-- | A box is a product of a consumer and producer destructor.
--
-- Consumers and producers (committers and emitters) are paired in two ways:
--
-- - As two ends of a resource such as a file, or screen or queue; input to and output from.
--
-- - As the start and end of a computation pipeline.
module Box.Box
  ( Box (..),
    CoBox,
    CoBoxM (..),
    bmap,
    foistb,
    glue,
    Closure (..),
    glue',
    glueN,
    glueES,
    glueS,
    fuse,
    Divap (..),
    DecAlt (..),
    cobox,
    seqBox,
  )
where

import Box.Codensity
import Box.Committer
import Box.Emitter
import Box.Functor
import Control.Applicative
  ( Alternative (empty, (<|>)),
    Applicative (liftA2),
  )
import Control.Monad
import Control.Monad.State.Lazy
import Data.Bool
import Data.Function
import Data.Functor.Contravariant (Contravariant (contramap))
import Data.Functor.Contravariant.Divisible
  ( Decidable (choose, lose),
    Divisible (conquer, divide),
  )
import Data.Profunctor (Profunctor (dimap))
import Data.Semigroupoid
import Data.Sequence qualified as Seq
import Data.Void (Void, absurd)
import Prelude hiding (id, liftA2, (.))

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Prelude
-- >>> import Box
-- >>> import Data.Text (pack)
-- >>> import Data.Bool
-- >>> import Control.Monad.State.Lazy

-- | A Box is a product of a 'Committer' and an 'Emitter'.
--
-- Think of a box with an incoming arrow an outgoing arrow. And then make your pov ambiguous: are you looking at two wires from "inside a box"; or are you looking from "outside the box"; interacting with a black box object. Either way, it looks the same: it's a box.
--
-- And either way, one of the arrows, the 'Committer', is contravariant and the other, the 'Emitter' is covariant. The combination is a profunctor.
data Box m c e = Box
  { forall (m :: * -> *) c e. Box m c e -> Committer m c
committer :: Committer m c,
    forall (m :: * -> *) c e. Box m c e -> Emitter m e
emitter :: Emitter m e
  }

-- | Wrong kind signature for the FFunctor class
foistb :: (forall a. m a -> n a) -> Box m c e -> Box n c e
foistb :: forall (m :: * -> *) (n :: * -> *) c e.
(forall a. m a -> n a) -> Box m c e -> Box n c e
foistb forall a. m a -> n a
nat (Box Committer m c
c Emitter m e
e) = Committer n c -> Emitter n e -> Box n c e
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box ((forall a. m a -> n a) -> Committer m c -> Committer n c
forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Committer f a -> Committer g a
forall (h :: (* -> *) -> * -> *) (f :: * -> *) (g :: * -> *) a.
FFunctor h =>
(forall x. f x -> g x) -> h f a -> h g a
foist m x -> n x
forall a. m a -> n a
nat Committer m c
c) ((forall a. m a -> n a) -> Emitter m e -> Emitter n e
forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Emitter f a -> Emitter g a
forall (h :: (* -> *) -> * -> *) (f :: * -> *) (g :: * -> *) a.
FFunctor h =>
(forall x. f x -> g x) -> h f a -> h g a
foist m x -> n x
forall a. m a -> n a
nat Emitter m e
e)

instance (Functor m) => Profunctor (Box m) where
  dimap :: forall a b c d. (a -> b) -> (c -> d) -> Box m b c -> Box m a d
dimap a -> b
f c -> d
g (Box Committer m b
c Emitter m c
e) = Committer m a -> Emitter m d -> Box m a d
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box ((a -> b) -> Committer m b -> Committer m a
forall a' a. (a' -> a) -> Committer m a -> Committer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap a -> b
f Committer m b
c) ((c -> d) -> Emitter m c -> Emitter m d
forall a b. (a -> b) -> Emitter m a -> Emitter m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> d
g Emitter m c
e)

instance (Alternative m, Monad m) => Semigroup (Box m c e) where
  <> :: Box m c e -> Box m c e -> Box m c e
