TagT.hs

{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-}

----------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.Phooey.TagT
-- Copyright   :  (c) Conal Elliott 2006
-- License     :  LGPL
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  provisional
-- Portability :  portable
-- 
-- A /tagging/ monad transformer
----------------------------------------------------------------------

module Graphics.UI.Phooey.TagT
  (
  -- * Convenient function synonyms
    Unop, Binop
  -- * The /tagging/ monad transformer (or tagged-value maker)
  , TagT(..), runTag
  -- * Transforming tagged-value makers
  , TagTOp, mapTag, mkTag
  -- * Tag-combiner tweakers
  , updateTagComb, setTagComb, flipTagComb
  ) where

-- import Control.Monad.Fix
import Control.Monad.Reader
import Control.Monad.Trans
import Control.Arrow (first)

{----------------------------------------------------------
    Convenient function synonyms
----------------------------------------------------------}

type Unop   a = a -> a
type Binop  a = a -> a -> a


{----------------------------------------------------------
    The /tagging/ monad transformer / tagged-value maker.
    Tags may be present or absent and are combined according to
    a contextual 'Binop'.
----------------------------------------------------------}

newtype TagT tag m a =
  T { unT :: ReaderT (Binop tag) m (Maybe tag,a) }

-- | Run a 'TagT'
runTag :: Binop tag       -- ^ the tag combiner
       -> TagT tag m a
       -> m (Maybe tag,a)
runTag op (T r) = runReaderT r op

instance Monad m => Monad (TagT tag m) where
  return a   = lift (return a)
  wta >>= f  = T (do  (ta,a)  <- unT wta
                      (tb,b)  <- unT (f a)
                      op      <- ask
                      return (mb op ta tb, b))
    where
      mb op (Just a)  (Just b)  = Just (a `op` b)
      mb _  mba       mbb       = mba `mplus` mbb

instance MonadFix m => MonadFix (TagT tag m) where
  mfix f = T (mfix (\ ~(_,a) ->  unT (f a)))


{----------------------------------------------------------
    Transforming tagged-value makers
----------------------------------------------------------}

-- | Transforming tagged-value makers into others
type TagTOp tag m = forall a. Unop (TagT tag m a)

-- | Tag changer
mapTag :: Monad m => Unop tag -> TagTOp tag m
mapTag f (T reader) = T (liftM (first (fmap f)) reader)

-- | Make a tagged-value maker from a tag and a value
mkTag :: Monad m => m (Maybe tag,a) -> TagT tag m a
mkTag m = T (lift m)

{----------------------------------------------------------
    Tag-combiner tweakers
----------------------------------------------------------}

-- | Temporarily /update/ the tag combiner
updateTagComb  ::  Monad m =>
                 Unop (Binop tag)
             ->  Unop (TagT tag m a)
updateTagComb h (T r) = T (local h r)

-- Augment the context for the duration of a computation.
-- Maybe rename and put back in MonadLib
-- updateR :: RunReaderM m i => (i->i) -> m a -> m a
-- updateR f m = do r <- ask
--                  local (f r) m


-- | Temporarily /replace/ the tag combiner
setTagComb  ::  Monad m => Binop tag ->  Unop (TagT tag m a)
setTagComb op = updateTagComb (const op)

-- | Temporarily /reverse/ the tag combiner
flipTagComb ::  Monad m => Unop (TagT tag m a)
flipTagComb = updateTagComb flip

instance MonadTrans (TagT tag) where
  lift m = T (lift (do  a <- m
                        return (Nothing,a)))

-- instance BaseM m b => BaseM (TagT tag m) b where
--   inBase m = lift (inBase m)

-- Add more transformer instances