{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Box.Box
( Box (..),
bmap,
hoistb,
glue,
glue_,
glueb,
fuse,
dotb,
Divap (..),
DecAlt (..),
)
where
import Box.Committer
import Box.Emitter
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Divisible
import Data.Profunctor
import NumHask.Prelude
data Box m c e = Box
{ Box m c e -> Committer m c
committer :: Committer m c,
Box m c e -> Emitter m e
emitter :: Emitter m e
}
hoistb :: Monad m => (forall a. m a -> n a) -> Box m c e -> Box n c e
hoistb :: (forall a. m a -> n a) -> Box m c e -> Box n c e
hoistb 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 k (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
(b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall a. m a -> n a
nat Committer m c
c) ((forall a. m a -> n a) -> Emitter m e -> Emitter n e
forall k (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
(b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall a. m a -> n a
nat Emitter m e
e)
instance (Functor m) => Profunctor (Box m) where
dimap :: (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 (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap a -> b
f Committer m b
c) ((c -> d) -> Emitter m c -> Emitter m d
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
(<>)
bmap :: (Monad m) => (a' -> m (Maybe a)) -> (b -> m (Maybe b')) -> Box m a b -> Box m a' b'
bmap :: (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
mapC 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
mapE b -> m (Maybe b')
fe Emitter m b
e)
dotb :: (Monad m) => Box m a b -> Box m b c -> m (Box m a c)
dotb :: Box m a b -> Box m b c -> m (Box m a c)
dotb (Box Committer m a
c Emitter m b
e) (Box Committer m b
c' Emitter m c
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' Emitter m b
e m () -> Box m a c -> m (Box m a c)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> 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'
glue :: (Monad m) => Committer m a -> Emitter m a -> m ()
glue :: Committer m a -> Emitter m a -> m ()
glue Committer m a
c Emitter m a
e = m ()
go
where
go :: m ()
go = do
Maybe a
a <- Emitter m a -> m (Maybe a)
forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
e
Bool
c' <- m Bool -> (a -> m Bool) -> Maybe a -> m Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> m Bool
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) Maybe a
a
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
c' m ()
go
glue_ :: (Monad m) => Committer m a -> Emitter m a -> m ()
glue_ :: Committer m a -> Emitter m a -> m ()
glue_ Committer m a
c Emitter m a
e = m ()
go
where
go :: m ()
go = do
Maybe a
a <- Emitter m a -> m (Maybe a)
forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m a
e
case Maybe a
a of
Maybe a
Nothing -> m ()
go
Just a
a' -> do
Bool
b <- Committer m a -> a -> m Bool
forall (m :: * -> *) a. Committer m a -> a -> m Bool
commit Committer m a
c a
a'
if Bool
b then m ()
go else () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
glueb :: (Monad m) => Box m a a -> m ()
glueb :: Box m a a -> m ()
glueb (Box Committer m a
c Emitter m a
e) = Committer m a -> Emitter m a -> m ()
forall (m :: * -> *) a.
Monad m =>
Committer m a -> Emitter m a -> m ()
glue Committer m a
c Emitter m a
e
fuse :: (Monad m) => (a -> m (Maybe b)) -> Box m b a -> m ()
fuse :: (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
mapE a -> m (Maybe b)
f Emitter m a
e)
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 :: (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 (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 (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 :: 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 (f :: * -> *) a. Divisible f => f a
conquer (a -> Emitter m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)
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 :: (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 (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 (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 (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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (e -> Either d e) -> Emitter m e -> Emitter m (Either d e)
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 :: 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 (f :: * -> *) a. Decidable f => (a -> Void) -> f a
lose Void -> Void
forall a. Void -> a
absurd) Emitter m b
forall (f :: * -> *) a. Alternative f => f a
empty