{-# 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 (..)
  , -- * Operations
    mask, uninterruptibleMask, bracket, bracketOnError, mask_, uninterruptibleMask_, bracket_, finally, onError
  , -- * Interpretations
    runMask
  ) where

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

-- * Effect

-- | An effect capable of 'Exc.mask'ing and specifically, 'Exc.bracket'ing operations, /i.e./ allowing cleanup after
-- operations that my raise exceptions.
data Mask :: Effect where
  Mask :: ((m ~> m) -> m a) -> Mask m a
  UninterruptibleMask :: ((m ~> m) -> m a) -> Mask m a
  Bracket :: m a -> (a -> m c) -> (a -> m b) -> Mask m b
  BracketOnError :: m a -> (a -> m c) -> (a -> m b) -> Mask m b

-- * Operations

makeEffect ''Mask

-- | 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

-- | Attach a cleanup action that will always run to a potentially throwing computation.
finally :: Mask :> es => Eff es a -> Eff es b -> Eff es a
finally :: Eff es a -> Eff es b -> Eff es a
finally Eff es a
m Eff es b
mz = Eff es () -> Eff es b -> (() -> Eff es a) -> Eff es a
forall (es :: [(Type -> Type) -> Type -> Type]) a c b.
(Mask :> es) =>
Eff es a -> Eff es c -> (a -> Eff es b) -> Eff es b
bracket_ (() -> Eff es ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()) Eff es b
mz (Eff es a -> () -> Eff es a
forall a b. a -> b -> a
const Eff es a
m)

-- | Attach an action that runs if the main computation throws an exception.
onError :: Mask :> es => Eff es a -> Eff es b -> Eff es a
onError :: Eff es a -> Eff es b -> Eff es a
onError Eff es a
m Eff es b
mz = Eff es () -> (() -> Eff es b) -> (() -> Eff es a) -> Eff es a
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 ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()) (Eff es b -> () -> Eff es b
forall a b. a -> b -> a
const Eff es b
mz) (Eff es a -> () -> Eff es a
forall a b. a -> b -> a
const Eff es a
m)

-- * 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 (m :: Type -> Type) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m 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 (m :: Type -> Type) b.
MonadUnliftIO m =>
((forall a. m a -> m a) -> m b) -> m 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)
  Bracket ma mz m        -> ((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 -> IO a -> (a -> IO c) -> (a -> IO a) -> IO a
forall (m :: Type -> Type) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
Exc.bracket (Eff esSend a -> IO a
Eff esSend ~> IO
toIO Eff esSend a
ma) (Eff esSend c -> IO c
Eff esSend ~> IO
toIO (Eff esSend c -> IO c) -> (a -> Eff esSend c) -> a -> IO c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Eff esSend c
mz) (Eff esSend a -> IO a
Eff esSend ~> IO
toIO (Eff esSend a -> IO a) -> (a -> Eff esSend a) -> a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Eff esSend a
m)
  BracketOnError ma mz m -> ((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 -> IO a -> (a -> IO c) -> (a -> IO a) -> IO a
forall (m :: Type -> Type) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
Exc.bracketOnError (Eff esSend a -> IO a
Eff esSend ~> IO
toIO Eff esSend a
ma) (Eff esSend c -> IO c
Eff esSend ~> IO
toIO (Eff esSend c -> IO c) -> (a -> Eff esSend c) -> a -> IO c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Eff esSend c
mz) (Eff esSend a -> IO a
Eff esSend ~> IO
toIO (Eff esSend a -> IO a) -> (a -> Eff esSend a) -> a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Eff esSend a
m)
{-# INLINE runMask #-}