{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wall #-}
module Box.Committer
( Committer (..),
drain,
mapC,
premapC,
postmapC,
stateC,
listC,
)
where
import Data.Functor.Contravariant
import Data.Functor.Contravariant.Divisible
import NumHask.Prelude
newtype Committer m a
= Committer
{ commit :: a -> m Bool
}
instance MFunctor Committer where
hoist nat (Committer c) = Committer $ nat . c
instance (Applicative m) => Semigroup (Committer m a) where
(<>) i1 i2 = Committer (\a -> (||) <$> commit i1 a <*> commit i2 a)
instance (Applicative m) => Monoid (Committer m a) where
mempty = Committer (\_ -> pure False)
mappend = (<>)
instance Contravariant (Committer m) where
contramap f (Committer a) = Committer (a . f)
instance (Applicative m) => Divisible (Committer m) where
conquer = Committer (\_ -> pure False)
divide f i1 i2 =
Committer $ \a ->
case f a of
(b, c) -> (||) <$> commit i1 b <*> commit i2 c
instance (Applicative m) => Decidable (Committer m) where
lose f = Committer (absurd . f)
choose f i1 i2 =
Committer $ \a ->
case f a of
Left b -> commit i1 b
Right c -> commit i2 c
drain :: (Applicative m) => Committer m a
drain = Committer (\_ -> pure True)
mapC :: (Monad m) => (b -> m (Maybe a)) -> Committer m a -> Committer m b
mapC f c = Committer go
where
go b = do
fb <- f b
case fb of
Nothing -> pure True
Just fb' -> commit c fb'
premapC ::
(Applicative m) =>
(Committer m a -> m ()) ->
Committer m a ->
Committer m a
premapC f c = Committer $ \a -> f c *> commit c a
postmapC ::
(Monad m) =>
(Committer m a -> m ()) ->
Committer m a ->
Committer m a
postmapC f c = Committer $ \a -> do
r <- commit c a
f c
pure r
stateC :: (Monad m) => Committer (StateT [a] m) a
stateC = Committer $ \a -> do
modify (a :)
pure True
listC :: (Monad m) => Committer m a -> Committer m [a]
listC c = Committer $ \as ->
any id <$> (sequence $ commit c <$> as)