{-# LANGUAGE Trustworthy #-}
-- |
-- Copyright: (c) 2021 Xy Ren
-- License: BSD3
-- Maintainer: xy.r@outlook.com
-- Stability: experimental
-- Portability: non-portable (GHC only)
module Cleff.Mask
  ( -- * Effect
    Mask (..)
    -- * High-level operations
  , bracket
  , bracketOnError
  , bracket_
  , bracketOnError_
  , onError
  , finally
    -- * Primitive operations
  , mask
  , uninterruptibleMask
  , onException
  , mask_
  , uninterruptibleMask_
    -- * Interpretations
  , runMask
  ) where

import           Cleff
import           Cleff.Internal.Base
import qualified Control.Exception   as Exc

-- * Effect

-- | An effect capable of 'Exc.mask'ing and performing cleanup operations when an computation is interrupted. In
-- particular, this effects allows the use of 'bracket'.
--
-- === Technical details
--
-- Regarding the nuances of 'bracket' semantics, this effect uses the semantics of "UnliftIO.Exception" rather than
-- "Control.Exception". They are more sensible defaults and users can implement other semantics out of the primitive
-- operations if they want to.
data Mask :: Effect where
  Mask :: ((m ~> m) -> m a) -> Mask m a
  UninterruptibleMask :: ((m ~> m) -> m a) -> Mask m a
  OnException :: m a -> m b -> Mask m a

-- * Operations

makeEffect_ ''Mask

-- | Prevents a computation from receiving asynchronous exceptions, i.e. being interrupted by another thread. Also
-- provides a function to restore receiving async exceptions for a computation.
--
-- However, some potentially blocking actions like @takeMVar@ can still be interrupted, and for them also not to be
-- interrupted in any case you'll need 'uninterruptibleMask'. See 'Control.Exception.mask' for details.
mask :: Mask :> es => ((Eff es ~> Eff es) -> Eff es a) -> Eff es a

-- | Prevents a computation from receiving asynchronous exceptions, even if there is an interruptible operation
-- (operations that potentially deadlocks or otherwise blocks indefinitely). Therefore this function is potentially
-- dangerous in the sense that it can make a thread both unresponsive and unkillable. See
-- 'Control.Exception.uninterruptibleMask' for details.
uninterruptibleMask :: Mask :> es => ((Eff es ~> Eff es) -> Eff es a) -> Eff es a

-- | Like 'onError', but without 'uninterruptibleMask'ing the cleanup action, making it possible that a cleanup action
-- is interrupted. Use 'onError' is usually the safer option.
onException :: Mask :> es
  => Eff es a -- ^ The main computation that may throw an exception
  -> Eff es b -- ^ The computation that runs when an exception is thrown
  -> Eff es a

-- | Run a computation that acquires a resource (@alloc@), then a main computation using that resource, then a cleanup
-- computation (@dealloc@). 'bracket' guarantees that @alloc@ and @dealloc@ will always run, regardless of whether an
-- exception is thrown in the main computation. Note that if an exception is thrown in the main computation, it will
-- be rethrown after 'bracket' finishes.
--
-- === Technical details
--
-- Note that this function uses @unliftio@ semantics: resource acquiring action is interruptibly 'mask'ed while
-- resource cleanup is 'uninterruptibleMask'ed. Most of the times, this will be what you want. Other functions in this
-- module use @unliftio@ semantics too.
bracket :: Mask :> es
  => Eff es a -- ^ The computation to run first, usually acquires a resource
  -> (a -> Eff es c) -- ^ The computation to run after the main computation, usually cleans up
  -> (a -> Eff es b) -- ^ The main computation that uses the resource
  -> Eff es b
bracket :: Eff es a -> (a -> Eff es c) -> (a -> Eff es b) -> Eff es b
bracket Eff es a
alloc a -> Eff es c
dealloc a -> Eff es b
action = ((Eff es ~> Eff es) -> Eff es b) -> Eff es b
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Mask :> es) =>
((Eff es ~> Eff es) -> Eff es a) -> Eff es a
mask \Eff es ~> Eff es
restore -> do
  a
res <- Eff es a
alloc
  b
ret <- Eff es b -> Eff es b
Eff es ~> Eff es
restore (a -> Eff es b
action a
res) Eff es b -> Eff es c -> Eff es b
forall (es :: [(Type -> Type) -> Type -> Type]) a b.
(Mask :> es) =>
Eff es a -> Eff es b -> Eff es a
`onError` a -> Eff es c
dealloc a
res
  c
_ <- Eff es c -> Eff es c
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Mask :> es) =>
Eff es a -> Eff es a
uninterruptibleMask_ (a -> Eff es c
dealloc a
res)
  b -> Eff es b
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure b
ret

-- | Like 'bracket', but only runs cleanup if an exception is thrown in the main computation.
bracketOnError :: Mask :> es
  => Eff es a -- ^ The computation to run first, usually acquires a resource
  -> (a -> Eff es c) -- ^ The computation to run when the main computation throws an exception, usually cleans up
  -> (a -> Eff es b) -- ^ The main computation that uses the resource
  -> Eff es b
