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, runNamedUI
  -- * High-level widgets
  , stringDisplay, showDisplay, textEntry, islider
  , checkBoxDisplay, checkBoxEntry, title
  -- * Tools for defining high-level widgets
  , mkWidget
  -- * Layout
  , onLayoutT, mapLayout
  ) where

import Control.Applicative
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))

instance Functor UI where { fmap = (<$>) }
instance Applicative UI where { pure = return; (<*>) = ap }

-- | Run a 'UI' with window title \"Monadic Phooey GUI\".
runUI :: UI (Source ()) -> IO ()
runUI = runNamedUI "Monadic Phooey GUI"

-- | Run a 'UI' with given window title.
runNamedUI :: String -> UI (Source ()) -> IO ()
runNamedUI name = runL name . runReaderT . runCB (lift.lift)


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

-- | String display widget
stringDisplay :: Source String -> UI (Source ())
stringDisplay src = mkHWidget $ \ 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 = mkHWidget $ \ win ->
  do  ctl <- mkText win
      return  (  Just (hwidget ctl)
              ,  (get ctl text, onCommand ctl, skip))

mkText :: WX.Window a -> IO (WX.TextCtrl ())
mkText win = WX.textEntry win []


-- | Slider widget with static initial value and dynamic bounds (min,max)
islider :: Int -> Source (Int,Int) -> UI (Source Int)
islider initial bounds = mkHWidget $ \ 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 id $ \ 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 id $ \ 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 :: Unop Layout                 -- ^ id, hfill, vfill, or fill
         -> (Win -> IO  (  Maybe Layout
                        ,  (a, Sink Updater, Updater)))
         -> UI a
mkWidget layf f = CB (mkRead (mkTag . panWrap layf f))

-- | Make a widget with horizontal filling
mkHWidget :: (Win -> IO  (  Maybe Layout
                         ,  (a, Sink Updater, Updater)))
          -> UI a
mkHWidget = mkWidget hfill


-- Wrap another panel and layout unop (probably id, hfill, vfill, or fill)
-- to get desired stretchiness.
panWrap :: Unop Layout -> Unop (Win -> IO (Maybe Layout, b))
panWrap layf f w = do  pan     <- panel w []
                       (mbl,b) <- f pan
                       -- if we get a layout, use it for the panel.
                       maybe skip (set1 pan layout) mbl
                       return (Just (layf (widget pan)), b)

-- | 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)