Permalink
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
68 lines (54 sloc) 1.9 KB
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FunctionalDependencies #-}
module UpdateT where
import Control.Monad.IO.Class
import Data.Monoid
class (Monoid p) =>
ApplyAction p s
where
applyAction :: p -> s -> s
class (ApplyAction p s, Monad m) =>
MonadUpdate m p s
| m -> s
, m -> p
where
putAction :: p -> m ()
getState :: m s
data UpdateT p s m a = UpdateT
{ runUpdateT :: (s -> m (p, a))
} deriving (Functor)
instance (ApplyAction p s, Monad m) => Applicative (UpdateT p s m) where
pure a = UpdateT . const $ pure (mempty, a)
UpdateT u <*> UpdateT t =
UpdateT $ \s -> do
(p, f) <- u s
(p', a) <- t (applyAction p s)
return (p' <> p, f a)
instance (ApplyAction p s, Monad m) => Monad (UpdateT p s m) where
UpdateT u >>= f =
UpdateT $ \s -> do
(p, a) <- u s
let UpdateT fs = f a
(p', a) <- fs (applyAction p s)
return (p <> p', a)
instance (Monad m, ApplyAction p s) => MonadUpdate (UpdateT p s m) p s where
putAction p = UpdateT $ \_ -> pure (p, ())
getState = UpdateT $ \s -> pure (mempty, s)
instance (MonadIO m, ApplyAction p s) => MonadIO (UpdateT p s m) where
liftIO m = UpdateT $ \_ -> liftIO m >>= \x -> return (mempty, x)
evalUpdateT :: (ApplyAction p s, Monad m) => UpdateT p s m a -> s -> m a
evalUpdateT u s = snd <$> runUpdateT u s
execUpdateT :: (ApplyAction p s, Monad m) => UpdateT p s m a -> s -> m s
execUpdateT u s = snd <$> runUpdateT (u *> getState) s
collectUpdateT :: (ApplyAction p s, Monad m) => UpdateT p s m a -> s -> m p
collectUpdateT u s = fst <$> runUpdateT u s
auditUpdateT ::
(Monad m, ApplyAction p s) => UpdateT p s m a -> s -> m (s, p, a)
auditUpdateT u s = do
(p, (a, s)) <- runUpdateT ((,) <$> u <*> getState) s
return (s, p, a)