{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{- | A carrier for 'Accum' effects.
This carrier performs its append operations strictly and thus avoids the space leaks inherent in lazy writer monads.
These appends are left-associative; as such, @[]@ is a poor choice of monoid for computations that entail many calls to 'tell'.
The [Seq](http://hackage.haskell.org/package/containersdocs/Data-Sequence.html) or [DList](http://hackage.haskell.org/package/dlist) monoids may be a superior choice.

@since 1.1.2.0
-}

module Control.Carrier.Accum.Strict
( -- * Accum carrier
  runAccum
, execAccum
, evalAccum
, AccumC(AccumC)
  -- * Accum effect
, 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

-- | Run an 'Accum' effect with a 'Monoid'al log, applying a continuation to the final log and result.
--
-- @
-- 'runAccum' w0 ('pure' a) = 'pure' (w0, a)
-- @
-- @
-- 'runAccum' w0 ('add' w) = 'pure' (w0 <> w, ())
-- @
-- @
-- 'runAccum' w0 ('add' w >> 'look') = 'pure' (w0 <> w, w0 <> w)
-- @
--
-- @since 1.1.2.0
runAccum :: w -> AccumC w m a -> m (w, a)
runAccum :: forall w (m :: * -> *) a. w -> AccumC w m a -> m (w, a)
runAccum = (AccumC w m a -> w -> m (w, a)) -> w -> AccumC w m a -> m (w, a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip AccumC w m a -> w -> m (w, a)
forall w (m :: * -> *) a. AccumC w m a -> w -> m (w, a)
runAccumC
{-# INLINE runAccum #-}

-- | Run a 'Accum' effect (typically with a 'Monoid'al log),
--   producing the final log and discarding the result value.
--
-- @
-- 'execAccum' w = 'fmap' 'fst' . 'runAccum' w
-- @
--
-- @since 1.1.2.0
execAccum :: (Functor m) => w -> AccumC w m a -> m w
execAccum :: forall (m :: * -> *) w a. Functor m => w -> AccumC w m a -> m w
execAccum w
w = ((w, a) -> w) -> m (w, a) -> m w
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (w, a) -> w
forall a b. (a, b) -> a
fst (m (w, a) -> m w)
-> (AccumC w m a -> m (w, a)) -> AccumC w m a -> m w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> AccumC w m a -> m (w, a)
forall w (m :: * -> *) a. w -> AccumC w m a -> m (w, a)
runAccum w
w
{-# INLINE execAccum #-}

-- | Run a 'Accum' effect (typically with a 'Monoid'al log),
--   producing the result value and discarding the final log.
--
-- @
-- 'evalAccum' w = 'fmap' 'snd' . 'runAccum' w
-- @
--
-- @since 1.1.2.0
evalAccum :: (Functor m) => w -> AccumC w m a -> m a
evalAccum :: forall (m :: * -> *) w a. Functor m => w -> AccumC w m a -> m a
evalAccum w
w = ((w, a) -> a) -> m (w, a) -> m a
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (w, a) -> a
forall a b. (a, b) -> b
snd (m (w, a) -> m a)
-> (AccumC w m a -> m (w, a)) -> AccumC w m a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> AccumC w m a -> m (w, a)
forall w (m :: * -> *) a. w -> AccumC w m a -> m (w, a)
runAccum w
w
{-# INLINE evalAccum #-}

-- | @since 1.1.2.0
newtype AccumC w m a = AccumC { forall w (m :: * -> *) a. AccumC w m a -> w -> m (w, a)
runAccumC :: w -> m (w, a) }

instance Monoid w => MonadTrans (AccumC w) where
  lift :: forall (m :: * -> *) a. Monad m => m a -> AccumC w m a
lift m a
ma = (w -> m (w, a)) -> AccumC w m a
forall w (m :: * -> *) a. (w -> m (w, a)) -> AccumC w m a
AccumC ((w -> m (w, a)) -> AccumC w m a)
-> (w -> m (w, a)) -> AccumC w m a
forall a b. (a -> b) -> a -> b
$ \w
_ -> (w
forall a. Monoid a => a
mempty, ) (a -> (w, a)) -> m a -> m (w, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
ma
  {-# INLINE lift #-}

instance Functor m => 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 = (w -> m (w, b)) -> AccumC w m b
forall w (m :: * -> *) a. (w -> m (w, a)) -> AccumC w m a
AccumC ((w -> m (w, b)) -> AccumC w m b)
-> (w -> m (w, b)) -> AccumC w m b
forall a b. (a -> b) -> a -> b
$ ((w, a) -> (w, b)) -> m (w, a) -> m (w, b)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (w, a) -> (w, b)
forall a b. (a -> b) -> (w, a) -> (w, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (m (w, a) -> m (w, b)) -> (w -> m (w, a)) -> w -> m (w, b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AccumC w m a -> w -> m (w, a)
forall w (m :: * -> *) a. AccumC w m a -> w -> m (w, a)
runAccumC AccumC w m a
ma
  {-# INLINE fmap #-}

instance (Monad m, Monoid w) => Applicative (AccumC w m) where
  pure :: forall a. a -> AccumC w m a
pure a
a = (w -> m (w, a)) -> AccumC w m a
forall w (m :: * -> *) a. (w -> m (w, a)) -> AccumC w m a
AccumC ((w -> m (w, a)) -> AccumC w m a)
-> (w -> m (w, a)) -> AccumC w m a
forall a b. (a -> b) -> a -> b
$ m (w, a) -> w -> m (w, a)
forall a b. a -> b -> a
const (m (w, a) -> w -> m (w, a)) -> m (w, a) -> w -> m (w, a)
forall a b. (a -> b) -> a -> b
$ (w, a) -> m (w, a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 = (w -> m (w, b)) -> AccumC w m b
forall w (m :: * -> *) a. (w -> m (w, a)) -> AccumC w m a
AccumC ((w -> m (w, b)) -> AccumC w m b)
-> (w -> m (w, b)) -> AccumC w m b
forall a b. (a -> b) -> a -> b
$ \w
w -> do
    (w' , f) <- AccumC w m (a -> b) -> w -> m (w, a -> b)
forall w (m :: * -> *) a. AccumC w m a -> w -> m (w, a)
runAccumC AccumC w m (a -> b)
mf w
w
    (w'', a) <- runAccumC ma $ mappend w w'
    return (mappend w' w'', f a)
  {-# 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 = (w -> m (w, a)) -> AccumC w m a
forall w (m :: * -> *) a. (w -> m (w, a)) -> AccumC w m a
AccumC ((w -> m (w, a)) -> AccumC w m a)
-> (w -> m (w, a)) -> AccumC w m a
forall a b. (a -> b) -> a -> b
$ \w
w -> AccumC w m a -> w -> m (w, a)
forall w (m :: * -> *) a. AccumC w m a -> w -> m (w, a)
runAccumC AccumC w m a
ma1 w
w m (w, a) -> m (w, a) -> m (w, a)
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> AccumC w m a -> w -> m (w, a)
forall w (m :: * -> *) a. AccumC w m a -> w -> m (w, a)
runAccumC AccumC w m a
ma2 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 = (w -> m (w, b)) -> AccumC w m b
forall w (m :: * -> *) a. (w -> m (w, a)) -> AccumC w m a
AccumC ((w -> m (w, b)) -> AccumC w m b)
-> (w -> m (w, b)) -> AccumC w m b
forall a b. (a -> b) -> a -> b
$ \w
w -> do
    (w', a) <- AccumC w m a -> w -> m (w, a)
forall w (m :: * -> *) a. AccumC w m a -> w -> m (w, a)
runAccumC AccumC w m a
ma w
w
    (w'', b) <- runAccumC (f a) $ mappend w w'
    return (mappend w' w'', b)
  {-# 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 = (w -> m (w, a)) -> AccumC w m a
forall w (m :: * -> *) a. (w -> m (w, a)) -> AccumC w m a
AccumC ((w -> m (w, a)) -> AccumC w m a)
-> (w -> m (w, a)) -> AccumC w m a
forall a b. (a -> b) -> a -> b
$ \w
w -> AccumC w m a -> w -> m (w, a)
forall w (m :: * -> *) a. AccumC w m a -> w -> m (w, a)
runAccumC AccumC w m a
ma1 w
w m (w, a) -> m (w, a) -> m (w, a)
forall a. m a -> m a -> m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` AccumC w m a -> w -> m (w, a)
forall w (m :: * -> *) a. AccumC w m a -> w -> m (w, a)
runAccumC AccumC w m a
ma2 w
w
  {-# INLINE mplus #-}

instance (MonadFail m, Monoid w) => MonadFail (AccumC w m) where
  fail :: forall a. String -> AccumC w m a
fail = (w -> m (w, a)) -> AccumC w m a
forall w (m :: * -> *) a. (w -> m (w, a)) -> AccumC w m a
AccumC ((w -> m (w, a)) -> AccumC w m a)
-> (String -> w -> m (w, a)) -> String -> AccumC w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (w, a) -> w -> m (w, a)
forall a b. a -> b -> a
const (m (w, a) -> w -> m (w, a))
-> (String -> m (w, a)) -> String -> w -> m (w, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m (w, a)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail
  {-# 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 = (w -> m (w, a)) -> AccumC w m a
forall w (m :: * -> *) a. (w -> m (w, a)) -> AccumC w m a
AccumC ((w -> m (w, a)) -> AccumC w m a)
-> (w -> m (w, a)) -> AccumC w m a
forall a b. (a -> b) -> a -> b
$ \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 (((w, a) -> m (w, a)) -> m (w, a))
-> ((w, a) -> m (w, a)) -> m (w, a)
forall a b. (a -> b) -> a -> b
$ (AccumC w m a -> w -> m (w, a)) -> w -> AccumC w m a -> m (w, a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip AccumC w m a -> w -> m (w, a)
forall w (m :: * -> *) a. AccumC w m a -> w -> m (w, a)
runAccumC 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
  {-# 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 = (w -> m (w, ctx a)) -> AccumC w m (ctx a)
forall w (m :: * -> *) a. (w -> m (w, a)) -> AccumC w m a
AccumC ((w -> m (w, ctx a)) -> AccumC w m (ctx a))
-> (w -> m (w, ctx a)) -> AccumC w m (ctx a)
forall a b. (a -> b) -> a -> b
$ \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 (w, ctx a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (w
w', ctx a
ctx ()
ctx)
      Accum w n a
Look   -> (w, ctx a) -> m (w, ctx a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (w
forall a. Monoid a => a
mempty, 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 -> AccumC w m x -> m (w, x)
forall w (m :: * -> *) a. w -> AccumC w m a -> m (w, a)
runAccum (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)
  {-# INLINE alg #-}