(<>) (Box Committer m c
c Emitter m e
e) (Box Committer m c
c' Emitter m e
e') = Committer m c -> Emitter m e -> Box m c e
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box (Committer m c
c Committer m c -> Committer m c -> Committer m c
forall a. Semigroup a => a -> a -> a
<> Committer m c
c') (Emitter m e
e Emitter m e -> Emitter m e -> Emitter m e
forall a. Semigroup a => a -> a -> a
<> Emitter m e
e')

instance (Alternative m, Monad m) => Monoid (Box m c e) where
  mempty :: Box m c e
mempty = Committer m c -> Emitter m e -> Box m c e
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box Committer m c
forall a. Monoid a => a
mempty Emitter m e
forall a. Monoid a => a
mempty
  mappend :: Box m c e -> Box m c e -> Box m c e
mappend = Box m c e -> Box m c e -> Box m c e
forall a. Semigroup a => a -> a -> a
(<>)

-- | A profunctor dimapMaybe
bmap :: (Monad m) => (a' -> m (Maybe a)) -> (b -> m (Maybe b')) -> Box m a b -> Box m a' b'
bmap :: forall (m :: * -> *) a' a b b'.
Monad m =>
(a' -> m (Maybe a))
-> (b -> m (Maybe b')) -> Box m a b -> Box m a' b'
bmap a' -> m (Maybe a)
fc b -> m (Maybe b')
fe (Box Committer m a
c Emitter m b
e) = Committer m a' -> Emitter m b' -> Box m a' b'
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box ((a' -> m (Maybe a)) -> Committer m a -> Committer m a'
forall (m :: * -> *) b a.
Monad m =>
(b -> m (Maybe a)) -> Committer m a -> Committer m b
witherC a' -> m (Maybe a)
fc Committer m a
c) ((b -> m (Maybe b')) -> Emitter m b -> Emitter m b'
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Emitter m a -> Emitter m b
witherE b -> m (Maybe b')
fe Emitter m b
e)

-- | Connect an emitter directly to a committer of the same type.
--
-- >>> glue showStdout <$|> qList [1..3]
-- 1
-- 2
-- 3
glue :: (Monad m) => Committer m a -> Emitter m a -> m ()
glue :: forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue Committer m a
c Emitter m a
e = (m () -> m ()) -> m ()
forall a. (a -> a) -> a
fix ((m () -> m ()) -> m ()) -> (m () -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \m ()
rec -> Emitter m a -> m (Maybe a)
forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
e m (Maybe a) -> (Maybe a -> m Bool) -> m Bool
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m Bool -> (a -> m Bool) -> Maybe a -> m Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) (Committer m a -> a -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m a
c) m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m () -> m () -> Bool -> m ()
forall a. a -> a -> Bool -> a
bool (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) m ()
rec

-- | Whether the committer or emitter closed the computation.
data Closure = CommitterClosed | EmitterClosed deriving (Closure -> Closure -> Bool
(Closure -> Closure -> Bool)
-> (Closure -> Closure -> Bool) -> Eq Closure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Closure -> Closure -> Bool
== :: Closure -> Closure -> Bool
$c/= :: Closure -> Closure -> Bool
/= :: Closure -> Closure -> Bool
Eq, Int -> Closure -> ShowS
[Closure] -> ShowS
Closure -> String
(Int -> Closure -> ShowS)
-> (Closure -> String) -> ([Closure] -> ShowS) -> Show Closure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Closure -> ShowS
showsPrec :: Int -> Closure -> ShowS
$cshow :: Closure -> String
show :: Closure -> String
$cshowList :: [Closure] -> ShowS
showList :: [Closure] -> ShowS
Show, Eq Closure
Eq Closure =>
(Closure -> Closure -> Ordering)
-> (Closure -> Closure -> Bool)
-> (Closure -> Closure -> Bool)
-> (Closure -> Closure -> Bool)
-> (Closure -> Closure -> Bool)
-> (Closure -> Closure -> Closure)
-> (Closure -> Closure -> Closure)
-> Ord Closure
Closure -> Closure -> Bool
Closure -> Closure -> Ordering
Closure -> Closure -> Closure
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Closure -> Closure -> Ordering
compare :: Closure -> Closure -> Ordering
$c< :: Closure -> Closure -> Bool
< :: Closure -> Closure -> Bool
$c<= :: Closure -> Closure -> Bool
<= :: Closure -> Closure -> Bool
$c> :: Closure -> Closure -> Bool
> :: Closure -> Closure -> Bool
$c>= :: Closure -> Closure -> Bool
>= :: Closure -> Closure -> Bool
$cmax :: Closure -> Closure -> Closure
max :: Closure -> Closure -> Closure
$cmin :: Closure -> Closure -> Closure
min :: Closure -> Closure -> Closure
Ord)

-- | Connect an emitter directly to a committer of the same type, returning whether the emitter or committer caused eventual closure.
--
-- >>> glue' showStdout <$|> qList [1..3]
-- 1
-- 2
-- 3
-- EmitterClosed
glue' :: (Monad m) => Committer m a -> Emitter m a -> m Closure
glue' :: forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m Closure
glue' Committer m a
c Emitter m a
e =
  (m Closure -> m Closure) -> m Closure
forall a. (a -> a) -> a
fix ((m Closure -> m Closure) -> m Closure)
-> (m Closure -> m Closure) -> m Closure
forall a b. (a -> b) -> a -> b
$ \m Closure
rec ->
    Emitter m a -> m (Maybe a)
forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
e
      m (Maybe a) -> (Maybe a -> m Closure) -> m Closure
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m Closure -> (a -> m Closure) -> Maybe a -> m Closure
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (Closure -> m Closure
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Closure
EmitterClosed)
        (Committer m a -> a -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m a
c (a -> m Bool) -> (Bool -> m Closure) -> a -> m Closure
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> m Closure -> m Closure -> Bool -> m Closure
forall a. a -> a -> Bool -> a
bool (Closure -> m Closure
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Closure
CommitterClosed) m Closure
rec)

-- | Connect a Stateful emitter to a (non-stateful) committer of the same type, supplying initial state.
--
-- >>> glueES 0 (showStdout) <$|> (takeE 2 <$> qList [1..3])
-- 1
-- 2
glueES :: (Monad m) => s -> Committer m a -> Emitter (StateT s m) a -> m ()
glueES :: forall (m :: * -> *) s a.
Monad m =>
s -> Committer m a -> Emitter (StateT s m) a -> m ()
glueES s
s Committer m a
c Emitter (StateT s m) a
e = (StateT s m () -> s -> m ()) -> s -> StateT s m () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT s m () -> s -> m ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT s
s (StateT s m () -> m ()) -> StateT s m () -> m ()
forall a b. (a -> b) -> a -> b
$ Committer (StateT s m) a -> Emitter (StateT s m) a -> StateT s m ()
forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue ((forall x. m x -> StateT s m x)
-> Committer m a -> Committer (StateT s m) a
forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Committer f a -> Committer g a
forall (h :: (* -> *) -> * -> *) (f :: * -> *) (g :: * -> *) a.
FFunctor h =>
(forall x. f x -> g x) -> h f a -> h g a
foist m x -> StateT s m x
forall x. m x -> StateT s m x
forall (m :: * -> *) a. Monad m => m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Committer m a
c) Emitter (StateT s m) a
e

-- | Connect a Stateful emitter to a (similarly-stateful) committer of the same type, supplying initial state.
--
-- >>> glueS 0 (foist lift showStdout) <$|> (takeE 2 <$> qList [1..3])
-- 1
-- 2
glueS :: (Monad m) => s -> Committer (StateT s m) a -> Emitter (StateT s m) a -> m ()
glueS :: forall (m :: * -> *) s a.
Monad m =>
s -> Committer (StateT s m) a -> Emitter (StateT s m) a -> m ()
glueS s
s Committer (StateT s m) a
c Emitter (StateT s m) a
e = (StateT s m () -> s -> m ()) -> s -> StateT s m () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT s m () -> s -> m ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT s
s (StateT s m () -> m ()) -> StateT s m () -> m ()
forall a b. (a -> b) -> a -> b
$ Committer (StateT s m) a -> Emitter (StateT s m) a -> StateT s m ()
forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue Committer (StateT s m) a
c Emitter (StateT s m) a
e

-- | Glues a committer and emitter, and takes n emits
--
-- >>> glueN 3 <$> pure showStdout <*|> qList [1..]
-- 1
-- 2
-- 3
--
-- Note that glueN counts the number of events passing across the connection and doesn't take into account post-transmission activity in the Committer, eg
--
-- >>> glueN 4 (witherC (\x -> bool (pure Nothing) (pure (Just x)) (even x)) showStdout) <$|> qList [0..9]
-- 0
-- 2
glueN :: (Monad m) => Int -> Committer m a -> Emitter m a -> m ()
glueN :: forall (m :: * -> *) a.
Monad m =>
Int -> Committer m a -> Emitter m a -> m ()
glueN Int
n Committer m a
c Emitter m a
e = (StateT Int m () -> Int -> m ()) -> Int -> StateT Int m () -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Int m () -> Int -> m ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Int
0 (StateT Int m () -> m ()) -> StateT Int m () -> m ()
forall a b. (a -> b) -> a -> b
$ Committer (StateT Int m) a
-> Emitter (StateT Int m) a -> StateT Int m ()
forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue ((forall x. m x -> StateT Int m x)
-> Committer m a -> Committer (StateT Int m) a
forall (f :: * -> *) (g :: * -> *) a.
(forall x. f x -> g x) -> Committer f a -> Committer g a
forall (h :: (* -> *) -> * -> *) (f :: * -> *) (g :: * -> *) a.
FFunctor h =>
(forall x. f x -> g x) -> h f a -> h g a
foist m x -> StateT Int m x
forall x. m x -> StateT Int m x
forall (m :: * -> *) a. Monad m => m a -> StateT Int m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Committer m a
c) (Int -> Emitter m a -> Emitter (StateT Int m) a
forall (m :: * -> *) a.
Monad m =>
Int -> Emitter m a -> Emitter (StateT Int m) a
takeE Int
n Emitter m a
e)

-- | Glue a Committer to an Emitter within a box.
--
-- > fuse (pure . pure) == \(Box c e) -> glue c e
--
-- A command-line echoer
--
-- > fuse (pure . Just . ("echo " <>)) (Box toStdout fromStdin)
fuse :: (Monad m) => (a -> m (Maybe b)) -> Box m b a -> m ()
fuse :: forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Box m b a -> m ()
fuse a -> m (Maybe b)
f (Box Committer m b
c Emitter m a
e) = Committer m b -> Emitter m b -> m ()
forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue Committer m b
c ((a -> m (Maybe b)) -> Emitter m a -> Emitter m b
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Emitter m a -> Emitter m b
witherE a -> m (Maybe b)
f Emitter m a
e)

-- | combines 'divide' 'conquer' and 'liftA2' 'pure'
class Divap p where
  divap :: (a -> (b, c)) -> ((d, e) -> f) -> p b d -> p c e -> p a f
  conpur :: a -> p b a

instance (Applicative m) => Divap (Box m) where
  divap :: forall a b c d e f.
(a -> (b, c))
-> ((d, e) -> f) -> Box m b d -> Box m c e -> Box m a f
divap a -> (b, c)
split' (d, e) -> f
merge (Box Committer m b
lc Emitter m d
le) (Box Committer m c
rc Emitter m e
re) =
    Committer m a -> Emitter m f -> Box m a f
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box ((a -> (b, c)) -> Committer m b -> Committer m c -> Committer m a
forall a b c.
(a -> (b, c)) -> Committer m b -> Committer m c -> Committer m a
forall (f :: * -> *) a b c.
Divisible f =>
(a -> (b, c)) -> f b -> f c -> f a
divide a -> (b, c)
split' Committer m b
lc Committer m c
rc) ((d -> e -> f) -> Emitter m d -> Emitter m e -> Emitter m f
forall a b c.
(a -> b -> c) -> Emitter m a -> Emitter m b -> Emitter m c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (((d, e) -> f) -> d -> e -> f
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (d, e) -> f
merge) Emitter m d
le Emitter m e
re)

  conpur :: forall a b. a -> Box m b a
conpur a
a = Committer m b -> Emitter m a -> Box m b a
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box Committer m b
forall a. Committer m a
forall (f :: * -> *) a. Divisible f => f a
conquer (a -> Emitter m a
forall a. a -> Emitter m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)

-- | combines 'Decidable' and 'Alternative'
class (Profunctor p) => DecAlt p where
  choice :: (a -> Either b c) -> (Either d e -> f) -> p b d -> p c e -> p a f
  loss :: p Void b

instance (Monad m, Alternative m) => DecAlt (Box m) where
  choice :: forall a b c d e f.
(a -> Either b c)
-> (Either d e -> f) -> Box m b d -> Box m c e -> Box m a f
choice a -> Either b c
split' Either d e -> f
merge (Box Committer m b
lc Emitter m d
le) (Box Committer m c
rc Emitter m e
re) =
    Committer m a -> Emitter m f -> Box m a f
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box ((a -> Either b c)
-> Committer m b -> Committer m c -> Committer m a
forall a b c.
(a -> Either b c)
-> Committer m b -> Committer m c -> Committer m a
forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose a -> Either b c
split' Committer m b
lc Committer m c
rc) ((Either d e -> f) -> Emitter m (Either d e) -> Emitter m f
forall a b. (a -> b) -> Emitter m a -> Emitter m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either d e -> f
merge (Emitter m (Either d e) -> Emitter m f)
-> Emitter m (Either d e) -> Emitter m f
forall a b. (a -> b) -> a -> b
$ (d -> Either d e) -> Emitter m d -> Emitter m (Either d e)
forall a b. (a -> b) -> Emitter m a -> Emitter m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap d -> Either d e
forall a b. a -> Either a b
Left Emitter m d
le Emitter m (Either d e)
-> Emitter m (Either d e) -> Emitter m (Either d e)
forall a. Emitter m a -> Emitter m a -> Emitter m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (e -> Either d e) -> Emitter m e -> Emitter m (Either d e)
forall a b. (a -> b) -> Emitter m a -> Emitter m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap e -> Either d e
forall a b. b -> Either a b
Right Emitter m e
re)
  loss :: forall b. Box m Void b
loss = Committer m Void -> Emitter m b -> Box m Void b
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box ((Void -> Void) -> Committer m Void
forall a. (a -> Void) -> Committer m a
forall (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose Void -> Void
forall a. Void -> a
absurd) Emitter m b
forall a. Emitter m a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | A box continuation
type CoBox m a b = Codensity m (Box m a b)

-- | Construct a CoBox
--
--
-- > cobox = Box <$> c <*> e
--
-- >>> fuse (pure . Just . ("show: " <>) . pack . show) <$|> (cobox (pure toStdout) (qList [1..3]))
-- show: 1
-- show: 2
-- show: 3
cobox :: CoCommitter m a -> CoEmitter m b -> CoBox m a b
cobox :: forall (m :: * -> *) a b.
CoCommitter m a -> CoEmitter m b -> CoBox m a b
cobox CoCommitter m a
c CoEmitter m b
e = Committer m a -> Emitter m b -> Box m a b
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box (Committer m a -> Emitter m b -> Box m a b)
-> CoCommitter m a -> Codensity m (Emitter m b -> Box m a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoCommitter m a
c Codensity m (Emitter m b -> Box m a b)
-> CoEmitter m b -> Codensity m (Box m a b)
forall a b. Codensity m (a -> b) -> Codensity m a -> Codensity m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoEmitter m b
e

-- | State monad queue.
seqBox :: (Monad m) => Box (StateT (Seq.Seq a) m) a a
seqBox :: forall (m :: * -> *) a. Monad m => Box (StateT (Seq a) m) a a
seqBox = Committer (StateT (Seq a) m) a
-> Emitter (StateT (Seq a) m) a -> Box (StateT (Seq a) m) a a
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box Committer (StateT (Seq a) m) a
forall (m :: * -> *) a. Monad m => Committer (StateT (Seq a) m) a
push Emitter (StateT (Seq a) m) a
forall (m :: * -> *) a. Monad m => Emitter (StateT (Seq a) m) a
pop

-- | cps composition of monadic boxes
dotco :: (Monad m) => Codensity m (Box m a b) -> Codensity m (Box m b c) -> Codensity m (Box m a c)
dotco :: forall (m :: * -> *) a b c.
Monad m =>
Codensity m (Box m a b)
-> Codensity m (Box m b c) -> Codensity m (Box m a c)
dotco Codensity m (Box m a b)
b Codensity m (Box m b c)
b' = m (Box m a c) -> Codensity m (Box m a c)
forall (m :: * -> *) a. Monad m => m a -> Codensity m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Box m a c) -> Codensity m (Box m a c))
-> m (Box m a c) -> Codensity m (Box m a c)
forall a b. (a -> b) -> a -> b
$ do
  (Box Committer m a
c Emitter m b
e) <- Codensity m (Box m a b) -> m (Box m a b)
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity Codensity m (Box m a b)
b
  (Box Committer m b
c' Emitter m c
e') <- Codensity m (Box m b c) -> m (Box m b c)
forall (f :: * -> *) a. Applicative f => Codensity f a -> f a
lowerCodensity Codensity m (Box m b c)
b'
  Committer m b -> Emitter m b -> m ()
forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue Committer m b
c' Emitter m b
e
  Box m a c -> m (Box m a c)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Committer m a -> Emitter m c -> Box m a c
forall (m :: * -> *) c e. Committer m c -> Emitter m e -> Box m c e
Box Committer m a
c Emitter m c
e')

-- | Wrapper for the semigroupoid instance of a box continuation.
newtype CoBoxM m a b = CoBoxM {forall (m :: * -> *) a b. CoBoxM m a b -> Codensity m (Box m a b)
uncobox :: Codensity m (Box m a b)}

instance (Monad m) => Semigroupoid (CoBoxM m) where
  o :: forall j k1 i. CoBoxM m j k1 -> CoBoxM m i j -> CoBoxM m i k1
o (CoBoxM Codensity m (Box m j k1)
b) (CoBoxM Codensity m (Box m i j)
b') = Codensity m (Box m i k1) -> CoBoxM m i k1
forall (m :: * -> *) a b. Codensity m (Box m a b) -> CoBoxM m a b
CoBoxM (Codensity m (Box m i j)
-> Codensity m (Box m j k1) -> Codensity m (Box m i k1)
forall (m :: * -> *) a b c.
Monad m =>
Codensity m (Box m a b)
-> Codensity m (Box m b c) -> Codensity m (Box m a c)
dotco Codensity m (Box m i j)
b' Codensity m (Box m j k1)
b)