{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wall #-}
module Box.Updater
( Updater(..)
, updater
, listen
, updates
) where
import Control.Applicative (Applicative((<*>), pure))
import Control.Foldl (Fold(..), FoldM(..))
import qualified Control.Foldl as Foldl
import Box
import Control.Monad.Conc.Class as C
import qualified GHC.Conc
data Updater a =
forall e. Updater (FoldM IO e a)
(Cont IO (Emitter GHC.Conc.STM e))
instance Functor Updater where
fmap f (Updater fold' e) = Updater (fmap f fold') e
onLeft :: Monad m => FoldM m a b -> FoldM m (Either a x) b
onLeft (FoldM step begin done) = FoldM step' begin done
where
step' x (Left a) = step x a
step' x _ = return x
onRight :: Monad m => FoldM m a b -> FoldM m (Either x a) b
onRight (FoldM step begin done) = FoldM step' begin done
where
step' x (Right a) = step x a
step' x _ = return x
instance Applicative Updater where
pure a = Updater (pure a) mempty
(Updater foldL eL) <*> (Updater foldR eR) = Updater foldT eT
where
foldT = onLeft foldL <*> onRight foldR
eT = fmap (fmap Left) eL <> fmap (fmap Right) eR
updater :: Fold e a -> Cont IO (Emitter GHC.Conc.STM e) -> Updater a
updater fold' = Updater (Foldl.generalize fold')
listen :: (a -> IO ()) -> Updater a -> Updater a
listen handler (Updater (FoldM step begin done) mController) =
Updater (FoldM step' begin' done) mController
where
begin' = do
x <- begin
b <- done x
handler b
return x
step' x a = do
x' <- step x a
b <- done x'
handler b
return x'
updates :: Updater a -> Cont IO (Emitter GHC.Conc.STM a)
updates (Updater (FoldM step begin done) e) = Cont $ \e' -> queueE cio e'
where
ioref c = do
x <- begin
a <- done x
_ <- atomically $ commit c a
C.newIORef x
cio c =
with e $ \e' -> do
ioref' <- ioref c
x <- C.readIORef ioref'
e'' <- atomically $ emit e'
case e'' of
Nothing -> pure ()
Just e''' -> do
x' <- step x e'''
a <- done x'
_ <- atomically $ commit c a
C.writeIORef ioref' x'