{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Box.Box
( Box (..),
bmap,
hoistb,
glue,
glueb,
fuse,
dotb,
)
where
import Box.Committer
import Box.Emitter
import Data.Functor.Contravariant
import Data.Profunctor
import NumHask.Prelude
data Box m c e
= Box
{ committer :: Committer m c,
emitter :: Emitter m e
}
hoistb :: Monad m => (forall a. m a -> n a) -> Box m c e -> Box n c e
hoistb nat (Box c e) = Box (hoist nat c) (hoist nat e)
instance (Functor m) => Profunctor (Box m) where
dimap f g (Box c e) = Box (contramap f c) (fmap g e)
instance (Alternative m, Monad m) => Semigroup (Box m c e) where
(<>) (Box c e) (Box c' e') = Box (c <> c') (e <> e')
instance (Alternative m, Monad m) => Monoid (Box m c e) where
mempty = Box mempty mempty
mappend = (<>)
bmap :: (Monad m) => (a' -> m (Maybe a)) -> (b -> m (Maybe b')) -> Box m a b -> Box m a' b'
bmap fc fe (Box c e) = Box (mapC fc c) (mapE fe e)
dotb :: (Monad m) => Box m a b -> Box m b c -> m (Box m a c)
dotb (Box c e) (Box c' e') = glue c' e *> pure (Box c e')
glue :: (Monad m) => Committer m a -> Emitter m a -> m ()
glue c e = go
where
go = do
a <- emit e
c' <- maybe (pure False) (commit c) a
when c' go
glueb :: (Monad m) => Box m a a -> m ()
glueb (Box c e) = glue c e
fuse :: (Monad m) => (a -> m (Maybe b)) -> Box m b a -> m ()
fuse f (Box c e) = glue c (mapE f e)