CallBackT.hs

{-# OPTIONS -fglasgow-exts #-}

----------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.Phooey.CallBackT
-- Copyright   :  (c) Conal Elliott 2006
-- License     :  LGPL
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  provisional
-- Portability :  portable
-- 
-- A monad transformer for managing callbacks.
-- 
-- In imperative GUI programs (wxHaskell. at least), the constructed
-- widgets are used in four ways: extracting the current value, setting
-- the callback invoked on user input, updating, and constructing a
-- layout.  'CallBackT' manages callbacks and updates.  /(Work on this
-- description.)/
----------------------------------------------------------------------

module Graphics.UI.Phooey.CallbackT
  (CallBackT(..), runCB)
  where


-- import Control.Monad
-- import Control.Monad.Fix
import Control.Monad.Reader
import Control.Monad.Trans

-- import Monads hiding (get)


import Graphics.UI.Phooey.Imperative

-- | The callback monad transformer.
newtype CallBackT m a =
  CB {unCB :: m (a, Sink Updater, Updater)}

instance Monad m => Monad (CallBackT m) where
  return a  = lift (return a)
  p >>= f   = CB (do  (a,ona,upda)  <- unCB p
                      (b,onb,updb)  <- unCB (f a)
                      return  (  b
                              ,  \ u -> ona (updb>>u) >> onb u
                              ,  upda>>updb))

instance MonadTrans CallBackT where
  lift m = CB (do  a <- m
                   return (a, munch, skip))

instance  {-""-}  MonadFix m
          =>      MonadFix (CallBackT m) where
  mfix f = CB (mdo  ~(a,snk,upd) <- unCB (f a)
                    return (a, snk.(>>upd), upd))

-- | /Run/ a callback-transformed-monad value
runCB :: Monad m =>
         (Updater -> m ())   -- ^ lifter
      -> CallBackT m a
      -> m a
runCB liftUpd (CB m) =  do  (a,on,upd) <- m
                            liftUpd (do  on upd
                                         upd)
                            return a