MonadUI.hs

{-# OPTIONS -fglasgow-exts #-}

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

module Graphics.UI.Phooey.MonadUI
  (
  -- * The UI monad
   UI, runUI
  -- * High-level widgets
  , stringDisplay, showDisplay, textEntry, islider
  , checkBoxDisplay, checkBoxEntry, title
  -- * Tools for defining high-level widgets
  , mkWidget
  -- * Layout
  , onLayoutT, mapLayout
  ) where

-- import Monads hiding (set,get)
import Control.Monad.Reader
import Control.Monad.Trans
import Graphics.UI.WX hiding (textEntry)
import qualified Graphics.UI.WX as WX

import Graphics.UI.Phooey.Imperative
import Graphics.UI.Phooey.CallbackT
import Graphics.UI.Phooey.TagT (Unop,mkTag,mapTag)
import Graphics.UI.Phooey.LayoutT


{----------------------------------------------------------
    The UI monad
----------------------------------------------------------}

-- | The UI monad
type UI = CallBackT (ReaderT Win (LayoutT IO))

-- | Run a 'UI'.
runUI :: String -> UI () -> IO ()
runUI name = runL name . runReaderT . runCB (lift.lift)


{----------------------------------------------------------
    High-level widgets
----------------------------------------------------------}

mkText win = WX.textEntry win []

-- | String display widget
stringDisplay :: Source String -> UI (Source ())
stringDisplay src = mkWidget $ \ win ->
  do  ctl <- mkText win
      return  (  Just (hwidget ctl)
              ,  (skip, munch, src >>= set1 ctl text))

-- | Showable display widget
showDisplay :: Show a => Source a -> UI (Source ())
showDisplay src = stringDisplay (fmap show src)

-- | Simple text input widget
textEntry :: UI (Source String)
textEntry = mkWidget $ \ win ->
  do  ctl <- mkText win
      return  ( Just (hwidget ctl)
              ,  (get ctl text, onCommand ctl, skip))

-- | Slider widget with static initial value and dynamic bounds (min,max)
islider :: Int -> Source (Int,Int) -> UI (Source Int)
islider initial bounds = mkWidget $ \ win ->
  do  (ctl,snk) <- hsliderDyn win True [ selection := initial ]
      return  (  Just (hwidget ctl)
              ,  (getSel ctl, onCommand ctl, bounds>>=snk))

-- | String display widget
checkBoxDisplay :: Source Bool -> UI (Source ())
checkBoxDisplay src = mkWidget $ \ win ->
  do  ctl <- WX.checkBox win []
      return  (  Just (hwidget ctl)
              ,  (skip, munch, src >>= set1 ctl checked))

-- | Simple checkbox input widget
checkBoxEntry :: Bool -> UI (Source Bool)
checkBoxEntry initial = mkWidget $ \ win ->
  do  ctl <- WX.checkBox win [ checked := initial ]
      return  ( Just (hwidget ctl)
              ,  (get ctl checked, onCommand ctl, skip))

-- TODO: factor out commonalities between textEntry & checkBoxEntry and
-- between stringDisplay & checkBoxDisplay.


-- | Wrap a title around a 'UI'
title :: String -> Unop (UI a)
title str = mapLayout (boxed str)


{----------------------------------------------------------
    Tools for defining high-level widgets
----------------------------------------------------------}

-- | Make a widget
mkWidget :: (Win -> IO  (  Maybe Layout
                        ,  (a, Sink Updater, Updater)))
         -> UI a
mkWidget f = CB (mkRead (mkTag . f))

-- | Tweak the 'LayoutT'
onLayoutT :: LayoutTOp IO -> Unop (UI a)
onLayoutT f (CB reader) = CB (mkRead (f . runReaderT reader))

-- | Tweak the layout
mapLayout :: Unop Layout -> Unop (UI a)
mapLayout f = onLayoutT (mapTag f)


---- Misc unexported

mkRead :: Monad m => (r -> m a) -> ReaderT r m a
mkRead f = do  r <- ask
               lift (f r)