bracketOnError :: Eff es a -> (a -> Eff es c) -> (a -> Eff es b) -> Eff es b
bracketOnError Eff es a
alloc a -> Eff es c
dealloc a -> Eff es b
action = ((Eff es ~> Eff es) -> Eff es b) -> Eff es b
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Mask :> es) =>
((Eff es ~> Eff es) -> Eff es a) -> Eff es a
mask \Eff es ~> Eff es
restore -> do
  a
res <- Eff es a
alloc
  Eff es b -> Eff es b
Eff es ~> Eff es
restore (a -> Eff es b
action a
res) Eff es b -> Eff es c -> Eff es b
forall (es :: [(Type -> Type) -> Type -> Type]) a b.
(Mask :> es) =>
Eff es a -> Eff es b -> Eff es a
`onError` a -> Eff es c
dealloc a
res

-- | Variant of 'mask' that does not provide a restoring function.
mask_ :: Mask :> es => Eff es a -> Eff es a
mask_ :: Eff es a -> Eff es a
mask_ Eff es a
m = ((Eff es ~> Eff es) -> Eff es a) -> Eff es a
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Mask :> es) =>
((Eff es ~> Eff es) -> Eff es a) -> Eff es a
mask \Eff es ~> Eff es
_ -> Eff es a
m

-- | Variant of 'uninterruptibleMask' that does not provide a restoring function.
uninterruptibleMask_ :: Mask :> es => Eff es a -> Eff es a
uninterruptibleMask_ :: Eff es a -> Eff es a
uninterruptibleMask_ Eff es a
m = ((Eff es ~> Eff es) -> Eff es a) -> Eff es a
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Mask :> es) =>
((Eff es ~> Eff es) -> Eff es a) -> Eff es a
uninterruptibleMask \Eff es ~> Eff es
_ -> Eff es a
m

-- | Variant of 'bracket' that does not pass the allocated resource to the cleanup action.
bracket_ :: Mask :> es => Eff es a -> Eff es c -> (a -> Eff es b) -> Eff es b
bracket_ :: Eff es a -> Eff es c -> (a -> Eff es b) -> Eff es b
bracket_ Eff es a
ma = Eff es a -> (a -> Eff es c) -> (a -> Eff es b) -> Eff es b
forall (es :: [(Type -> Type) -> Type -> Type]) a c b.
(Mask :> es) =>
Eff es a -> (a -> Eff es c) -> (a -> Eff es b) -> Eff es b
bracket Eff es a
ma ((a -> Eff es c) -> (a -> Eff es b) -> Eff es b)
-> (Eff es c -> a -> Eff es c)
-> Eff es c
-> (a -> Eff es b)
-> Eff es b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff es c -> a -> Eff es c
forall a b. a -> b -> a
const

-- | Variant of 'bracketOnError' that does not pass the allocated resource to the cleanup action.
bracketOnError_ :: Mask :> es => Eff es a -> Eff es c -> (a -> Eff es b) -> Eff es b
bracketOnError_ :: Eff es a -> Eff es c -> (a -> Eff es b) -> Eff es b
bracketOnError_ Eff es a
ma = Eff es a -> (a -> Eff es c) -> (a -> Eff es b) -> Eff es b
forall (es :: [(Type -> Type) -> Type -> Type]) a c b.
(Mask :> es) =>
Eff es a -> (a -> Eff es c) -> (a -> Eff es b) -> Eff es b
bracketOnError Eff es a
ma ((a -> Eff es c) -> (a -> Eff es b) -> Eff es b)
-> (Eff es c -> a -> Eff es c)
-> Eff es c
-> (a -> Eff es b)
-> Eff es b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff es c -> a -> Eff es c
forall a b. a -> b -> a
const

-- | Attach an action that runs if the main computation throws an exception. Note that this will rethrow the exception
-- instead of returning to normal control flow.
--
-- The cleanup action is guaranteed not to be interrupted halfways.
onError :: Mask :> es
  => Eff es a -- ^ The main computation that may throw an exception
  -> Eff es b -- ^ The computation that runs when an exception is thrown
  -> Eff es a
onError :: Eff es a -> Eff es b -> Eff es a
onError Eff es a
m Eff es b
n = Eff es a
m Eff es a -> Eff es b -> Eff es a
forall (es :: [(Type -> Type) -> Type -> Type]) a b.
(Mask :> es) =>
Eff es a -> Eff es b -> Eff es a
`onException` Eff es b -> Eff es b
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Mask :> es) =>
Eff es a -> Eff es a
uninterruptibleMask_ Eff es b
n

-- | Attach a cleanup action that will always run after a potentially throwing computation.
finally :: Mask :> es
  => Eff es a -- ^ The main computation that may throw an exception
  -> Eff es b -- ^ The computation that runs after the main computation, regardless of whether an exception is thrown
  -> Eff es a
