{-# LANGUAGE BangPatterns, TemplateHaskell #-}

module Polysemy.Output
  ( -- * Effect
    Output (..)

    -- * Actions
  , output

    -- * Interpretations
  , runOutputList
  , runLazyOutputList
  , runOutputMonoid
  , runLazyOutputMonoid
  , runOutputMonoidAssocR
  , runLazyOutputMonoidAssocR
  , runOutputMonoidIORef
  , runOutputMonoidTVar
  , outputToIOMonoid
  , outputToIOMonoidAssocR
  , ignoreOutput
  , runOutputBatched
  , runOutputSem
  ) where

import Data.IORef
import Control.Concurrent.STM
import qualified Control.Monad.Trans.Writer.Lazy as Lazy

import Data.Semigroup (Endo(..))
import Data.Bifunctor (first)
import Polysemy
import Polysemy.State
import Control.Monad (when)

import Polysemy.Internal.Union
import Polysemy.Internal.Writer


------------------------------------------------------------------------------
-- | An effect capable of sending messages. Useful for streaming output and for
-- logging.
data Output o m a where
  Output :: o -> Output o m ()

makeSem ''Output


------------------------------------------------------------------------------
-- | Run an 'Output' effect by transforming it into a list of its values.
--
-- @since 1.0.0.0
runOutputList
    :: forall o r a
     . Sem (Output o ': r) a
    -> Sem r ([o], a)
runOutputList :: Sem (Output o : r) a -> Sem r ([o], a)
runOutputList = (([o], a) -> ([o], a)) -> Sem r ([o], a) -> Sem r ([o], a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([o] -> [o]) -> ([o], a) -> ([o], a)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [o] -> [o]
forall a. [a] -> [a]
reverse) (Sem r ([o], a) -> Sem r ([o], a))
-> (Sem (Output o : r) a -> Sem r ([o], a))
-> Sem (Output o : r) a
-> Sem r ([o], a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [o] -> Sem (State [o] : r) a -> Sem r ([o], a)
forall s (r :: [(* -> *) -> * -> *]) a.
s -> Sem (State s : r) a -> Sem r (s, a)
runState [] (Sem (State [o] : r) a -> Sem r ([o], a))
-> (Sem (Output o : r) a -> Sem (State [o] : r) a)
-> Sem (Output o : r) a
-> Sem r ([o], a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (rInitial :: [(* -> *) -> * -> *]) x.
 Output o (Sem rInitial) x -> Sem (State [o] : r) x)
-> Sem (Output o : r) a -> Sem (State [o] : r) a
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
FirstOrder e1 "reinterpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e1 (Sem rInitial) x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
reinterpret
  (\case
      Output o -> ([o] -> [o]) -> Sem (State [o] : r) ()
forall s (r :: [(* -> *) -> * -> *]).
Member (State s) r =>
(s -> s) -> Sem r ()
modify' (o
o o -> [o] -> [o]
forall a. a -> [a] -> [a]
:)
  )
{-# INLINE runOutputList #-}


------------------------------------------------------------------------------
-- | Run an 'Output' effect by transforming it into a list of its values,
-- lazily.
--
-- __Warning: This inherits the nasty space leak issue of__
-- __'Lazy.WriterT'! Don't use this if you don't have to.__
--
-- @since 1.3.0.0
runLazyOutputList
    :: forall o r a
     . Sem (Output o ': r) a
    -> Sem r ([o], a)
runLazyOutputList :: Sem (Output o : r) a -> Sem r ([o], a)
runLazyOutputList = (o -> [o]) -> Sem (Output o : r) a -> Sem r ([o], a)
forall o m (r :: [(* -> *) -> * -> *]) a.
Monoid m =>
(o -> m) -> Sem (Output o : r) a -> Sem r (m, a)
runLazyOutputMonoidAssocR o -> [o]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE runLazyOutputList #-}

------------------------------------------------------------------------------
-- | Run an 'Output' effect by transforming it into a monoid.
--
-- @since 1.0.0.0
runOutputMonoid
    :: forall o m r a
     . Monoid m
    => (o -> m)
    -> Sem (Output o ': r) a
    -> Sem r (m, a)
runOutputMonoid :: (o -> m) -> Sem (Output o : r) a -> Sem r (m, a)
runOutputMonoid o -> m
f = m -> Sem (State m : r) a -> Sem r (m, a)
forall s (r :: [(* -> *) -> * -> *]) a.
s -> Sem (State s : r) a -> Sem r (s, a)
runState m
forall a. Monoid a => a
mempty (Sem (State m : r) a -> Sem r (m, a))
-> (Sem (Output o : r) a -> Sem (State m : r) a)
-> Sem (Output o : r) a
-> Sem r (m, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (rInitial :: [(* -> *) -> * -> *]) x.
 Output o (Sem rInitial) x -> Sem (State m : r) x)
-> Sem (Output o : r) a -> Sem (State m : r) a
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
FirstOrder e1 "reinterpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e1 (Sem rInitial) x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
reinterpret
  (\case
      Output o -> (m -> m) -> Sem (State m : r) ()
forall s (r :: [(* -> *) -> * -> *]).
Member (State s) r =>
(s -> s) -> Sem r ()
modify' (m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` o -> m
f o
o)
  )
{-# INLINE runOutputMonoid #-}


------------------------------------------------------------------------------
-- | Run an 'Output' effect by transforming it into a monoid, and accumulate
-- it lazily.
--
-- __Warning: This inherits the nasty space leak issue of__
-- __'Lazy.WriterT'! Don't use this if you don't have to.__
--
-- @since 1.3.0.0
runLazyOutputMonoid
    :: forall o m r a
     . Monoid m
    => (o -> m)
    -> Sem (Output o ': r) a
    -> Sem r (m, a)
runLazyOutputMonoid :: (o -> m) -> Sem (Output o : r) a -> Sem r (m, a)
runLazyOutputMonoid o -> m
f = (forall (m :: * -> *) x.
 Monad m =>
 Weaving (Output o) (WriterT m m) x -> WriterT m m x)
-> Sem (Output o : r) a -> Sem r (m, a)
forall o (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Monoid o =>
(forall (m :: * -> *) x.
 Monad m =>
 Weaving e (WriterT o m) x -> WriterT o m x)
-> Sem (e : r) a -> Sem r (o, a)
interpretViaLazyWriter ((forall (m :: * -> *) x.
  Monad m =>
  Weaving (Output o) (WriterT m m) x -> WriterT m m x)
 -> Sem (Output o : r) a -> Sem r (m, a))
-> (forall (m :: * -> *) x.
    Monad m =>
    Weaving (Output o) (WriterT m m) x -> WriterT m m x)
-> Sem (Output o : r) a
-> Sem r (m, a)
forall a b. (a -> b) -> a -> b
$ \(Weaving Output o (Sem rInitial) a
e f ()
s forall x. f (Sem rInitial x) -> WriterT m m (f x)
_ f a -> x
ex forall x. f x -> Maybe x
_) ->
  case Output o (Sem rInitial) a
e of
    Output o -> f a -> x
ex f a
f ()
s x -> WriterT m m () -> WriterT m m x
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ m -> WriterT m m ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Lazy.tell (o -> m
f o
o)

------------------------------------------------------------------------------
-- | Like 'runOutputMonoid', but right-associates uses of '<>'.
--
-- This asymptotically improves performance if the time complexity of '<>' for
-- the 'Monoid' depends only on the size of the first argument.
--
-- You should always use this instead of 'runOutputMonoid' if the monoid
-- is a list, such as 'String'.
--
-- @since 1.1.0.0
runOutputMonoidAssocR
    :: forall o m r a
     . Monoid m
    => (o -> m)
    -> Sem (Output o ': r) a
    -> Sem r (m, a)
runOutputMonoidAssocR :: (o -> m) -> Sem (Output o : r) a -> Sem r (m, a)
runOutputMonoidAssocR o -> m
f =
    ((Endo m, a) -> (m, a)) -> Sem r (Endo m, a) -> Sem r (m, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Endo m -> m) -> (Endo m, a) -> (m, a)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Endo m -> m -> m
forall a. Endo a -> a -> a
`appEndo` m
forall a. Monoid a => a
mempty))
  (Sem r (Endo m, a) -> Sem r (m, a))
-> (Sem (Output o : r) a -> Sem r (Endo m, a))
-> Sem (Output o : r) a
-> Sem r (m, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (o -> Endo m) -> Sem (Output o : r) a -> Sem r (Endo m, a)
forall o m (r :: [(* -> *) -> * -> *]) a.
Monoid m =>
(o -> m) -> Sem (Output o : r) a -> Sem r (m, a)
runOutputMonoid (\o
o -> let !o' :: m
o' = o -> m
f o
o in (m -> m) -> Endo m
forall a. (a -> a) -> Endo a
Endo (m
o' m -> m -> m
forall a. Semigroup a => a -> a -> a
<>))
{-# INLINE runOutputMonoidAssocR #-}

------------------------------------------------------------------------------
-- | Like 'runLazyOutputMonoid', but right-associates uses of '<>'.
--
-- This asymptotically improves performance if the time complexity of '<>' for
-- the 'Monoid' depends only on the size of the first argument.
--
-- You should always use this instead of 'runLazyOutputMonoid' if the monoid
-- is a list, such as 'String'.
--
-- __Warning: This inherits the nasty space leak issue of__
-- __'Lazy.WriterT'! Don't use this if you don't have to.__
--
-- @since 1.3.0.0
runLazyOutputMonoidAssocR
    :: forall o m r a
     . Monoid m
    => (o -> m)
    -> Sem (Output o ': r) a
    -> Sem r (m, a)
runLazyOutputMonoidAssocR :: (o -> m) -> Sem (Output o : r) a -> Sem r (m, a)
runLazyOutputMonoidAssocR o -> m
f =
    ((Endo m, a) -> (m, a)) -> Sem r (Endo m, a) -> Sem r (m, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Endo m -> m) -> (Endo m, a) -> (m, a)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Endo m -> m -> m
forall a. Endo a -> a -> a
`appEndo` m
forall a. Monoid a => a
mempty))
  (Sem r (Endo m, a) -> Sem r (m, a))
-> (Sem (Output o : r) a -> Sem r (Endo m, a))
-> Sem (Output o : r) a
-> Sem r (m, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (o -> Endo m) -> Sem (Output o : r) a -> Sem r (Endo m, a)
forall o m (r :: [(* -> *) -> * -> *]) a.
Monoid m =>
(o -> m) -> Sem (Output o : r) a -> Sem r (m, a)
runLazyOutputMonoid (\o
o -> let o' :: m
o' = o -> m
f o
o in (m -> m) -> Endo m
forall a. (a -> a) -> Endo a
Endo (m
o' m -> m -> m
forall a. Semigroup a => a -> a -> a
<>))
                              --   ^ N.B. No bang pattern
{-# INLINE runLazyOutputMonoidAssocR #-}

------------------------------------------------------------------------------
-- | Run an 'Output' effect by transforming it into atomic operations
-- over an 'IORef'.
--
-- @since 1.1.0.0
runOutputMonoidIORef
    :: forall o m r a
     . (Monoid m, Member (Embed IO) r)
    => IORef m
    -> (o -> m)
    -> Sem (Output o ': r) a
    -> Sem r a
runOutputMonoidIORef :: IORef m -> (o -> m) -> Sem (Output o : r) a -> Sem r a
runOutputMonoidIORef IORef m
ref o -> m
f = (forall x (rInitial :: [(* -> *) -> * -> *]).
 Output o (Sem rInitial) x -> Sem r x)
-> Sem (Output o : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: [(* -> *) -> * -> *]).
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall x (rInitial :: [(* -> *) -> * -> *]).
  Output o (Sem rInitial) x -> Sem r x)
 -> Sem (Output o : r) a -> Sem r a)
-> (forall x (rInitial :: [(* -> *) -> * -> *]).
    Output o (Sem rInitial) x -> Sem r x)
-> Sem (Output o : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Output o -> IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ IORef m -> (m -> (m, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef m
ref (\m
s -> let !o' :: m
o' = o -> m
f o
o in (m
s m -> m -> m
forall a. Semigroup a => a -> a -> a
<> m
o', ()))
{-# INLINE runOutputMonoidIORef #-}

------------------------------------------------------------------------------
-- | Run an 'Output' effect by transforming it into atomic operations
-- over a 'TVar'.
--
-- @since 1.1.0.0
runOutputMonoidTVar
    :: forall o m r a
     . (Monoid m, Member (Embed IO) r)
    => TVar m
    -> (o -> m)
    -> Sem (Output o ': r) a
    -> Sem r a
runOutputMonoidTVar :: TVar m -> (o -> m) -> Sem (Output o : r) a -> Sem r a
runOutputMonoidTVar TVar m
tvar o -> m
f = (forall x (rInitial :: [(* -> *) -> * -> *]).
 Output o (Sem rInitial) x -> Sem r x)
-> Sem (Output o : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: [(* -> *) -> * -> *]).
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall x (rInitial :: [(* -> *) -> * -> *]).
  Output o (Sem rInitial) x -> Sem r x)
 -> Sem (Output o : r) a -> Sem r a)
-> (forall x (rInitial :: [(* -> *) -> * -> *]).
    Output o (Sem rInitial) x -> Sem r x)
-> Sem (Output o : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Output o -> IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    m
s <- TVar m -> STM m
forall a. TVar a -> STM a
readTVar TVar m
tvar
    TVar m -> m -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar m
tvar (m -> STM ()) -> m -> STM ()
forall a b. (a -> b) -> a -> b
$! m
s m -> m -> m
forall a. Semigroup a => a -> a -> a
<> o -> m
f o
o
{-# INLINE runOutputMonoidTVar #-}


--------------------------------------------------------------------
-- | Run an 'Output' effect in terms of atomic operations
-- in 'IO'.
--
-- Internally, this simply creates a new 'IORef', passes it to
-- 'runOutputMonoidIORef', and then returns the result and the final value
-- of the 'IORef'.
--
-- /Beware/: As this uses an 'IORef' internally,
-- all other effects will have local
-- state semantics in regards to 'Output' effects
-- interpreted this way.
-- For example, 'Polysemy.Error.throw' and 'Polysemy.Error.catch' will
-- never revert 'output's, even if 'Polysemy.Error.runError' is used
-- after 'outputToIOMonoid'.
--
-- @since 1.2.0.0
outputToIOMonoid
  :: forall o m r a
   . (Monoid m, Member (Embed IO) r)
  => (o -> m)
  -> Sem (Output o ': r) a
  -> Sem r (m, a)
outputToIOMonoid :: (o -> m) -> Sem (Output o : r) a -> Sem r (m, a)
outputToIOMonoid o -> m
f Sem (Output o : r) a
sem = do
  IORef m
ref <- IO (IORef m) -> Sem r (IORef m)
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO (IORef m) -> Sem r (IORef m))
-> IO (IORef m) -> Sem r (IORef m)
forall a b. (a -> b) -> a -> b
$ m -> IO (IORef m)
forall a. a -> IO (IORef a)
newIORef m
forall a. Monoid a => a
mempty
  a
res <- IORef m -> (o -> m) -> Sem (Output o : r) a -> Sem r a
forall o m (r :: [(* -> *) -> * -> *]) a.
(Monoid m, Member (Embed IO) r) =>
IORef m -> (o -> m) -> Sem (Output o : r) a -> Sem r a
runOutputMonoidIORef IORef m
ref o -> m
f Sem (Output o : r) a
sem
  m
end <- IO m -> Sem r m
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO m -> Sem r m) -> IO m -> Sem r m
forall a b. (a -> b) -> a -> b
$ IORef m -> IO m
forall a. IORef a -> IO a
readIORef IORef m
ref
  (m, a) -> Sem r (m, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (m
end, a
res)

------------------------------------------------------------------------------
-- | Like 'outputToIOMonoid', but right-associates uses of '<>'.
--
-- This asymptotically improves performance if the time complexity of '<>' for
-- the 'Monoid' depends only on the size of the first argument.
--
-- You should always use this instead of 'outputToIOMonoid' if the monoid
-- is a list, such as 'String'.
--
-- /Beware/: As this uses an 'IORef' internally,
-- all other effects will have local
-- state semantics in regards to 'Output' effects
-- interpreted this way.
-- For example, 'Polysemy.Error.throw' and 'Polysemy.Error.catch' will
-- never revert 'output's, even if 'Polysemy.Error.runError' is used
-- after 'outputToIOMonoidAssocR'.
--
-- @since 1.2.0.0
outputToIOMonoidAssocR
  :: forall o m r a
   . (Monoid m, Member (Embed IO) r)
  => (o -> m)
  -> Sem (Output o ': r) a
  -> Sem r (m, a)
outputToIOMonoidAssocR :: (o -> m) -> Sem (Output o : r) a -> Sem r (m, a)
outputToIOMonoidAssocR o -> m
f =
    (((Endo m, a) -> (m, a)) -> Sem r (Endo m, a) -> Sem r (m, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Endo m, a) -> (m, a)) -> Sem r (Endo m, a) -> Sem r (m, a))
-> ((Endo m -> m) -> (Endo m, a) -> (m, a))
-> (Endo m -> m)
-> Sem r (Endo m, a)
-> Sem r (m, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Endo m -> m) -> (Endo m, a) -> (m, a)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first) (Endo m -> m -> m
forall a. Endo a -> a -> a
`appEndo` m
forall a. Monoid a => a
mempty)
  (Sem r (Endo m, a) -> Sem r (m, a))
-> (Sem (Output o : r) a -> Sem r (Endo m, a))
-> Sem (Output o : r) a
-> Sem r (m, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (o -> Endo m) -> Sem (Output o : r) a -> Sem r (Endo m, a)
forall o m (r :: [(* -> *) -> * -> *]) a.
(Monoid m, Member (Embed IO) r) =>
(o -> m) -> Sem (Output o : r) a -> Sem r (m, a)
outputToIOMonoid (\o
o -> let !o' :: m
o' = o -> m
f o
o in (m -> m) -> Endo m
forall a. (a -> a) -> Endo a
Endo (m
o' m -> m -> m
forall a. Semigroup a => a -> a -> a
<>))

------------------------------------------------------------------------------
-- | Run an 'Output' effect by ignoring it.
--
-- @since 1.0.0.0
ignoreOutput :: Sem (Output o ': r) a -> Sem r a
ignoreOutput :: Sem (Output o : r) a -> Sem r a
ignoreOutput = (forall x (rInitial :: [(* -> *) -> * -> *]).
 Output o (Sem rInitial) x -> Sem r x)
-> Sem (Output o : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: [(* -> *) -> * -> *]).
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall x (rInitial :: [(* -> *) -> * -> *]).
  Output o (Sem rInitial) x -> Sem r x)
 -> Sem (Output o : r) a -> Sem r a)
-> (forall x (rInitial :: [(* -> *) -> * -> *]).
    Output o (Sem rInitial) x -> Sem r x)
-> Sem (Output o : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Output _ -> () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINE ignoreOutput #-}


------------------------------------------------------------------------------
-- | Accumulate 'output's so they are delayed until they reach at least size
-- @size@.
--
-- If @size@ is 0, this interpretation will not emit anything in the resulting
-- 'Output' effect.
--
-- @since 1.0.0.0
runOutputBatched
    :: forall o r a
     . Member (Output [o]) r
    => Int
    -> Sem (Output o ': r) a
    -> Sem r a
runOutputBatched :: Int -> Sem (Output o : r) a -> Sem r a
runOutputBatched Int
0 Sem (Output o : r) a
m = Sem (Output o : r) a -> Sem r a
forall o (r :: [(* -> *) -> * -> *]) a.
Sem (Output o : r) a -> Sem r a
ignoreOutput Sem (Output o : r) a
m
runOutputBatched Int
size Sem (Output o : r) a
m = do
  ((Int
c, [o]
res), a
a) <-
    (Int, [o]) -> Sem (State (Int, [o]) : r) a -> Sem r ((Int, [o]), a)
forall s (r :: [(* -> *) -> * -> *]) a.
s -> Sem (State s : r) a -> Sem r (s, a)
runState (Int
0 :: Int, [] :: [o]) (Sem (State (Int, [o]) : r) a -> Sem r ((Int, [o]), a))
-> Sem (State (Int, [o]) : r) a -> Sem r ((Int, [o]), a)
forall a b. (a -> b) -> a -> b
$ (forall (rInitial :: [(* -> *) -> * -> *]) x.
 Output o (Sem rInitial) x -> Sem (State (Int, [o]) : r) x)
-> Sem (Output o : r) a -> Sem (State (Int, [o]) : r) a
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
FirstOrder e1 "reinterpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e1 (Sem rInitial) x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
reinterpret (\case
      Output o -> do
        (Int
count, [o]
acc) <- Sem (State (Int, [o]) : r) (Int, [o])
forall s (r :: [(* -> *) -> * -> *]).
MemberWithError (State s) r =>
Sem r s
get
        let newCount :: Int
newCount = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
count
            newAcc :: [o]
newAcc = o
o o -> [o] -> [o]
forall a. a -> [a] -> [a]
: [o]
acc
        if Int
newCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
size
          then (Int, [o]) -> Sem (State (Int, [o]) : r) ()
forall s (r :: [(* -> *) -> * -> *]).
MemberWithError (State s) r =>
s -> Sem r ()
put (Int
newCount, [o]
newAcc)
          else do
            [o] -> Sem (State (Int, [o]) : r) ()
forall o (r :: [(* -> *) -> * -> *]).
MemberWithError (Output o) r =>
o -> Sem r ()
output ([o] -> [o]
forall a. [a] -> [a]
reverse [o]
newAcc)
            (Int, [o]) -> Sem (State (Int, [o]) : r) ()
forall s (r :: [(* -> *) -> * -> *]).
MemberWithError (State s) r =>
s -> Sem r ()
put (Int
0 :: Int, [] :: [o])
    ) Sem (Output o : r) a
m
  Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ [o] -> Sem r ()
forall o (r :: [(* -> *) -> * -> *]).
MemberWithError (Output o) r =>
o -> Sem r ()
output @[o] ([o] -> [o]
forall a. [a] -> [a]
reverse [o]
res)
  a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

------------------------------------------------------------------------------
-- | Runs an 'Output' effect by running a monadic action for each of its
-- values.
runOutputSem :: (o -> Sem r ()) -> Sem (Output o ': r) a -> Sem r a
runOutputSem :: (o -> Sem r ()) -> Sem (Output o : r) a -> Sem r a
runOutputSem o -> Sem r ()
act = (forall x (rInitial :: [(* -> *) -> * -> *]).
 Output o (Sem rInitial) x -> Sem r x)
-> Sem (Output o : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (rInitial :: [(* -> *) -> * -> *]).
 e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall x (rInitial :: [(* -> *) -> * -> *]).
  Output o (Sem rInitial) x -> Sem r x)
 -> Sem (Output o : r) a -> Sem r a)
-> (forall x (rInitial :: [(* -> *) -> * -> *]).
    Output o (Sem rInitial) x -> Sem r x)
-> Sem (Output o : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
    Output o -> o -> Sem r ()
act o
o
{-# INLINE runOutputSem #-}