{-# LANGUAGE CPP #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Effectful.FileSystem.Handle.Internal
  ( -- * Typed Handle
    Handle (..),
    unHandle,
    HandleMode (..),
    appendToMode,

    -- ** Type families
    CanRead,
    CanWrite,

    -- * Locks
    LockedHandle (..),
    unLockedHandle,
    liftLocked,

    -- ** Helpers
    liftLock,
    liftTryLock,
    liftUnlock,
    withLockedFile,
    withTryLockedFile,
  )
where

import Control.Exception.Utils (bracket)
import Data.Functor (($>), (<&>))
import Data.Kind (Constraint, Type)
import Effectful (Eff)
import GHC.Records (HasField, getField)
import GHC.Stack.Types (HasCallStack)

-- TODO: Drop once GHC 9.2 dropped.
#if MIN_VERSION_base(4, 17, 0)
import GHC.TypeError qualified as TE
#else
import GHC.TypeLits qualified as TE
#endif
import Optics.Core (A_Getter, LabelOptic (labelOptic), to)
import System.IO (IOMode (AppendMode, WriteMode))
import System.IO qualified as IO

-- | Possible handle modes.
--
-- @since 0.1
data HandleMode
  = -- | @since 0.1
    HandleModeRead
  | -- | @since 0.1
    HandleModeWrite
  | -- | @since 0.1
    HandleModeReadWrite

-- | Wrapper for file handles that includes an index for the mode.
--
-- @since 0.1
type Handle :: HandleMode -> Type
newtype Handle p = MkHandle IO.Handle

-- | @since 0.1
instance HasField "unHandle" (Handle p) IO.Handle where
  getField :: Handle p -> Handle
getField = Handle p -> Handle
forall (p :: HandleMode). Handle p -> Handle
unHandle

-- | @since 0.1
instance
  (k ~ A_Getter, a ~ IO.Handle, b ~ IO.Handle) =>
  LabelOptic "unHandle" k (Handle p) (Handle p) a b
  where
  labelOptic :: Optic k NoIx (Handle p) (Handle p) a b
labelOptic = (Handle p -> a) -> Getter (Handle p) a
forall s a. (s -> a) -> Getter s a
to Handle p -> a
Handle p -> Handle
forall (p :: HandleMode). Handle p -> Handle
unHandle
  {-# INLINE labelOptic #-}

-- | @since 0.1
unHandle :: Handle p -> IO.Handle
unHandle :: forall (p :: HandleMode). Handle p -> Handle
unHandle (MkHandle Handle
h) = Handle
h

{- ORMOLU_DISABLE -}

-- | @since 0.1
type CanRead :: HandleMode -> Constraint
type family CanRead hm where
  CanRead HandleModeRead = ()
#if MIN_VERSION_GLASGOW_HASKELL(9, 8, 1, 0)
  CanRead HandleModeWrite = TE.Unsatisfiable (TE.Text "HandleModeWrite does not have Read permission.")
#else
  CanRead HandleModeWrite = TE.TypeError (TE.Text "HandleModeWrite does not have Read permission.")
#endif
  CanRead HandleModeReadWrite = ()

-- | @since 0.1
type CanWrite :: HandleMode -> Constraint
type family CanWrite hm where
#if MIN_VERSION_GLASGOW_HASKELL(9, 8, 1, 0)
  CanWrite HandleModeRead = TE.Unsatisfiable (TE.Text "HandleModeRead does not have Write permission.")
#else
  CanWrite HandleModeRead = TE.TypeError (TE.Text "HandleModeRead does not have Write permission.")
#endif
  CanWrite HandleModeWrite = ()
  CanWrite HandleModeReadWrite = ()

{- ORMOLU_ENABLE -}

-- | File handle with lock.
--
-- @since 0.1
type LockedHandle :: HandleMode -> Type
newtype LockedHandle p = MkLockedHandle (Handle p)

-- | @since 0.1
instance HasField "unLockedHandle" (LockedHandle p) (Handle p) where
  getField :: LockedHandle p -> Handle p
getField = LockedHandle p -> Handle p
forall (p :: HandleMode). LockedHandle p -> Handle p
unLockedHandle

-- | @since 0.1
instance
  (k ~ A_Getter, a ~ Handle p, b ~ Handle p) =>
  LabelOptic "unLockedHandle" k (LockedHandle p) (LockedHandle p) a b
  where
  labelOptic :: Optic k NoIx (LockedHandle p) (LockedHandle p) a b
labelOptic = (LockedHandle p -> a) -> Getter (LockedHandle p) a
forall s a. (s -> a) -> Getter s a
to LockedHandle p -> a
LockedHandle p -> Handle p
forall (p :: HandleMode). LockedHandle p -> Handle p
unLockedHandle
  {-# INLINE labelOptic #-}

-- | @since 0.1
unLockedHandle :: LockedHandle p -> Handle p
unLockedHandle :: forall (p :: HandleMode). LockedHandle p -> Handle p
unLockedHandle (MkLockedHandle Handle p
h) = Handle p
h

liftLock ::
  (Functor f) =>
  (Handle p -> f ()) ->
  Handle p ->
  f (LockedHandle p)
liftLock :: forall (f :: * -> *) (p :: HandleMode).
Functor f =>
(Handle p -> f ()) -> Handle p -> f (LockedHandle p)
liftLock Handle p -> f ()
lockFn Handle p
handle = Handle p -> f ()
lockFn Handle p
handle f () -> LockedHandle p -> f (LockedHandle p)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Handle p -> LockedHandle p
forall (p :: HandleMode). Handle p -> LockedHandle p
MkLockedHandle Handle p
handle

liftTryLock ::
  (Functor f) =>
  (Handle p -> f Bool) ->
  Handle p ->
  f (Maybe (LockedHandle p))
liftTryLock :: forall (f :: * -> *) (p :: HandleMode).
Functor f =>
(Handle p -> f Bool) -> Handle p -> f (Maybe (LockedHandle p))
liftTryLock Handle p -> f Bool
tryLockFn Handle p
handle =
  Handle p -> f Bool
tryLockFn Handle p
handle f Bool
-> (Bool -> Maybe (LockedHandle p)) -> f (Maybe (LockedHandle p))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Bool
locked ->
    if Bool
locked
      then LockedHandle p -> Maybe (LockedHandle p)
forall a. a -> Maybe a
Just (Handle p -> LockedHandle p
forall (p :: HandleMode). Handle p -> LockedHandle p
MkLockedHandle Handle p
handle)
      else Maybe (LockedHandle p)
forall a. Maybe a
Nothing

liftUnlock ::
  (Functor f) =>
  (Handle p -> f ()) ->
  LockedHandle p ->
  f (Handle p)
liftUnlock :: forall (f :: * -> *) (p :: HandleMode).
Functor f =>
(Handle p -> f ()) -> LockedHandle p -> f (Handle p)
liftUnlock Handle p -> f ()
unlockFn (MkLockedHandle Handle p
handle) = Handle p -> f ()
unlockFn Handle p
handle f () -> Handle p -> f (Handle p)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Handle p
handle

-- | Runs a computation with a locked file.
withLockedFile ::
  (HasCallStack) =>
  -- | Lock function.
  (Handle p -> Eff es ()) ->
  -- | Unlock function.
  (Handle p -> Eff es ()) ->
  -- | Handle to lock.
  Handle p ->
  -- | Callback with locked handle.
  (LockedHandle p -> Eff es a) ->
  Eff es a
withLockedFile :: forall (p :: HandleMode) (es :: [Effect]) a.
HasCallStack =>
(Handle p -> Eff es ())
-> (Handle p -> Eff es ())
-> Handle p
-> (LockedHandle p -> Eff es a)
-> Eff es a
withLockedFile Handle p -> Eff es ()
lockFn Handle p -> Eff es ()
unlockFn Handle p
handle =
  Eff es (LockedHandle p)
-> (LockedHandle p -> Eff es (Handle p))
-> (LockedHandle p -> Eff es a)
-> Eff es a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket
    ((Handle p -> Eff es ()) -> Handle p -> Eff es (LockedHandle p)
forall (f :: * -> *) (p :: HandleMode).
Functor f =>
(Handle p -> f ()) -> Handle p -> f (LockedHandle p)
liftLock Handle p -> Eff es ()
lockFn Handle p
handle)
    ((Handle p -> Eff es ()) -> LockedHandle p -> Eff es (Handle p)
forall (f :: * -> *) (p :: HandleMode).
Functor f =>
(Handle p -> f ()) -> LockedHandle p -> f (Handle p)
liftUnlock Handle p -> Eff es ()
unlockFn)
{-# INLINEABLE withLockedFile #-}

-- | Like 'withSharedLockedFile', except the lock attempt does not block.
--
-- @since 0.1
withTryLockedFile ::
  forall p a es.
  (HasCallStack) =>
  -- | Lock function.
  (Handle p -> Eff es Bool) ->
  -- | Unlock function.
  (Handle p -> Eff es ()) ->
  -- | Handle to lock.
  Handle p ->
  -- | Handle callback.
  (LockedHandle p -> Eff es a) ->
  Eff es (Maybe a)
withTryLockedFile :: forall (p :: HandleMode) a (es :: [Effect]).
HasCallStack =>
(Handle p -> Eff es Bool)
-> (Handle p -> Eff es ())
-> Handle p
-> (LockedHandle p -> Eff es a)
-> Eff es (Maybe a)
withTryLockedFile Handle p -> Eff es Bool
tryLockFn Handle p -> Eff es ()
unlockFn Handle p
handle LockedHandle p -> Eff es a
onHandle =
  Eff es (Maybe (LockedHandle p))
-> (Maybe (LockedHandle p) -> Eff es (Maybe (Handle p)))
-> (Maybe (LockedHandle p) -> Eff es (Maybe a))
-> Eff es (Maybe a)
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket
    ((Handle p -> Eff es Bool)
-> Handle p -> Eff es (Maybe (LockedHandle p))
forall (f :: * -> *) (p :: HandleMode).
Functor f =>
(Handle p -> f Bool) -> Handle p -> f (Maybe (LockedHandle p))
liftTryLock Handle p -> Eff es Bool
tryLockFn Handle p
handle)
    ((LockedHandle p -> Eff es (Handle p))
-> Maybe (LockedHandle p) -> Eff es (Maybe (Handle p))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ((Handle p -> Eff es ()) -> LockedHandle p -> Eff es (Handle p)
forall (f :: * -> *) (p :: HandleMode).
Functor f =>
(Handle p -> f ()) -> LockedHandle p -> f (Handle p)
liftUnlock Handle p -> Eff es ()
unlockFn))
    ((LockedHandle p -> Eff es a)
-> Maybe (LockedHandle p) -> Eff es (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse LockedHandle p -> Eff es a
onHandle)
{-# INLINEABLE withTryLockedFile #-}

-- | Lifts a function on handle to one on locked handles.
--
-- @since 0.1
liftLocked ::
  forall p a.
  (HasCallStack) =>
  ((HasCallStack) => Handle p -> a) ->
  LockedHandle p ->
  a
liftLocked :: forall (p :: HandleMode) a.
HasCallStack =>
(HasCallStack => Handle p -> a) -> LockedHandle p -> a
liftLocked HasCallStack => Handle p -> a
onHandle (MkLockedHandle Handle p
h) = HasCallStack => Handle p -> a
Handle p -> a
onHandle Handle p
h
{-# INLINEABLE liftLocked #-}

appendToMode :: Bool -> IOMode
appendToMode :: Bool -> IOMode
appendToMode Bool
True = IOMode
AppendMode
appendToMode Bool
False = IOMode
WriteMode