SeerT monad transformer, written with Reader and Writer.

gistfile1.hs

{-# LANGUAGE GeneralizedNewtypeDeriving, DoRec #-}

module Control.Monad.Trans.Seer 
    ( SeerT
    , runSeerT  -- :: MonadFix m => SeerT w m a -> m (a, w)
    , evalSeerT -- :: MonadFix m => SeerT w m a -> m a
    , execSeerT -- :: MonadFix m => SeerT w m a -> m w

    , send      -- :: (Monoid w, Monad m) => w -> SeerT w m ()
    , see       -- :: (Monoid w, Monad m) => SeerT w m w

    , Seer
    , runSeer   -- :: Seer w a -> (a, w)
    , evalSeer  -- :: Seer w a -> a
    , execSeer  -- :: Seer w a -> w

    ) where

import Control.Applicative
import Control.Monad.Trans
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer
import Control.Monad.Identity
import Data.Maybe
import Data.Monoid

-- | Monad transformer for computations that can see a temporally
-- global state.  A @SeerT m@ action can @see@ the computation log and
-- @send@ values to it.  The special property here is that a
-- computation will @see@ the effects of both earlier and later
-- @send@s.
newtype SeerT w m a = SeerT (ReaderT w (WriterT w m) a)
    deriving ( Functor
             , Applicative
             , Alternative
             , Monad
             , MonadPlus
             , MonadIO
             , MonadFix
-- Never got around to doing these:
--             , MonadTrans
--             , MonadCont
--             , MonadError e
--             , MonadReader r
--             , MonadWriter w 
             )

runSeerT :: MonadFix m => SeerT w m a -> m (a, w)
runSeerT (SeerT ma) = do rec (a, w) <- runWriterT (runReaderT ma w)
                         return (a, w)

evalSeerT :: MonadFix m => SeerT w m a -> m a
evalSeerT = liftM fst . runSeerT

execSeerT :: MonadFix m => SeerT w m a -> m w
execSeerT = liftM snd . runSeerT

instance MonadTrans (SeerT w) where
    lift = lift

-- | Send a value to the computation's log.  Both earlier and later
-- @see@ actions see the effect of @send@.
send :: (Monoid w, Monad m) => w -> SeerT w m ()
send = SeerT . lift . tell

-- | Observe the computation's log.  This will reflect both earlier
-- and later @send@ actions.
see :: (Monoid w, Monad m) => SeerT w m w
see = SeerT ask


-- | Non-transformer vesion of @SeerT@.
type Seer w a = SeerT w Identity a

runSeer :: Seer w a -> (a, w)
runSeer = runIdentity . runSeerT

evalSeer :: Seer w a -> a
evalSeer = fst . runSeer

execSeer :: Seer w a -> w
execSeer = snd . runSeer


------------------------------------------------------------------
------------------------------------------------------------------
-- EXAMPLE 1
--

example1 :: Seer [String] [String]
example1 = do send ["foo"]
              send ["bar"]
              xs <- see     -- xs gets both the previous and later sends
              send ["baz"]
              send ["quux"]
              return xs
-- evalSeer example1 => ["foo","bar","baz","quux"]


------------------------------------------------------------------
------------------------------------------------------------------
-- EXAMPLE 2
--
-- A Program is a sequence of Statements.  A Statement is
-- either a Definition of an Identifier (a String), or an Use of an
-- identifier.
type Program a = [Statement a]
data Statement a = Definition Identifier a | Use Identifier
type Identifier = String

-- An example Program:
program1 = [ Use "y"
           , Use "x"
           , Definition "x" 5
           , Use "x"
           , Definition "y" 7 
           ]


elimDefinition :: Program a -> [a]
elimDefinition = catMaybes . evalSeer . mapM elimStep

elimStep :: Statement a -> Seer [(Identifier,a)] (Maybe a)
-- Each time we see a Definition, we send it to the Seer.
elimStep (Definition v x) = send [(v,x)] >> return Nothing
-- Each time we see a Use, we consult the Seer.
elimStep (Use v) = liftM (lookup v) see


example2 :: [Integer]
example2 = elimDefinition program1