finally :: Eff es a -> Eff es b -> Eff es a
finally Eff es a
m Eff es b
mz = (Eff es a
m Eff es a -> Eff es b -> Eff es a
forall (es :: [(Type -> Type) -> Type -> Type]) a b.
(Mask :> es) =>
Eff es a -> Eff es b -> Eff es a
`onError` Eff es b
mz) Eff es a -> Eff es b -> Eff es a
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* Eff es b -> Eff es b
forall (es :: [(Type -> Type) -> Type -> Type]) a.
(Mask :> es) =>
Eff es a -> Eff es a
uninterruptibleMask_ Eff es b
mz

-- * Interpretations

-- | Interpret the 'Mask' effect in terms of primitive 'IO' actions.
runMask :: Eff (Mask ': es) ~> Eff es
runMask :: Eff (Mask : es) a -> Eff es a
runMask = Eff (IOE : es) a -> Eff es a
forall (es :: [(Type -> Type) -> Type -> Type]).
Eff (IOE : es) ~> Eff es
thisIsPureTrustMe (Eff (IOE : es) a -> Eff es a)
-> (Eff (Mask : es) a -> Eff (IOE : es) a)
-> Eff (Mask : es) a
-> Eff es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handler Mask (IOE : es) -> Eff (Mask : es) ~> Eff (IOE : es)
forall (e' :: (Type -> Type) -> Type -> Type)
       (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
Handler e (e' : es) -> Eff (e : es) ~> Eff (e' : es)
reinterpret \case
  Mask f -> ((Eff esSend ~> IO) -> IO a) -> Eff (IOE : es) a
forall (esSend :: [(Type -> Type) -> Type -> Type])
       (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(Handling esSend e es, IOE :> es) =>
((Eff esSend ~> IO) -> IO a) -> Eff es a
withToIO \Eff esSend ~> IO
toIO -> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
Exc.mask \forall a. IO a -> IO a
restore -> Eff esSend a -> IO a
Eff esSend ~> IO
toIO (Eff esSend a -> IO a) -> Eff esSend a -> IO a
forall a b. (a -> b) -> a -> b
$ (Eff esSend ~> Eff esSend) -> Eff esSend a
f (IO a -> Eff esSend a
forall (esSend :: [(Type -> Type) -> Type -> Type])
       (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
(Handling esSend e es, IOE :> es) =>
IO ~> Eff esSend
fromIO (IO a -> Eff esSend a)
-> (Eff esSend a -> IO a) -> Eff esSend a -> Eff esSend a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO a
forall a. IO a -> IO a
restore (IO a -> IO a) -> (Eff esSend a -> IO a) -> Eff esSend a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff esSend a -> IO a
Eff esSend ~> IO
toIO)
  UninterruptibleMask f -> ((Eff esSend ~> IO) -> IO a) -> Eff (IOE : es) a
forall (esSend :: [(Type -> Type) -> Type -> Type])
       (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(Handling esSend e es, IOE :> es) =>
((Eff esSend ~> IO) -> IO a) -> Eff es a
withToIO \Eff esSend ~> IO
toIO -> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
Exc.uninterruptibleMask \forall a. IO a -> IO a
restore -> Eff esSend a -> IO a
Eff esSend ~> IO
toIO (Eff esSend a -> IO a) -> Eff esSend a -> IO a
forall a b. (a -> b) -> a -> b
$ (Eff esSend ~> Eff esSend) -> Eff esSend a
f (IO a -> Eff esSend a
forall (esSend :: [(Type -> Type) -> Type -> Type])
       (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]).
(Handling esSend e es, IOE :> es) =>
IO ~> Eff esSend
fromIO (IO a -> Eff esSend a)
-> (Eff esSend a -> IO a) -> Eff esSend a -> Eff esSend a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO a
forall a. IO a -> IO a
restore (IO a -> IO a) -> (Eff esSend a -> IO a) -> Eff esSend a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff esSend a -> IO a
Eff esSend ~> IO
toIO)
  OnException m n -> ((Eff esSend ~> IO) -> IO a) -> Eff (IOE : es) a
forall (esSend :: [(Type -> Type) -> Type -> Type])
       (e :: (Type -> Type) -> Type -> Type)
       (es :: [(Type -> Type) -> Type -> Type]) a.
(Handling esSend e es, IOE :> es) =>
((Eff esSend ~> IO) -> IO a) -> Eff es a
withToIO \Eff esSend ~> IO
toIO -> Eff esSend a -> IO a
Eff esSend ~> IO
toIO Eff esSend a
m IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exc.catch` \(SomeException
e :: Exc.SomeException) ->
    IO b -> IO (Either SomeException b)
forall e a. Exception e => IO a -> IO (Either e a)
Exc.try @Exc.SomeException (Eff esSend b -> IO b
Eff esSend ~> IO
toIO Eff esSend b
n) IO (Either SomeException b) -> IO a -> IO a
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> SomeException -> IO a
forall e a. Exception e => e -> IO a
Exc.throwIO SomeException
e
{-# INLINE runMask #-}