gistfile1.hs

{-# LANGUAGE MultiParamTypeClasses,
             GeneralizedNewtypeDeriving,
             FlexibleContexts,
             FlexibleInstances #-}
module Main where

import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap

import Control.Monad.Reader
import Control.Monad.Writer

-- The intention is to maintain a `Log a' of `Index -> Entry a' mappings
type Index = Int
data Entry a = Entry { eIndex :: Index
                     , eValue :: a
                     }
  deriving (Show)
-- During a transition, we emit `Command's, e.g. 'write some entry'
data Command a = Write (Entry a)
  deriving (Show)

-- `TransitionT' is a monad in which we construct transitions (i.e. emit
-- `Command's)
newtype TransitionT a m r = T { unTransition :: WriterT [Command a] m r }
  deriving (Monad, MonadWriter [Command a], MonadTrans)

runTransitionT :: TransitionT a m r -> m (r, [Command a])
runTransitionT = runWriterT . unTransition

-- Emit a `Command' to be executed
exec :: Monad m => Command a -> TransitionT a m ()
exec c = tell [c]

-- A monad which provides access to a `Log'
class MonadLog m a where
    getEntry :: Index -> m (Maybe (Entry a))

-- Lift `Log' operations when in `TransitionT'
instance (Monad m, MonadLog m a) => MonadLog (TransitionT a m) a where
    getEntry = lift . getEntry

-- A demo transition which needs access to the provides Log. Never mind the
-- implementation, it's just a demo.
demo :: (Monad m, MonadLog m a) => Index -> a -> TransitionT a m String
demo i a = do
    e <- getEntry i
    let v = maybe a eValue e
        n = Entry { eIndex = succ i
                  , eValue = v
                  }
    exec $ Write n
    return "Done"

-- A specific implementation of a monad providing a Log
type Log a = IntMap (Entry a)
newtype MemLog a r = M { unMemLog :: Reader (Log a) r }
  deriving (Functor, Monad, MonadReader (Log a))

instance MonadLog (MemLog a) a where
    getEntry i = IntMap.lookup i `fmap` ask

runMemLog :: MemLog a r -> Log a -> r
runMemLog = runReader . unMemLog

-- Using `demo' while providing/using a `MemLog' doesn't type-check
foo :: (String, [Command Int])
foo = runMemLog (runTransitionT $ demo 1 321) (IntMap.empty :: Log Int)

main :: IO ()
main = print foo