{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Carrier.Interpret
(
runInterpret
, runInterpretState
, InterpretC(InterpretC)
, Reifies
, Interpreter
, Algebra
, Has
, run
) where
import Control.Algebra
import Control.Applicative (Alternative)
import Control.Carrier.State.Strict
import Control.Monad (MonadPlus)
import Control.Monad.Fail as Fail
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Data.Functor.Const (Const(..))
import Data.Kind (Type)
import Unsafe.Coerce (unsafeCoerce)
newtype Interpreter sig m = Interpreter
{ forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Interpreter sig m
-> forall (ctx :: * -> *) (n :: * -> *) s x.
Functor ctx =>
Handler ctx n (InterpretC s sig m)
-> sig n x -> ctx () -> InterpretC s sig m (ctx x)
runInterpreter :: forall ctx n s x . Functor ctx => Handler ctx n (InterpretC s sig m) -> sig n x -> ctx () -> InterpretC s sig m (ctx x) }
class Reifies s a | s -> a where
reflect :: Const a s
data Skolem
newtype Magic a r = Magic (Reifies Skolem a => Const r Skolem)
reify :: a -> (forall s . Reifies s a => Const r s) -> r
reify :: forall a r. a -> (forall s. Reifies s a => Const r s) -> r
reify a
a forall s. Reifies s a => Const r s
k = forall a b. a -> b
unsafeCoerce (forall a r. (Reifies Skolem a => Const r Skolem) -> Magic a r
Magic forall s. Reifies s a => Const r s
k) a
a
runInterpret
:: (forall ctx n x . Functor ctx => Handler ctx n m -> eff n x -> ctx () -> m (ctx x))
-> (forall s . Reifies s (Interpreter eff m) => InterpretC s eff m a)
-> m a
runInterpret :: forall (m :: * -> *) (eff :: (* -> *) -> * -> *) a.
(forall (ctx :: * -> *) (n :: * -> *) x.
Functor ctx =>
Handler ctx n m -> eff n x -> ctx () -> m (ctx x))
-> (forall s.
Reifies s (Interpreter eff m) =>
InterpretC s eff m a)
-> m a
runInterpret forall (ctx :: * -> *) (n :: * -> *) x.
Functor ctx =>
Handler ctx n m -> eff n x -> ctx () -> m (ctx x)
f forall s. Reifies s (Interpreter eff m) => InterpretC s eff m a
m = forall a r. a -> (forall s. Reifies s a => Const r s) -> r
reify (forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(forall (ctx :: * -> *) (n :: * -> *) s x.
Functor ctx =>
Handler ctx n (InterpretC s sig m)
-> sig n x -> ctx () -> InterpretC s sig m (ctx x))
-> Interpreter sig m
Interpreter (\ Handler ctx n (InterpretC s eff m)
hdl eff n x
sig -> forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
m a -> InterpretC s sig m a
InterpretC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (ctx :: * -> *) (n :: * -> *) x.
Functor ctx =>
Handler ctx n m -> eff n x -> ctx () -> m (ctx x)
f (forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
InterpretC s sig m a -> m a
runInterpretC forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handler ctx n (InterpretC s eff m)
hdl) eff n x
sig)) (forall s (eff :: (* -> *) -> * -> *) (m :: * -> *) x.
InterpretC s eff m x -> Const (m x) s
go forall s. Reifies s (Interpreter eff m) => InterpretC s eff m a
m) where
go :: InterpretC s eff m x -> Const (m x) s
go :: forall s (eff :: (* -> *) -> * -> *) (m :: * -> *) x.
InterpretC s eff m x -> Const (m x) s
go (InterpretC m x
m) = forall {k} a (b :: k). a -> Const a b
Const m x
m
{-# INLINE runInterpret #-}
runInterpretState
:: (forall ctx n x . Functor ctx => Handler ctx n (StateC s m) -> eff n x -> s -> ctx () -> m (s, ctx x))
-> s
-> (forall t . Reifies t (Interpreter eff (StateC s m)) => InterpretC t eff (StateC s m) a)
-> m (s, a)
runInterpretState :: forall s (m :: * -> *) (eff :: (* -> *) -> * -> *) a.
(forall (ctx :: * -> *) (n :: * -> *) x.
Functor ctx =>
Handler ctx n (StateC s m)
-> eff n x -> s -> ctx () -> m (s, ctx x))
-> s
-> (forall t.
Reifies t (Interpreter eff (StateC s m)) =>
InterpretC t eff (StateC s m) a)
-> m (s, a)
runInterpretState forall (ctx :: * -> *) (n :: * -> *) x.
Functor ctx =>
Handler ctx n (StateC s m)
-> eff n x -> s -> ctx () -> m (s, ctx x)
handler s
state forall t.
Reifies t (Interpreter eff (StateC s m)) =>
InterpretC t eff (StateC s m) a
m
= forall s (m :: * -> *) a. s -> StateC s m a -> m (s, a)
runState s
state
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (eff :: (* -> *) -> * -> *) a.
(forall (ctx :: * -> *) (n :: * -> *) x.
Functor ctx =>
Handler ctx n m -> eff n x -> ctx () -> m (ctx x))
-> (forall s.
Reifies s (Interpreter eff m) =>
InterpretC s eff m a)
-> m a
runInterpret (\ Handler ctx n (StateC s m)
hdl eff n x
sig ctx ()
ctx -> forall s (m :: * -> *) a. (s -> m (s, a)) -> StateC s m a
StateC (forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (ctx :: * -> *) (n :: * -> *) x.
Functor ctx =>
Handler ctx n (StateC s m)
-> eff n x -> s -> ctx () -> m (s, ctx x)
handler Handler ctx n (StateC s m)
hdl eff n x
sig) ctx ()
ctx)) forall t.
Reifies t (Interpreter eff (StateC s m)) =>
InterpretC t eff (StateC s m) a
m
{-# INLINE runInterpretState #-}
newtype InterpretC s (sig :: (Type -> Type) -> (Type -> Type)) m a = InterpretC { forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
InterpretC s sig m a -> m a
runInterpretC :: m a }
deriving (forall a. InterpretC s sig m a
forall a. InterpretC s sig m a -> InterpretC s sig m [a]
forall a.
InterpretC s sig m a
-> InterpretC s sig m a -> InterpretC s sig m a
forall {s} {sig :: (* -> *) -> * -> *} {m :: * -> *}.
Alternative m =>
Applicative (InterpretC s sig m)
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Alternative m =>
InterpretC s sig m a
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Alternative m =>
InterpretC s sig m a -> InterpretC s sig m [a]
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Alternative m =>
InterpretC s sig m a
-> InterpretC s sig m a -> InterpretC s sig m a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: forall a. InterpretC s sig m a -> InterpretC s sig m [a]
$cmany :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Alternative m =>
InterpretC s sig m a -> InterpretC s sig m [a]
some :: forall a. InterpretC s sig m a -> InterpretC s sig m [a]
$csome :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Alternative m =>
InterpretC s sig m a -> InterpretC s sig m [a]
<|> :: forall a.
InterpretC s sig m a
-> InterpretC s sig m a -> InterpretC s sig m a
$c<|> :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Alternative m =>
InterpretC s sig m a
-> InterpretC s sig m a -> InterpretC s sig m a
empty :: forall a. InterpretC s sig m a
$cempty :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Alternative m =>
InterpretC s sig m a
Alternative, forall a. a -> InterpretC s sig m a
forall a b.
InterpretC s sig m a
-> InterpretC s sig m b -> InterpretC s sig m a
forall a b.
InterpretC s sig m a
-> InterpretC s sig m b -> InterpretC s sig m b
forall a b.
InterpretC s sig m (a -> b)
-> InterpretC s sig m a -> InterpretC s sig m b
forall a b c.
(a -> b -> c)
-> InterpretC s sig m a
-> InterpretC s sig m b
-> InterpretC s sig m c
forall {s} {sig :: (* -> *) -> * -> *} {m :: * -> *}.
Applicative m =>
Functor (InterpretC s sig m)
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Applicative m =>
a -> InterpretC s sig m a
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative m =>
InterpretC s sig m a
-> InterpretC s sig m b -> InterpretC s sig m a
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative m =>
InterpretC s sig m a
-> InterpretC s sig m b -> InterpretC s sig m b
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative m =>
InterpretC s sig m (a -> b)
-> InterpretC s sig m a -> InterpretC s sig m b
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> InterpretC s sig m a
-> InterpretC s sig m b
-> InterpretC s sig m c
forall (f :: * -> *).
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
<* :: forall a b.
InterpretC s sig m a
-> InterpretC s sig m b -> InterpretC s sig m a
$c<* :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative m =>
InterpretC s sig m a
-> InterpretC s sig m b -> InterpretC s sig m a
*> :: forall a b.
InterpretC s sig m a
-> InterpretC s sig m b -> InterpretC s sig m b
$c*> :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative m =>
InterpretC s sig m a
-> InterpretC s sig m b -> InterpretC s sig m b
liftA2 :: forall a b c.
(a -> b -> c)
-> InterpretC s sig m a
-> InterpretC s sig m b
-> InterpretC s sig m c
$cliftA2 :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c)
-> InterpretC s sig m a
-> InterpretC s sig m b
-> InterpretC s sig m c
<*> :: forall a b.
InterpretC s sig m (a -> b)
-> InterpretC s sig m a -> InterpretC s sig m b
$c<*> :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b.
Applicative m =>
InterpretC s sig m (a -> b)
-> InterpretC s sig m a -> InterpretC s sig m b
pure :: forall a. a -> InterpretC s sig m a
$cpure :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Applicative m =>
a -> InterpretC s sig m a
Applicative, forall a b. a -> InterpretC s sig m b -> InterpretC s sig m a
forall a b.
(a -> b) -> InterpretC s sig m a -> InterpretC s sig m b
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b.
Functor m =>
a -> InterpretC s sig m b -> InterpretC s sig m a
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b.
Functor m =>
(a -> b) -> InterpretC s sig m a -> InterpretC s sig m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> InterpretC s sig m b -> InterpretC s sig m a
$c<$ :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b.
Functor m =>
a -> InterpretC s sig m b -> InterpretC s sig m a
fmap :: forall a b.
(a -> b) -> InterpretC s sig m a -> InterpretC s sig m b
$cfmap :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b.
Functor m =>
(a -> b) -> InterpretC s sig m a -> InterpretC s sig m b
Functor, forall a. a -> InterpretC s sig m a
forall a b.
InterpretC s sig m a
-> InterpretC s sig m b -> InterpretC s sig m b
forall a b.
InterpretC s sig m a
-> (a -> InterpretC s sig m b) -> InterpretC s sig m b
forall {s} {sig :: (* -> *) -> * -> *} {m :: * -> *}.
Monad m =>
Applicative (InterpretC s sig m)
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Monad m =>
a -> InterpretC s sig m a
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b.
Monad m =>
InterpretC s sig m a
-> InterpretC s sig m b -> InterpretC s sig m b
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b.
Monad m =>
InterpretC s sig m a
-> (a -> InterpretC s sig m b) -> InterpretC s sig m b
forall (m :: * -> *).
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 :: forall a. a -> InterpretC s sig m a
$creturn :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Monad m =>
a -> InterpretC s sig m a
>> :: forall a b.
InterpretC s sig m a
-> InterpretC s sig m b -> InterpretC s sig m b
$c>> :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b.
Monad m =>
InterpretC s sig m a
-> InterpretC s sig m b -> InterpretC s sig m b
>>= :: forall a b.
InterpretC s sig m a
-> (a -> InterpretC s sig m b) -> InterpretC s sig m b
$c>>= :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b.
Monad m =>
InterpretC s sig m a
-> (a -> InterpretC s sig m b) -> InterpretC s sig m b
Monad, forall a. String -> InterpretC s sig m a
forall {s} {sig :: (* -> *) -> * -> *} {m :: * -> *}.
MonadFail m =>
Monad (InterpretC s sig m)
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadFail m =>
String -> InterpretC s sig m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> InterpretC s sig m a
$cfail :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadFail m =>
String -> InterpretC s sig m a
Fail.MonadFail, forall a. (a -> InterpretC s sig m a) -> InterpretC s sig m a
forall {s} {sig :: (* -> *) -> * -> *} {m :: * -> *}.
MonadFix m =>
Monad (InterpretC s sig m)
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadFix m =>
(a -> InterpretC s sig m a) -> InterpretC s sig m a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
mfix :: forall a. (a -> InterpretC s sig m a) -> InterpretC s sig m a
$cmfix :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadFix m =>
(a -> InterpretC s sig m a) -> InterpretC s sig m a
MonadFix, forall a. IO a -> InterpretC s sig m a
forall {s} {sig :: (* -> *) -> * -> *} {m :: * -> *}.
MonadIO m =>
Monad (InterpretC s sig m)
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadIO m =>
IO a -> InterpretC s sig m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> InterpretC s sig m a
$cliftIO :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadIO m =>
IO a -> InterpretC s sig m a
MonadIO, forall a. InterpretC s sig m a
forall a.
InterpretC s sig m a
-> InterpretC s sig m a -> InterpretC s sig m a
forall {s} {sig :: (* -> *) -> * -> *} {m :: * -> *}.
MonadPlus m =>
Monad (InterpretC s sig m)
forall {s} {sig :: (* -> *) -> * -> *} {m :: * -> *}.
MonadPlus m =>
Alternative (InterpretC s sig m)
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadPlus m =>
InterpretC s sig m a
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadPlus m =>
InterpretC s sig m a
-> InterpretC s sig m a -> InterpretC s sig m a
forall (m :: * -> *).
Alternative m
-> Monad m
-> (forall a. m a)
-> (forall a. m a -> m a -> m a)
-> MonadPlus m
mplus :: forall a.
InterpretC s sig m a
-> InterpretC s sig m a -> InterpretC s sig m a
$cmplus :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadPlus m =>
InterpretC s sig m a
-> InterpretC s sig m a -> InterpretC s sig m a
mzero :: forall a. InterpretC s sig m a
$cmzero :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadPlus m =>
InterpretC s sig m a
MonadPlus, forall b.
((forall a. InterpretC s sig m a -> IO a) -> IO b)
-> InterpretC s sig m b
forall {s} {sig :: (* -> *) -> * -> *} {m :: * -> *}.
MonadUnliftIO m =>
MonadIO (InterpretC s sig m)
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. InterpretC s sig m a -> IO a) -> IO b)
-> InterpretC s sig m b
forall (m :: * -> *).
MonadIO m
-> (forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
withRunInIO :: forall b.
((forall a. InterpretC s sig m a -> IO a) -> IO b)
-> InterpretC s sig m b
$cwithRunInIO :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. InterpretC s sig m a -> IO a) -> IO b)
-> InterpretC s sig m b
MonadUnliftIO)
instance MonadTrans (InterpretC s sig) where
lift :: forall (m :: * -> *) a. Monad m => m a -> InterpretC s sig m a
lift = forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
m a -> InterpretC s sig m a
InterpretC
{-# INLINE lift #-}
instance (Reifies s (Interpreter eff m), Algebra sig m) => Algebra (eff :+: sig) (InterpretC s eff m) where
alg :: forall (ctx :: * -> *) (n :: * -> *) a.
Functor ctx =>
Handler ctx n (InterpretC s eff m)
-> (:+:) eff sig n a -> ctx () -> InterpretC s eff m (ctx a)
alg Handler ctx n (InterpretC s eff m)
hdl = \case
L eff n a
eff -> forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Interpreter sig m
-> forall (ctx :: * -> *) (n :: * -> *) s x.
Functor ctx =>
Handler ctx n (InterpretC s sig m)
-> sig n x -> ctx () -> InterpretC s sig m (ctx x)
runInterpreter (forall {k} a (b :: k). Const a b -> a
getConst (forall s a. Reifies s a => Const a s
reflect @s)) Handler ctx n (InterpretC s eff m)
hdl eff n a
eff
R sig n a
other -> forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
m a -> InterpretC s sig m a
InterpretC forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (ctx :: * -> *)
(n :: * -> *) a.
(Algebra sig m, Functor ctx) =>
Handler ctx n m -> sig n a -> ctx () -> m (ctx a)
alg (forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
InterpretC s sig m a -> m a
runInterpretC forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handler ctx n (InterpretC s eff m)
hdl) sig n a
other
{-# INLINE alg #-}