{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_HADDOCK not-home #-}
-- |
-- Copyright: (c) 2021 Xy Ren
-- License: BSD3
-- Maintainer: xy.r@outlook.com
-- Stability: unstable
-- Portability: non-portable (GHC only)
--
-- This module contains the definition of the 'Eff' monad. Most of the times, you won't need to use this module
-- directly; user-facing functionalities are all exported via the "Cleff" module.
--
-- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be
-- extra careful if you're to depend on this module.
module Cleff.Internal.Monad
  ( -- * The 'Eff' monad
    InternalHandler (InternalHandler, runHandler), Eff (Eff, unEff)
  , -- * Effect environment
    Env, HandlerPtr, emptyEnv, adjustEnv, allocaEnv, readEnv, writeEnv, replaceEnv, appendEnv, updateEnv
  , -- * Performing effect operations
    KnownList, Subset, send, sendVia
  ) where

import           Cleff.Internal.Any
import           Cleff.Internal.Effect
import           Control.Monad.Fix          (MonadFix)
import           Control.Monad.Trans.Reader (ReaderT (ReaderT))
import           Data.IntMap.Strict         (IntMap)
import qualified Data.IntMap.Strict         as Map
import           Data.Rec.SmallArray        (KnownList, Rec, Subset, pattern (:~:))
import qualified Data.Rec.SmallArray        as Rec
import           Type.Reflection            (Typeable, typeRep)

-- * The 'Eff' monad

-- | The internal representation of effect handlers. This is just a natural transformation from the effect type
-- @e ('Eff' es)@ to the effect monad @'Eff' es@ for any effect stack @es@.
--
-- In interpreting functions (see "Cleff.Internal.Interpret"), the user-facing 'Cleff.Handler' type is transformed into
-- this type.
newtype InternalHandler e = InternalHandler
  { InternalHandler e
-> forall (es :: [Effect]) a. e (Eff es) a -> Eff es a
runHandler :: ∀ es. e (Eff es) ~> Eff es }

-- | @
-- 'show' (handler :: 'InternalHandler' E) == "Handler E"
-- @
instance Typeable e => Show (InternalHandler e) where
  showsPrec :: Int -> InternalHandler e -> ShowS
showsPrec Int
p InternalHandler e
_ = (String
"Handler " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TypeRep e -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p (Typeable e => TypeRep e
forall k (a :: k). Typeable a => TypeRep a
typeRep @e)

-- | The extensible effect monad. A monad @'Eff' es@ is capable of performing any effect in the /effect stack/ @es@,
-- which is a type-level list that holds all effects available. However, most of the times, for flexibility, @es@
-- should be a polymorphic type variable, and you should use the '(:>)' and '(:>>)' operators in constraints to
-- indicate what effects are in the stack. For example,
--
-- @
-- 'Cleff.Reader.Reader' 'String' ':>' es, 'Cleff.State.State' 'Bool' ':>' es => 'Eff' es 'Integer'
-- @
--
-- allows you to perform operations of the @'Cleff.Reader.Reader' 'String'@ effect and the @'Cleff.State.State' 'Bool'@
-- effect in a computation returning an 'Integer'.
type role Eff nominal representational
newtype Eff es a = Eff { Eff es a -> Env es -> IO a
unEff :: Env es -> IO a }
  -- ^ The effect monad receives an effect environment 'Env' that contains all effect handlers and produces an 'IO'
  -- action.
  deriving newtype (b -> Eff es a -> Eff es a
NonEmpty (Eff es a) -> Eff es a
Eff es a -> Eff es a -> Eff es a
(Eff es a -> Eff es a -> Eff es a)
-> (NonEmpty (Eff es a) -> Eff es a)
-> (forall b. Integral b => b -> Eff es a -> Eff es a)
-> Semigroup (Eff es a)
forall (es :: [Effect]) a.
Semigroup a =>
NonEmpty (Eff es a) -> Eff es a
forall (es :: [Effect]) a.
Semigroup a =>
Eff es a -> Eff es a -> Eff es a
forall (es :: [Effect]) a b.
(Semigroup a, Integral b) =>
b -> Eff es a -> Eff es a
forall b. Integral b => b -> Eff es a -> Eff es a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Eff es a -> Eff es a
$cstimes :: forall (es :: [Effect]) a b.
(Semigroup a, Integral b) =>
b -> Eff es a -> Eff es a
sconcat :: NonEmpty (Eff es a) -> Eff es a
$csconcat :: forall (es :: [Effect]) a.
Semigroup a =>
NonEmpty (Eff es a) -> Eff es a
<> :: Eff es a -> Eff es a -> Eff es a
$c<> :: forall (es :: [Effect]) a.
Semigroup a =>
Eff es a -> Eff es a -> Eff es a
Semigroup, Semigroup (Eff es a)
Eff es a
Semigroup (Eff es a)
-> Eff es a
-> (Eff es a -> Eff es a -> Eff es a)
-> ([Eff es a] -> Eff es a)
-> Monoid (Eff es a)
[Eff es a] -> Eff es a
Eff es a -> Eff es a -> Eff es a
forall (es :: [Effect]) a. Monoid a => Semigroup (Eff es a)
forall (es :: [Effect]) a. Monoid a => Eff es a
forall (es :: [Effect]) a. Monoid a => [Eff es a] -> Eff es a
forall (es :: [Effect]) a.
Monoid a =>
Eff es a -> Eff es a -> Eff es a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Eff es a] -> Eff es a
$cmconcat :: forall (es :: [Effect]) a. Monoid a => [Eff es a] -> Eff es a
mappend :: Eff es a -> Eff es a -> Eff es a
$cmappend :: forall (es :: [Effect]) a.
Monoid a =>
Eff es a -> Eff es a -> Eff es a
mempty :: Eff es a
$cmempty :: forall (es :: [Effect]) a. Monoid a => Eff es a
$cp1Monoid :: forall (es :: [Effect]) a. Monoid a => Semigroup (Eff es a)
Monoid)
  deriving (a -> Eff es b -> Eff es a
(a -> b) -> Eff es a -> Eff es b
(forall a b. (a -> b) -> Eff es a -> Eff es b)
-> (forall a b. a -> Eff es b -> Eff es a) -> Functor (Eff es)
forall (es :: [Effect]) a b. a -> Eff es b -> Eff es a
forall (es :: [Effect]) a b. (a -> b) -> Eff es a -> Eff es b
forall a b. a -> Eff es b -> Eff es a
forall a b. (a -> b) -> Eff es a -> Eff es b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Eff es b -> Eff es a
$c<$ :: forall (es :: [Effect]) a b. a -> Eff es b -> Eff es a
fmap :: (a -> b) -> Eff es a -> Eff es b
$cfmap :: forall (es :: [Effect]) a b. (a -> b) -> Eff es a -> Eff es b
Functor, Functor (Eff es)
a -> Eff es a
Functor (Eff es)
-> (forall a. a -> Eff es a)
-> (forall a b. Eff es (a -> b) -> Eff es a -> Eff es b)
-> (forall a b c.
    (a -> b -> c) -> Eff es a -> Eff es b -> Eff es c)
-> (forall a b. Eff es a -> Eff es b -> Eff es b)
-> (forall a b. Eff es a -> Eff es b -> Eff es a)
-> Applicative (Eff es)
Eff es a -> Eff es b -> Eff es b
Eff es a -> Eff es b -> Eff es a
Eff es (a -> b) -> Eff es a -> Eff es b
(a -> b -> c) -> Eff es a -> Eff es b -> Eff es c
forall (es :: [Effect]). Functor (Eff es)
forall (es :: [Effect]) a. a -> Eff es a
forall (es :: [Effect]) a b. Eff es a -> Eff es b -> Eff es a
forall (es :: [Effect]) a b. Eff es a -> Eff es b -> Eff es b
forall (es :: [Effect]) a b.
Eff es (a -> b) -> Eff es a -> Eff es b
forall (es :: [Effect]) a b c.
(a -> b -> c) -> Eff es a -> Eff es b -> Eff es c
forall a. a -> Eff es a
forall a b. Eff es a -> Eff es b -> Eff es a
forall a b. Eff es a -> Eff es b -> Eff es b
forall a b. Eff es (a -> b) -> Eff es a -> Eff es b
forall a b c. (a -> b -> c) -> Eff es a -> Eff es b -> Eff es c
forall (f :: Type -> Type).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Eff es a -> Eff es b -> Eff es a
$c<* :: forall (es :: [Effect]) a b. Eff es a -> Eff es b -> Eff es a
*> :: Eff es a -> Eff es b -> Eff es b
$c*> :: forall (es :: [Effect]) a b. Eff es a -> Eff es b -> Eff es b
liftA2 :: (a -> b -> c) -> Eff es a -> Eff es b -> Eff es c
$cliftA2 :: forall (es :: [Effect]) a b c.
(a -> b -> c) -> Eff es a -> Eff es b -> Eff es c
<*> :: Eff es (a -> b) -> Eff es a -> Eff es b
$c<*> :: forall (es :: [Effect]) a b.
Eff es (a -> b) -> Eff es a -> Eff es b
pure :: a -> Eff es a
$cpure :: forall (es :: [Effect]) a. a -> Eff es a
$cp1Applicative :: forall (es :: [Effect]). Functor (Eff es)
Applicative, Applicative (Eff es)
a -> Eff es a
Applicative (Eff es)
-> (forall a b. Eff es a -> (a -> Eff es b) -> Eff es b)
-> (forall a b. Eff es a -> Eff es b -> Eff es b)
-> (forall a. a -> Eff es a)
-> Monad (Eff es)
Eff es a -> (a -> Eff es b) -> Eff es b
Eff es a -> Eff es b -> Eff es b
forall (es :: [Effect]). Applicative (Eff es)
forall (es :: [Effect]) a. a -> Eff es a
forall (es :: [Effect]) a b. Eff es a -> Eff es b -> Eff es b
forall (es :: [Effect]) a b.
Eff es a -> (a -> Eff es b) -> Eff es b
forall a. a -> Eff es a
forall a b. Eff es a -> Eff es b -> Eff es b
forall a b. Eff es a -> (a -> Eff es b) -> Eff es b
forall (m :: Type -> Type).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Eff es a
$creturn :: forall (es :: [Effect]) a. a -> Eff es a
>> :: Eff es a -> Eff es b -> Eff es b
$c>> :: forall (es :: [Effect]) a b. Eff es a -> Eff es b -> Eff es b
>>= :: Eff es a -> (a -> Eff es b) -> Eff es b
$c>>= :: forall (es :: [Effect]) a b.
Eff es a -> (a -> Eff es b) -> Eff es b
$cp1Monad :: forall (es :: [Effect]). Applicative (Eff es)
Monad, Monad (Eff es)
Monad (Eff es)
-> (forall a. (a -> Eff es a) -> Eff es a) -> MonadFix (Eff es)
(a -> Eff es a) -> Eff es a
forall (es :: [Effect]). Monad (Eff es)
forall (es :: [Effect]) a. (a -> Eff es a) -> Eff es a
forall a. (a -> Eff es a) -> Eff es a
forall (m :: Type -> Type).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
mfix :: (a -> Eff es a) -> Eff es a
$cmfix :: forall (es :: [Effect]) a. (a -> Eff es a) -> Eff es a
$cp1MonadFix :: forall (es :: [Effect]). Monad (Eff es)
MonadFix) via (ReaderT (Env es) IO)

-- * Effect environment

-- | The /effect environment/ that corresponds effects in the stack to their respective 'InternalHandler's. This
-- structure simulates memory: handlers are retrieved via pointers ('HandlerPtr's), and for each effect in the stack
-- we can either change what pointer it uses or change the handler the pointer points to. The former is used for global
-- effect interpretation ('Cleff.reinterpretN') and the latter for local interpretation ('Cleff.toEffWith') in order to
-- retain correct HO semantics. For more details on this see https://github.com/re-xyr/cleff/issues/5.
type role Env nominal
data Env (es :: [Effect]) = Env
  {-# UNPACK #-} !(Rec HandlerPtr es) -- ^ The array.
  {-# UNPACK #-} !Int -- ^ The next memory address to allocate.
  !(IntMap Any) -- ^ The simulated memory.

-- | A pointer to 'InternalHandler' in an 'Env'.
type role HandlerPtr nominal
newtype HandlerPtr (e :: Effect) = HandlerPtr { HandlerPtr e -> Int
unHandlerPtr :: Int }
  deriving newtype
    ( Eq  -- ^ Pointer equality.
    , Ord -- ^ An arbitrary total order on the pointers.
    )

-- | Create an empty 'Env' with no address allocated.
emptyEnv :: Env '[]
emptyEnv :: Env '[]
emptyEnv = Rec HandlerPtr '[] -> Int -> IntMap Any -> Env '[]
forall (es :: [Effect]).
Rec HandlerPtr es -> Int -> IntMap Any -> Env es
Env Rec HandlerPtr '[]
forall k (f :: k -> Type). Rec f '[]
Rec.empty Int
0 IntMap Any
forall a. IntMap a
Map.empty
{-# INLINE emptyEnv #-}

-- | Adjust the effect stack via an function over 'Rec'.
adjustEnv :: ∀ es' es. (Rec HandlerPtr es -> Rec HandlerPtr es') -> Env es -> Env es'
adjustEnv :: (Rec HandlerPtr es -> Rec HandlerPtr es') -> Env es -> Env es'
adjustEnv Rec HandlerPtr es -> Rec HandlerPtr es'
f (Env Rec HandlerPtr es
re Int
n IntMap Any
mem) = Rec HandlerPtr es' -> Int -> IntMap Any -> Env es'
forall (es :: [Effect]).
Rec HandlerPtr es -> Int -> IntMap Any -> Env es
Env (Rec HandlerPtr es -> Rec HandlerPtr es'
f Rec HandlerPtr es
re) Int
n IntMap Any
mem
{-# INLINE adjustEnv #-}

-- | Allocate a new, empty address for a handler. \( O(1) \).
allocaEnv :: ∀ e es. Env es -> (# HandlerPtr e, Env es #)
allocaEnv :: Env es -> (# HandlerPtr e, Env es #)
allocaEnv (Env Rec HandlerPtr es
re Int
n IntMap Any
mem) = (# Int -> HandlerPtr e
forall (e :: Effect). Int -> HandlerPtr e
HandlerPtr Int
n, Rec HandlerPtr es -> Int -> IntMap Any -> Env es
forall (es :: [Effect]).
Rec HandlerPtr es -> Int -> IntMap Any -> Env es
Env Rec HandlerPtr es
re (Int -> Int
forall a. Enum a => a -> a
succ Int
n) IntMap Any
mem #)
{-# INLINE allocaEnv #-}

-- | Read the handler a pointer points to. \( O(1) \).
readEnv :: ∀ e es. Rec.Elem e es => Env es -> InternalHandler e
readEnv :: Env es -> InternalHandler e
readEnv (Env Rec HandlerPtr es
re Int
_ IntMap Any
mem) = Any -> InternalHandler e
forall a. Any -> a
fromAny (Any -> InternalHandler e) -> Any -> InternalHandler e
forall a b. (a -> b) -> a -> b
$ IntMap Any
mem IntMap Any -> Int -> Any
forall a. IntMap a -> Int -> a
Map.! HandlerPtr e -> Int
forall (e :: Effect). HandlerPtr e -> Int
unHandlerPtr (Rec HandlerPtr es -> HandlerPtr e
forall k (e :: k) (es :: [k]) (f :: k -> Type).
Elem e es =>
Rec f es -> f e
Rec.index @e Rec HandlerPtr es
re)
{-# INLINE readEnv #-}

-- | Overwrite the handler a pointer points to. \( O(1) \).
writeEnv :: ∀ e es. HandlerPtr e -> InternalHandler e -> Env es -> Env es
writeEnv :: HandlerPtr e -> InternalHandler e -> Env es -> Env es
writeEnv (HandlerPtr Int
m) InternalHandler e
x (Env Rec HandlerPtr es
re Int
n IntMap Any
mem) = Rec HandlerPtr es -> Int -> IntMap Any -> Env es
forall (es :: [Effect]).
Rec HandlerPtr es -> Int -> IntMap Any -> Env es
Env Rec HandlerPtr es
re Int
n (Int -> Any -> IntMap Any -> IntMap Any
forall a. Int -> a -> IntMap a -> IntMap a
Map.insert Int
m (InternalHandler e -> Any
forall a. a -> Any
toAny InternalHandler e
x) IntMap Any
mem)
{-# INLINE writeEnv #-}

-- | Replace the handler pointer of an effect in the stack. \( O(n) \).
replaceEnv :: ∀ e es. Rec.Elem e es => HandlerPtr e -> InternalHandler e -> Env es -> Env es
replaceEnv :: HandlerPtr e -> InternalHandler e -> Env es -> Env es
replaceEnv (HandlerPtr Int
m) InternalHandler e
x (Env Rec HandlerPtr es
re Int
n IntMap Any
mem) = Rec HandlerPtr es -> Int -> IntMap Any -> Env es
forall (es :: [Effect]).
Rec HandlerPtr es -> Int -> IntMap Any -> Env es
Env (HandlerPtr e -> Rec HandlerPtr es -> Rec HandlerPtr es
forall k (e :: k) (es :: [k]) (f :: k -> Type).
Elem e es =>
f e -> Rec f es -> Rec f es
Rec.update @e (Int -> HandlerPtr e
forall (e :: Effect). Int -> HandlerPtr e
HandlerPtr Int
m) Rec HandlerPtr es
re) Int
n (Int -> Any -> IntMap Any -> IntMap Any
forall a. Int -> a -> IntMap a -> IntMap a
Map.insert Int
m (InternalHandler e -> Any
forall a. a -> Any
toAny InternalHandler e
x) IntMap Any
mem)
{-# INLINE replaceEnv #-}

-- | Add a new effect to the stack with its corresponding handler pointer. \( O(n) \).
appendEnv :: ∀ e es. HandlerPtr e -> InternalHandler e -> Env es -> Env (e ': es)
appendEnv :: HandlerPtr e -> InternalHandler e -> Env es -> Env (e : es)
appendEnv (HandlerPtr Int
m) InternalHandler e
x (Env Rec HandlerPtr es
re Int
n IntMap Any
mem) = Rec HandlerPtr (e : es) -> Int -> IntMap Any -> Env (e : es)
forall (es :: [Effect]).
Rec HandlerPtr es -> Int -> IntMap Any -> Env es
Env (Int -> HandlerPtr e
forall (e :: Effect). Int -> HandlerPtr e
HandlerPtr Int
m HandlerPtr e -> Rec HandlerPtr es -> Rec HandlerPtr (e : es)
forall a (f :: a -> Type) (e :: a) (es :: [a]).
f e -> Rec f es -> Rec f (e : es)
:~: Rec HandlerPtr es
re) Int
n (Int -> Any -> IntMap Any -> IntMap Any
forall a. Int -> a -> IntMap a -> IntMap a
Map.insert Int
m (InternalHandler e -> Any
forall a. a -> Any
toAny InternalHandler e
x) IntMap Any
mem)
{-# INLINE appendEnv #-}

-- | Use the state of LHS as a newer version for RHS. \( O(1) \).
updateEnv :: ∀ es es'. Env es' -> Env es -> Env es
updateEnv :: Env es' -> Env es -> Env es
updateEnv (Env Rec HandlerPtr es'
_ Int
n IntMap Any
mem) (Env Rec HandlerPtr es
re' Int
_ IntMap Any
_) = Rec HandlerPtr es -> Int -> IntMap Any -> Env es
forall (es :: [Effect]).
Rec HandlerPtr es -> Int -> IntMap Any -> Env es
Env Rec HandlerPtr es
re' Int
n IntMap Any
mem
{-# INLINE updateEnv #-}

-- * Performing effect operations

-- | Perform an effect operation, /i.e./ a value of an effect type @e :: 'Effect'@. This requires @e@ to be in the
-- effect stack.
send :: e :> es => e (Eff es) ~> Eff es
send :: e (Eff es) ~> Eff es
send = (Eff es ~> Eff es) -> e (Eff es) ~> Eff es
forall (e :: Effect) (es' :: [Effect]) (es :: [Effect]).
(e :> es') =>
(Eff es ~> Eff es') -> e (Eff es) ~> Eff es'
sendVia forall a. a -> a
Eff es ~> Eff es
id

-- | Perform an action in another effect stack via a transformation to that stack; in other words, this function "maps"
-- the effect operation from effect stack @es@ to @es'@. This is a generalization of 'send'; end users most likely
-- won't need to use this.
--
-- @
-- 'send' = 'sendVia' 'id'
-- @
sendVia :: e :> es' => (Eff es ~> Eff es') -> e (Eff es) ~> Eff es'
sendVia :: (Eff es ~> Eff es') -> e (Eff es) ~> Eff es'
sendVia Eff es ~> Eff es'
f e (Eff es) a
e = (Env es' -> IO a) -> Eff es' a
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
Eff \Env es'
es -> Eff es' a -> Env es' -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
unEff (Eff es a -> Eff es' a
Eff es ~> Eff es'
f (InternalHandler e -> e (Eff es) a -> Eff es a
forall (e :: Effect).
InternalHandler e
-> forall (es :: [Effect]) a. e (Eff es) a -> Eff es a
runHandler (Env es' -> InternalHandler e
forall (e :: Effect) (es :: [Effect]).
Elem e es =>
Env es -> InternalHandler e
readEnv Env es'
es) e (Eff es) a
e)) Env es'
es