module Data.Extensible.Effect (
Instruction(..)
, Eff
, liftEff
, liftsEff
, hoistEff
, Interpreter(..)
, handleEff
, peelEff
, Rebinder
, rebindEff0
, rebindEff1
, peelEff1
, rebindEff2
, leaveEff
, retractEff
, Action(..)
, Function
, runAction
, (@!?)
, peelAction
, peelAction0
, ReaderEff
, askEff
, asksEff
, localEff
, runReaderEff
, State
, getEff
, getsEff
, putEff
, modifyEff
, stateEff
, runStateEff
, execStateEff
, WriterEff
, writerEff
, tellEff
, listenEff
, passEff
, runWriterEff
, execWriterEff
, MaybeEff
, runMaybeEff
, EitherEff
, throwEff
, catchEff
, runEitherEff
, Identity
, tickEff
, runIterEff
) where
import Control.Applicative
import Control.Monad.Skeleton
import Control.Monad.Trans.State.Strict
import Data.Extensible.Field
import Data.Extensible.Internal
import Data.Extensible.Internal.Rig
import Data.Extensible.Class
import Data.Functor.Identity
import Data.Profunctor.Unsafe
data Instruction (xs :: [Assoc k (* -> *)]) a where
Instruction :: !(Membership xs kv) -> AssocValue kv a -> Instruction xs a
type Eff xs = Skeleton (Instruction xs)
liftEff :: forall s t xs a. Associate s t xs => Proxy s -> t a -> Eff xs a
liftEff p x = liftsEff p x id
liftsEff :: forall s t xs a r. Associate s t xs
=> Proxy s -> t a -> (a -> r) -> Eff xs r
liftsEff _ x k = boned
$ Instruction (association :: Membership xs (s ':> t)) x :>>= return . k
hoistEff :: forall s t xs a. Associate s t xs => Proxy s -> (forall x. t x -> t x) -> Eff xs a -> Eff xs a
hoistEff _ f = hoistSkeleton $ \(Instruction i t) -> case compareMembership (association :: Membership xs (s ':> t)) i of
Right Refl -> Instruction i (f t)
_ -> Instruction i t
peelEff :: forall k t xs a r
. Rebinder xs r
-> (a -> r)
-> (forall x. t x -> (x -> r) -> r)
-> Eff (k >: t ': xs) a -> r
peelEff pass ret wrap = go where
go m = case debone m of
Return a -> ret a
Instruction i t :>>= k -> runMembership i
(\Refl -> wrap t (go . k))
(\j -> pass (Instruction j t) (go . k))
peelEff1 :: (a -> b -> Eff xs r)
-> (forall x. t x -> (x -> b -> Eff xs r) -> b -> Eff xs r)
-> Eff (k >: t ': xs) a -> b -> Eff xs r
peelEff1 = peelEff rebindEff1
type Rebinder xs r = forall x. Instruction xs x -> (x -> r) -> r
rebindEff0 :: Rebinder xs (Eff xs r)
rebindEff0 i k = boned (i :>>= k)
rebindEff1 :: Rebinder xs (a -> Eff xs r)
rebindEff1 i k a = boned (i :>>= flip k a)
rebindEff2 :: Rebinder xs (a -> b -> Eff xs r)
rebindEff2 i k a b = boned (i :>>= \x -> k x a b)
leaveEff :: Eff '[] a -> a
leaveEff m = case debone m of
Return a -> a
_ -> error "Impossible"
retractEff :: forall k m a. Monad m => Eff '[k >: m] a -> m a
retractEff m = case debone m of
Return a -> return a
Instruction i t :>>= k -> runMembership i
(\Refl -> t >>= retractEff . k)
(error "Impossible")
newtype Interpreter f g = Interpreter { runInterpreter :: forall a. g a -> f a }
handleEff :: RecordOf (Interpreter m) xs -> Eff xs a -> MonadView m (Eff xs) a
handleEff hs m = case debone m of
Instruction i t :>>= k -> views (pieceAt i) (runInterpreter .# getField) hs t :>>= k
Return a -> Return a
data Action (args :: [*]) a r where
AResult :: Action '[] a a
AArgument :: x -> Action xs a r -> Action (x ': xs) a r
type family Function args r :: * where
Function '[] r = r
Function (x ': xs) r = x -> Function xs r
runAction :: Function xs (f a) -> Action xs a r -> f r
runAction r AResult = r
runAction f (AArgument x a) = runAction (f x) a
(@!?) :: FieldName k -> Function xs (f a) -> Field (Interpreter f) (k ':> Action xs a)
_ @!? f = Field $ Interpreter (runAction f)
infix 1 @!?
peelAction :: forall k ps q xs a r
. (forall x. Instruction xs x -> (x -> r) -> r)
-> (a -> r)
-> Function ps ((q -> r) -> r)
-> Eff (k >: Action ps q ': xs) a -> r
peelAction pass ret wrap = go where
go m = case debone m of
Return a -> ret a
Instruction i t :>>= k -> runMembership i
(\Refl -> case t of
(_ :: Action ps q x) ->
let run :: forall t. Function t ((q -> r) -> r) -> Action t q x -> r
run f AResult = f (go . k)
run f (AArgument x a) = run (f x) a
in run wrap t)
(\j -> pass (Instruction j t) (go . k))
peelAction0 :: forall k ps q xs a. Function ps (Eff xs q)
-> Eff (k >: Action ps q ': xs) a -> Eff xs a
peelAction0 wrap = go where
go m = case debone m of
Return a -> return a
Instruction i t :>>= k -> runMembership i
(\Refl -> case t of
(_ :: Action ps q x) ->
let run :: forall t. Function t (Eff xs q) -> Action t q x -> Eff xs a
run f AResult = f >>= go . k
run f (AArgument x a) = run (f x) a
in run wrap t)
(\j -> rebindEff0 (Instruction j t) (go . k))
type ReaderEff = (:~:)
askEff :: forall k r xs. Associate k (ReaderEff r) xs
=> Proxy k -> Eff xs r
askEff p = liftEff p Refl
asksEff :: forall k r xs a. Associate k (ReaderEff r) xs
=> Proxy k -> (r -> a) -> Eff xs a
asksEff p = liftsEff p Refl
localEff :: forall k r xs a. Associate k (ReaderEff r) xs
=> Proxy k -> (r -> r) -> Eff xs a -> Eff xs a
localEff _ f = go where
go m = case debone m of
Return a -> return a
Instruction i t :>>= k -> case compareMembership
(association :: Membership xs (k >: ReaderEff r)) i of
Left _ -> boned $ Instruction i t :>>= go . k
Right Refl -> case t of
Refl -> boned $ Instruction i t :>>= go . k . f
runReaderEff :: forall k r xs a. Eff (k >: ReaderEff r ': xs) a -> r -> Eff xs a
runReaderEff m r = peelEff rebindEff0 return (\Refl k -> k r) m
getEff :: forall k s xs. Associate k (State s) xs
=> Proxy k -> Eff xs s
getEff k = liftEff k get
getsEff :: forall k s a xs. Associate k (State s) xs
=> Proxy k -> (s -> a) -> Eff xs a
getsEff k = liftsEff k get
putEff :: forall k s xs. Associate k (State s) xs
=> Proxy k -> s -> Eff xs ()
putEff k = liftEff k . put
modifyEff :: forall k s xs. Associate k (State s) xs
=> Proxy k -> (s -> s) -> Eff xs ()
modifyEff k f = liftEff k $ state $ \s -> ((), f s)
stateEff :: forall k s xs a. Associate k (State s) xs
=> Proxy k -> (s -> (a, s)) -> Eff xs a
stateEff k = liftEff k . state
contState :: State s a -> (a -> s -> r) -> s -> r
contState m k s = let (a, s') = runState m s in k a $! s'
runStateEff :: forall k s xs a. Eff (k >: State s ': xs) a -> s -> Eff xs (a, s)
runStateEff = peelEff1 (\a s -> return (a, s)) contState
execStateEff :: forall k s xs a. Eff (k >: State s ': xs) a -> s -> Eff xs s
execStateEff = peelEff1 (const return) contState
type WriterEff w = (,) w
writerEff :: forall k w xs a. (Associate k (WriterEff w) xs)
=> Proxy k -> (a, w) -> Eff xs a
writerEff k (a, w) = liftEff k (w, a)
tellEff :: forall k w xs. (Associate k (WriterEff w) xs)
=> Proxy k -> w -> Eff xs ()
tellEff k w = liftEff k (w, ())
listenEff :: forall k w xs a. (Associate k (WriterEff w) xs, Monoid w)
=> Proxy k -> Eff xs a -> Eff xs (a, w)
listenEff p = go mempty where
go w m = case debone m of
Return a -> writerEff p ((a, w), w)
Instruction i t :>>= k -> case compareMembership (association :: Membership xs (k ':> (,) w)) i of
Left _ -> boned $ Instruction i t :>>= go w . k
Right Refl -> let (w', a) = t
!w'' = mappend w w' in go w'' (k a)
passEff :: forall k w xs a. (Associate k (WriterEff w) xs, Monoid w)
=> Proxy k -> Eff xs (a, w -> w) -> Eff xs a
passEff p = go mempty where
go w m = case debone m of
Return (a, f) -> writerEff p (a, f w)
Instruction i t :>>= k -> case compareMembership (association :: Membership xs (k ':> (,) w)) i of
Left _ -> boned $ Instruction i t :>>= go w . k
Right Refl -> let (w', a) = t
!w'' = mappend w w' in go w'' (k a)
contWriter :: Monoid w => (w, a) -> (a -> w -> r) -> w -> r
contWriter (w', a) k w = k a $! mappend w w'
runWriterEff :: forall k w xs a. Monoid w => Eff (k >: WriterEff w ': xs) a -> Eff xs (a, w)
runWriterEff = peelEff1 (\a w -> return (a, w)) contWriter `flip` mempty
execWriterEff :: forall k w xs a. Monoid w => Eff (k >: WriterEff w ': xs) a -> Eff xs w
execWriterEff = peelEff1 (const return) contWriter `flip` mempty
type MaybeEff = Const ()
runMaybeEff :: forall k xs a. Eff (k >: MaybeEff ': xs) a -> Eff xs (Maybe a)
runMaybeEff = peelEff rebindEff0 (return . Just)
(\_ _ -> return Nothing)
type EitherEff = Const
throwEff :: Associate k (EitherEff e) xs => Proxy k -> e -> Eff xs a
throwEff k = liftEff k . Const
catchEff :: forall k e xs a. (Associate k (EitherEff e) xs)
=> Proxy k -> Eff xs a -> (e -> Eff xs a) -> Eff xs a
catchEff _ m0 handler = go m0 where
go m = case debone m of
Return a -> return a
Instruction i t :>>= k -> case compareMembership (association :: Membership xs (k ':> Const e)) i of
Left _ -> boned $ Instruction i t :>>= go . k
Right Refl -> handler (getConst t)
runEitherEff :: forall k e xs a. Eff (k >: EitherEff e ': xs) a -> Eff xs (Either e a)
runEitherEff = peelEff rebindEff0 (return . Right)
(\(Const e) _ -> return $ Left e)
tickEff :: Associate k Identity xs => Proxy k -> Eff xs ()
tickEff k = liftEff k (Identity ())
runIterEff :: Eff (k >: Identity ': xs) a
-> Eff xs (Either a (Eff (k >: Identity ': xs) a))
runIterEff m = case debone m of
Return a -> return (Left a)
Instruction i t :>>= k -> runMembership i
(\Refl -> return $ Right $ k $ runIdentity t)
(\j -> boned $ Instruction j t :>>= runIterEff . k)