Monad.hs

{-# OPTIONS -fglasgow-exts #-}

----------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.Phooey.Monad
-- Copyright   :  (c) Conal Elliott 2006
-- License     :  LGPL
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  provisional
-- Portability :  portable
-- 
-- A functional UI monad.  Uses explicit data-driven \"sources\" of
-- values.  Supports recursive GUIs.  See
-- <http://haskell.org/haskellwiki/Phooey#Monadic_Interface>.
----------------------------------------------------------------------

module Graphics.UI.Phooey.Monad
  (
  -- * The UI monad
   UI, Source, Upd, Snk, runUI, runNamedUI, runUI', runNamedUI'
  -- * Tools for high-level widgets
  , IWidget, OWidget, OWidget', IOWidget, MkWidget
  , iwidget, owidget, owidget', iowidget
  -- * Some high-level widgets
  , stringEntry, stringDisplay, stringDisplay'
  , showDisplay, showDisplay'
  , islider, isliderDyn, isliderDisplay, isliderDisplay'
  , checkBoxEntry, checkBoxDisplay, checkBoxDisplay'
  , title
  -- * Explicit layout
  , fromTop, fromBottom, fromLeft, fromRight, flipLayout
  -- * Misc tools
  , mkWidget
  , onLayoutT, mapLayout
  ) where

import Control.Applicative
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Arrow (first)

import Graphics.UI.WX hiding (textEntry)
import qualified Graphics.UI.WX as WX

import Control.Compose () -- for Monad (IO a) instance
import Control.DataDriven

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


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

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

-- | Sources of values (data-driven)
type Source = DataDriven IO

-- | IO-based updater
type Upd = Updater IO -- == IO ()

-- | IO-based sink
type Snk a = Sink IO a

-- | 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 . ((liftM runDD' . runWriterT) .) . runReaderT
 where
   runDD' :: (Source (), Upd) -> Upd
   runDD' (src, delayed) = runDD src >> delayed   -- or delayed first?

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

-- | Run a 'UI' with given window title -- alternative version.  Works
-- with \"alternative\"-style outputs.
runNamedUI' :: String -> UI (Source Upd) -> Upd
runNamedUI' name = runNamedUI name . liftM joinDD


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

-- | Input widget type (with initial value)
type IWidget  a =        a -> UI (Source a)
-- | Output widget type
type OWidget  a = Source a -> UI (Source ())
-- | Alternative output widget type
type OWidget' a = UI (Snk a)

-- | Combine input & output widget types
type IOWidget a = (IWidget a, OWidget a, OWidget' a)

-- | Type of widget-making functions
type MkWidget widget a b =
  Unop Layout -> (Win -> [Prop widget] -> IO widget) -> Attr widget a -> b

-- | Make a high-level input widget
iwidget :: (Commanding widget, Widget widget) => MkWidget widget a (IWidget a)
iwidget layf mkWid attr initial = mkWidget layf $ \ win ->
  do  wid   <- mkWid win [ attr := initial ]
      onCmd <- mkNews wid
      return (wid, (dd onCmd (get wid attr), mempty))

type IWidgetDyn a b = Source a -> IWidget b

type MkIWidgetDyn widget a b =
      Unop Layout
   -> (Win -> [Prop widget] -> IO (widget, Snk a))
   -> Attr widget b
   -> IWidgetDyn a b

-- | Slider widget with static initial value and dynamic bounds (min,max)
iwidgetDyn :: (Commanding widget, Widget widget) => MkIWidgetDyn widget a b
iwidgetDyn layf mkWid attr src initial = mkWidget layf $ \ win ->
  do  (wid,snkA) <- mkWid win [ attr := initial ]
      onCmd <- mkNews wid
      return  ( wid
              , ( dd onCmd (get wid attr)
                , runDD (mapSrc (>>= snkA) src) ) )

-- OWidget is convenient for a monad interface.  For building an
-- applicative functor, we'll want the the alternative OWidget' style.

-- | Make a high-level output widget
owidget :: Widget widget => MkWidget widget a (OWidget a)
owidget layf mkWid attr src =
  liftM (joinDD . (<$> src)) (owidget' layf mkWid attr)

-- | Make a high-level output widget
owidget' :: Widget widget => MkWidget widget a (OWidget' a)
owidget' layf mkWid attr = mkWidget layf $ \ win ->
  do  wid <- mkWid win [ ]
      return (wid, (\ a -> set wid [ attr := a ], mempty))

-- | Convenience function combining 'iwidget', 'owidget', and 'owidget\''
iowidget :: (Commanding widget, Widget widget) => MkWidget widget a (IOWidget a)
iowidget layf mkWid attr =
  (iwidget layf mkWid attr, owidget layf mkWid attr, owidget' layf mkWid attr)


{----------------------------------------------------------
    Some high-level widgets
----------------------------------------------------------}

-- | String input widget
stringEntry :: IWidget String

-- | String output widget
stringDisplay :: OWidget String

-- | Alternative string output widget
stringDisplay' :: OWidget' String

(stringEntry,stringDisplay,stringDisplay') = iowidget hfill WX.textEntry text

-- | Showable output widget
showDisplay :: Show a => OWidget a
showDisplay = stringDisplay . fmap show

-- | Alternative showable output
showDisplay' :: Show a => OWidget' a
showDisplay' = fmap (. show) stringDisplay'

-- | Slider input widget
islider :: (Int,Int) -> IWidget Int

-- | Slider output widget
isliderDisplay :: (Int,Int) -> OWidget Int

-- | Alternative slider output widget
isliderDisplay' :: (Int,Int) -> OWidget' Int

(islider,isliderDisplay,isliderDisplay') = unTriple1 $ \ (lo,hi) ->
  iowidget hfill (\ win -> hslider win True lo hi) selection

-- Helpers
-- unPair1 :: (a -> (b,c)) -> (a->b, a->c)
-- unPair1 f = (fst . f, snd . f)

unTriple1 :: (a -> (b,c,d)) -> (a->b, a->c, a->d)
unTriple1 f = (fst3 . f, snd3 . f, thd3 . f)
 where
   fst3 (a,_,_) = a
   snd3 (_,b,_) = b
   thd3 (_,_,c) = c


-- | Slider widget with static initial value and dynamic bounds (min,max)
isliderDyn :: Source (Int,Int) -> IWidget Int
isliderDyn = iwidgetDyn hfill (flip hsliderDyn True) selection

-- | Boolean input widget
checkBoxEntry :: IWidget Bool

-- | Boolean output widget
checkBoxDisplay :: OWidget Bool

-- | Alternative Boolean output widget
checkBoxDisplay' :: OWidget' Bool

(checkBoxEntry,checkBoxDisplay,checkBoxDisplay') = iowidget hfill WX.checkBox checked

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


{----------------------------------------------------------
    Layout
----------------------------------------------------------}

-- | Lay out from top to bottom
fromTop :: Unop (UI a)
fromTop = onLayoutT fromTopL

-- | Lay out from bottom to top
fromBottom :: Unop (UI a)
fromBottom = onLayoutT fromBottomL

-- | Lay out from left to right
fromLeft :: Unop (UI a)
fromLeft = onLayoutT fromLeftL

-- | Lay out from right to left
fromRight :: Unop (UI a)
fromRight = onLayoutT fromRightL

-- | Reverse layout
flipLayout :: Unop (UI a)
flipLayout = onLayoutT flipL


{----------------------------------------------------------
    Misc tools
----------------------------------------------------------}

-- | Make a widget
mkWidget :: forall a widget. Widget widget
         => Unop Layout   -- ^ filler: id, hfill, vfill, or fill
         -> (Win -> IO (widget, (a, Upd)))
         -> UI a
mkWidget layf f = ReaderT (WriterT . mkTag . panelWrap layf f')
 where
   f' :: Win -> IO (Maybe Layout, (a, Upd))
   f' w = liftM (first (Just . layf . widget)) (f w)


-- | Tweak the 'LayoutT'
onLayoutT :: LayoutTOp IO -> Unop (UI a)
onLayoutT f = mapReaderT' (mapWriterT' f)

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


-- Same defs as 'mapReaderT', 'mapWriterT', but different types

mapWriterT' :: UUnop m -> UUnop (WriterT w m)
mapWriterT' f m = WriterT $ f (runWriterT m)

mapReaderT' :: UUnop m -> UUnop (ReaderT w m)
mapReaderT' f m = ReaderT $ f . runReaderT m