{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wall #-}
module Box.Committer
( Committer(..)
, liftC
, cmap
, handles
) where
import Control.Lens hiding ((:>), (.>), (<|), (|>))
import Data.Functor.Constant
import Data.Functor.Contravariant.Divisible
import Control.Monad.Conc.Class as C
import Data.Void (absurd)
import Data.Monoid (First(..))
newtype Committer m a = Committer
{ commit :: a -> m Bool
}
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
liftC :: (MonadConc m) => Committer (STM m) a -> Committer m a
liftC c = Committer $ atomically . commit c
cmap :: (Monad m) => (b -> m (Maybe a)) -> Committer m a -> Committer m b
cmap f c = Committer go
where
go b = do
fb <- f b
case fb of
Nothing -> pure True
Just fb' -> commit c fb'
handles ::
(Monad m)
=> ((b -> Constant (First b) b) -> (a -> Constant (First b) a))
-> Committer m b
-> Committer m a
handles k (Committer commit_) =
Committer
(\a ->
case match a of
Nothing -> return False
Just b -> commit_ b)
where
match = getFirst . getConstant . k (Constant . First . Just)