{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}
module Box.Committer
( Committer (..),
liftC,
cmap,
handles,
)
where
import Prelude
import Control.Lens hiding ((.>), (:>), (<|), (|>))
import Control.Monad.Conc.Class as C
import Data.Functor.Constant
import Data.Functor.Contravariant.Divisible
import Data.Monoid (First (..))
import Data.Void (absurd)
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)