{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Carrier.Accum.Church
(
runAccum
, execAccum
, evalAccum
, AccumC(AccumC)
, module Control.Effect.Accum
) where
import Control.Algebra
import Control.Applicative (Alternative(..))
import Control.Effect.Accum
import Control.Monad (MonadPlus(..))
import Control.Monad.Fail as Fail
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
runAccum :: (w -> a -> m b) -> w -> AccumC w m a -> m b
runAccum :: forall w a (m :: * -> *) b.
(w -> a -> m b) -> w -> AccumC w m a -> m b
runAccum w -> a -> m b
k w
w AccumC w m a
ma = AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
forall w (m :: * -> *) a.
AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
runAccumC AccumC w m a
ma w -> a -> m b
k w
w
{-# INLINE runAccum #-}
execAccum :: Applicative m => w -> AccumC w m a -> m w
execAccum :: forall (m :: * -> *) w a. Applicative m => w -> AccumC w m a -> m w
execAccum = (w -> a -> m w) -> w -> AccumC w m a -> m w
forall w a (m :: * -> *) b.
(w -> a -> m b) -> w -> AccumC w m a -> m b
runAccum (m w -> a -> m w
forall a b. a -> b -> a
const (m w -> a -> m w) -> (w -> m w) -> w -> a -> m w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m w
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)
{-# INLINE execAccum #-}
evalAccum :: Applicative m => w -> AccumC w m a -> m a
evalAccum :: forall (m :: * -> *) w a. Applicative m => w -> AccumC w m a -> m a
evalAccum = (w -> a -> m a) -> w -> AccumC w m a -> m a
forall w a (m :: * -> *) b.
(w -> a -> m b) -> w -> AccumC w m a -> m b
runAccum ((w -> a -> m a) -> w -> AccumC w m a -> m a)
-> (w -> a -> m a) -> w -> AccumC w m a -> m a
forall a b. (a -> b) -> a -> b
$ (a -> m a) -> w -> a -> m a
forall a b. a -> b -> a
const a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE evalAccum #-}
newtype AccumC w m a = AccumC { forall w (m :: * -> *) a.
AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
runAccumC :: forall r . (w -> a -> m r) -> w -> m r }
instance Monoid w => MonadTrans (AccumC w) where
lift :: forall (m :: * -> *) a. Monad m => m a -> AccumC w m a
lift m a
ma = (forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
forall w (m :: * -> *) a.
(forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
AccumC ((forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a)
-> (forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
forall a b. (a -> b) -> a -> b
$ \w -> a -> m r
k w
_ -> m a
ma m a -> (a -> m r) -> m r
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= w -> a -> m r
k w
forall a. Monoid a => a
mempty
{-# INLINE lift #-}
instance Functor (AccumC w m) where
fmap :: forall a b. (a -> b) -> AccumC w m a -> AccumC w m b
fmap a -> b
f AccumC w m a
ma = (forall r. (w -> b -> m r) -> w -> m r) -> AccumC w m b
forall w (m :: * -> *) a.
(forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
AccumC ((forall r. (w -> b -> m r) -> w -> m r) -> AccumC w m b)
-> (forall r. (w -> b -> m r) -> w -> m r) -> AccumC w m b
forall a b. (a -> b) -> a -> b
$ \w -> b -> m r
k w
w -> AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
forall w (m :: * -> *) a.
AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
runAccumC AccumC w m a
ma (\w
w a
a -> w -> b -> m r
k w
w (b -> m r) -> b -> m r
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a) w
w
{-# INLINE fmap #-}
instance Monoid w => Applicative (AccumC w m) where
pure :: forall a. a -> AccumC w m a
pure a
a = (forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
forall w (m :: * -> *) a.
(forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
AccumC ((forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a)
-> (forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
forall a b. (a -> b) -> a -> b
$ \w -> a -> m r
k w
_ -> w -> a -> m r
k w
forall a. Monoid a => a
mempty a
a
{-# INLINE pure #-}
AccumC w m (a -> b)
mf <*> :: forall a b. AccumC w m (a -> b) -> AccumC w m a -> AccumC w m b
<*> AccumC w m a
ma = (forall r. (w -> b -> m r) -> w -> m r) -> AccumC w m b
forall w (m :: * -> *) a.
(forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
AccumC ((forall r. (w -> b -> m r) -> w -> m r) -> AccumC w m b)
-> (forall r. (w -> b -> m r) -> w -> m r) -> AccumC w m b
forall a b. (a -> b) -> a -> b
$ \w -> b -> m r
k w
w ->
AccumC w m (a -> b) -> forall r. (w -> (a -> b) -> m r) -> w -> m r
forall w (m :: * -> *) a.
AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
runAccumC AccumC w m (a -> b)
mf (\w
w' a -> b
f -> AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
forall w (m :: * -> *) a.
AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
runAccumC AccumC w m a
ma (\w
w'' a
a -> w -> b -> m r
k (w
w' w -> w -> w
forall a. Monoid a => a -> a -> a
`mappend` w
w'') (b -> m r) -> b -> m r
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a) (w
w w -> w -> w
forall a. Monoid a => a -> a -> a
`mappend` w
w')) w
w
{-# INLINE (<*>) #-}
instance (Alternative m, Monad m, Monoid w) => Alternative (AccumC w m) where
empty :: forall a. AccumC w m a
empty = m a -> AccumC w m a
forall (m :: * -> *) a. Monad m => m a -> AccumC w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
forall a. m a
forall (f :: * -> *) a. Alternative f => f a
empty
{-# INLINE empty #-}
AccumC w m a
ma1 <|> :: forall a. AccumC w m a -> AccumC w m a -> AccumC w m a
<|> AccumC w m a
ma2 = (forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
forall w (m :: * -> *) a.
(forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
AccumC ((forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a)
-> (forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
forall a b. (a -> b) -> a -> b
$ \w -> a -> m r
k w
w -> AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
forall w (m :: * -> *) a.
AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
runAccumC AccumC w m a
ma1 w -> a -> m r
k w
w m r -> m r -> m r
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
forall w (m :: * -> *) a.
AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
runAccumC AccumC w m a
ma2 w -> a -> m r
k w
w
{-# INLINE (<|>) #-}
instance (Monad m, Monoid w) => Monad (AccumC w m) where
AccumC w m a
ma >>= :: forall a b. AccumC w m a -> (a -> AccumC w m b) -> AccumC w m b
>>= a -> AccumC w m b
f = (forall r. (w -> b -> m r) -> w -> m r) -> AccumC w m b
forall w (m :: * -> *) a.
(forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
AccumC ((forall r. (w -> b -> m r) -> w -> m r) -> AccumC w m b)
-> (forall r. (w -> b -> m r) -> w -> m r) -> AccumC w m b
forall a b. (a -> b) -> a -> b
$ \w -> b -> m r
k w
w -> AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
forall w (m :: * -> *) a.
AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
runAccumC AccumC w m a
ma (\w
w' a
a -> AccumC w m b -> forall r. (w -> b -> m r) -> w -> m r
forall w (m :: * -> *) a.
AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
runAccumC (a -> AccumC w m b
f a
a) (\w
w'' -> w -> b -> m r
k (w -> b -> m r) -> w -> b -> m r
forall a b. (a -> b) -> a -> b
$ w
w' w -> w -> w
forall a. Monoid a => a -> a -> a
`mappend` w
w'') (w
w w -> w -> w
forall a. Monoid a => a -> a -> a
`mappend` w
w')) w
w
{-# INLINE (>>=) #-}
instance (MonadPlus m, Monoid w) => MonadPlus (AccumC w m) where
mzero :: forall a. AccumC w m a
mzero = m a -> AccumC w m a
forall (m :: * -> *) a. Monad m => m a -> AccumC w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
forall a. m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
{-# INLINE mzero #-}
AccumC w m a
ma1 mplus :: forall a. AccumC w m a -> AccumC w m a -> AccumC w m a
`mplus` AccumC w m a
ma2 = (forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
forall w (m :: * -> *) a.
(forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
AccumC ((forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a)
-> (forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
forall a b. (a -> b) -> a -> b
$ \w -> a -> m r
k w
w -> AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
forall w (m :: * -> *) a.
AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
runAccumC AccumC w m a
ma1 w -> a -> m r
k w
w m r -> m r -> m r
forall a. m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
forall w (m :: * -> *) a.
AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
runAccumC AccumC w m a
ma2 w -> a -> m r
k w
w
{-# INLINE mplus #-}
instance (MonadFail m, Monoid w) => MonadFail (AccumC w m) where
fail :: forall a. String -> AccumC w m a
fail String
msg = (forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
forall w (m :: * -> *) a.
(forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
AccumC ((forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a)
-> (forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
forall a b. (a -> b) -> a -> b
$ (w -> m r) -> (w -> a -> m r) -> w -> m r
forall a b. a -> b -> a
const ((w -> m r) -> (w -> a -> m r) -> w -> m r)
-> (w -> m r) -> (w -> a -> m r) -> w -> m r
forall a b. (a -> b) -> a -> b
$ m r -> w -> m r
forall a b. a -> b -> a
const (m r -> w -> m r) -> m r -> w -> m r
forall a b. (a -> b) -> a -> b
$ String -> m r
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
msg
{-# INLINE fail #-}
instance (MonadFix m, Monoid w) => MonadFix (AccumC w m) where
mfix :: forall a. (a -> AccumC w m a) -> AccumC w m a
mfix a -> AccumC w m a
ma = (forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
forall w (m :: * -> *) a.
(forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
AccumC ((forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a)
-> (forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
forall a b. (a -> b) -> a -> b
$ \ w -> a -> m r
k w
w -> ((w, a) -> m (w, a)) -> m (w, a)
forall a. (a -> m a) -> m a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((\AccumC w m a
accumC -> AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
forall w (m :: * -> *) a.
AccumC w m a -> forall r. (w -> a -> m r) -> w -> m r
runAccumC AccumC w m a
accumC (((w, a) -> m (w, a)) -> w -> a -> m (w, a)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (w, a) -> m (w, a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) w
w) (AccumC w m a -> m (w, a))
-> ((w, a) -> AccumC w m a) -> (w, a) -> m (w, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AccumC w m a
ma (a -> AccumC w m a) -> ((w, a) -> a) -> (w, a) -> AccumC w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (w, a) -> a
forall a b. (a, b) -> b
snd) m (w, a) -> ((w, a) -> m r) -> m r
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (w -> a -> m r) -> (w, a) -> m r
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry w -> a -> m r
k
{-# INLINE mfix #-}
instance (MonadIO m, Monoid w) => MonadIO (AccumC w m) where
liftIO :: forall a. IO a -> AccumC w m a
liftIO = m a -> AccumC w m a
forall (m :: * -> *) a. Monad m => m a -> AccumC w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> AccumC w m a) -> (IO a -> m a) -> IO a -> AccumC w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
{-# INLINE liftIO #-}
instance (Algebra sig m, Monoid w) => Algebra (Accum w :+: sig) (AccumC w m) where
alg :: forall (ctx :: * -> *) (n :: * -> *) a.
Functor ctx =>
Handler ctx n (AccumC w m)
-> (:+:) (Accum w) sig n a -> ctx () -> AccumC w m (ctx a)
alg Handler ctx n (AccumC w m)
hdl (:+:) (Accum w) sig n a
sig ctx ()
ctx = (forall r. (w -> ctx a -> m r) -> w -> m r) -> AccumC w m (ctx a)
forall w (m :: * -> *) a.
(forall r. (w -> a -> m r) -> w -> m r) -> AccumC w m a
AccumC ((forall r. (w -> ctx a -> m r) -> w -> m r) -> AccumC w m (ctx a))
-> (forall r. (w -> ctx a -> m r) -> w -> m r)
-> AccumC w m (ctx a)
forall a b. (a -> b) -> a -> b
$ \w -> ctx a -> m r
k w
w -> case (:+:) (Accum w) sig n a
sig of
L Accum w n a
accum -> case Accum w n a
accum of
Add w
w' -> w -> ctx a -> m r
k w
w' ctx a
ctx ()
ctx
Accum w n a
Look -> w -> ctx a -> m r
k w
forall a. Monoid a => a
mempty (ctx a -> m r) -> ctx a -> m r
forall a b. (a -> b) -> a -> b
$ w
a
w a -> ctx () -> ctx a
forall a b. a -> ctx b -> ctx a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx
R sig n a
other -> Handler (Compose ((,) w) ctx) n m
-> sig n a -> (w, ctx ()) -> m (w, ctx a)
forall (ctx1 :: * -> *) (ctx2 :: * -> *)
(sig :: (* -> *) -> * -> *) (m :: * -> *) (n :: * -> *) a.
(Functor ctx1, Functor ctx2, Algebra sig m) =>
Handler (Compose ctx1 ctx2) n m
-> sig n a -> ctx1 (ctx2 ()) -> m (ctx1 (ctx2 a))
thread ((w -> AccumC w m x -> m (w, x)) -> (w, AccumC w m x) -> m (w, x)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((w -> x -> m (w, x)) -> w -> AccumC w m x -> m (w, x)
forall w a (m :: * -> *) b.
(w -> a -> m b) -> w -> AccumC w m a -> m b
runAccum (((w, x) -> m (w, x)) -> w -> x -> m (w, x)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (w, x) -> m (w, x)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)) (forall {x}. (w, AccumC w m x) -> m (w, x))
-> Handler ctx n (AccumC w m) -> Handler (Compose ((,) w) ctx) n m
forall (n :: * -> *) (ctx1 :: * -> *) (m :: * -> *)
(ctx2 :: * -> *) (l :: * -> *).
(Functor n, Functor ctx1) =>
Handler ctx1 m n
-> Handler ctx2 l m -> Handler (Compose ctx1 ctx2) l n
~<~ ctx (n x) -> AccumC w m (ctx x)
Handler ctx n (AccumC w m)
hdl) sig n a
other (w
w, ctx ()
ctx) m (w, ctx a) -> ((w, ctx a) -> m r) -> m r
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (w -> ctx a -> m r) -> (w, ctx a) -> m r
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry w -> ctx a -> m r
k
{-# INLINE alg #-}