Monad.hs

{-# LANGUAGE TypeOperators, TypeSynonymInstances, FlexibleContexts
           , UndecidableInstances, ScopedTypeVariables #-}
-- For ghc 6.6 compatibility
-- {-# OPTIONS -fglasgow-exts #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}


----------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.Phooey.Monad
-- Copyright   :  (c) Conal Elliott 2006
-- License     :  BSD3
-- 
-- 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
   CxLayout, UI, UI', biUI, inUI, toUI, fromUI
  , UIE, UIS
  , runUI, runNamedUI, act
  -- , accumE, accumS, monoidE, monoidS
  -- * Tools for high-level widgets
  , IWidget, OWidget, OWidget', IOWidget, MkWidget, widgetL
  , iwidget, iwidget', owidget, owidget', iowidget, testWidget
  -- * Some high-level widgets
  , stringEntry, stringDisplay, stringDisplay'
  , showDisplay, showDisplay'
  , islider, isliderDisplay, isliderDisplay'
  , fslider, fsliderDisplay, fsliderDisplay'
  , checkBoxEntry, checkBoxDisplay, checkBoxDisplay'
  , button, button', smallButton
  , choices
  , timedPoll
  -- * Explicit layout
  , fromTop, fromBottom, fromLeft, fromRight
  ) where

import Control.Applicative
import Control.Arrow ((>>>),first,second)
import Data.Maybe (fromJust)
import Data.List (elemIndex)

-- mtl
import Control.Monad.Reader
import Control.Monad.Writer

-- wxHaskell
import Graphics.UI.WX hiding (Event,button,smallButton)
import qualified Graphics.UI.WX as WX
import qualified Graphics.UI.WXCore as WXC

-- TypeCompose
import Control.Compose (Unop,Binop)
import Data.CxMonoid
import Data.Bijection
import Data.Title

-- reactive
import Data.Reactive

-- Phooey
import Graphics.UI.Phooey.Imperative
  (Win,empty',above,below,leftOf,rightOf)
import Graphics.UI.Phooey.WinEvents (attrSource,getAttr,setAttr,wEvent_,WioS)

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

-- | Context-dependent layout
type CxLayout = CxMonoid Layout

instance Title Layout where title = boxed

-- | The UI monad
type UI = ReaderT Win (WriterT CxLayout (WriterT (Source Action) IO))

-- | Source-valued UI
type UIS a = UI (Source a)

-- | Event-valued UI
type UIE a = UI (Event  a)

-- Standard monad-as-applicative instance
instance Applicative UI where { pure = return ; (<*>) = ap }

-- Standard AF-as-monoid instance
instance Monoid o => Monoid (UI o) where
  mempty  = pure   mempty
  mappend = liftA2 mappend

-- | Convenient variation of 'UI'
type UI' a = Win -> IO ((a, CxLayout), Source Action)

-- Convenient bijection
biReaderT :: (r -> m a) :<->: ReaderT r m a 
biReaderT = Bi ReaderT runReaderT

biWriterT :: m (a, w) :<->: WriterT w m a 
biWriterT = Bi WriterT runWriterT

-- | Bijection for convenient manipulation.  
biUI :: UI' a :<->: UI a
biUI = bimap (biWriterT >>> biWriterT) >>> biReaderT

-- In biUI, the bimap is for the (->) Win, and each biWriterT un/wraps a WriterT.

-- Separate biUI into separately typed pieces.

-- TODO: look for alternatives.

-- | Make from representation
toUI :: UI' a -> UI a
toUI = biTo biUI

-- | Extract representation
fromUI :: UI b -> UI' b
fromUI = biFrom biUI

-- | Apply a unary function inside the 'UI' representation.
inUI :: (UI' a -> UI' b) -> (UI a -> UI b)
inUI = (toUI .) . (. fromUI)

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

-- | Run a 'UI' with given window title.
runNamedUI :: String -> UI () -> IO ()
runNamedUI name ui = start $
  do  f                <- frame [ visible := False, text := name ]
      win              <- panel f []
      (((),cxl),acts)  <- fromUI ui win
      set win  [ layout := unCxMonoid cxl (empty',above) ]
      set f    [ layout := fill (widget win), visible := True ]
      forkR acts

-- | Move an action source into position to be executed
act :: UI (Source Action) -> UI ()
act = inUI $ (fmap.fmap) doit
 where
   doit ((io, l), acts) = (((),l), acts `mappend` io)



{----------------------------------------------------------
    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 ()
-- | Alternative output widget type
type OWidget' a = UI (Sink a)

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

-- | Utility type for making widgets
type MkWidget ctl a b =
  Unop Layout -> (Win -> [Prop ctl] -> IO ctl) -> Attr ctl a -> b

widgetL :: Widget w => Unop Layout -> w -> CxLayout
widgetL filler ctl = CxMonoid (const (filler (widget ctl)))

-- | Make an input widget.  See alos 'iwidget\''.
iwidget :: (Commanding ctl, Widget ctl) => MkWidget ctl a (IWidget a)
iwidget = iwidget' command

-- | Make an input widget with a given update event.  If the update is
-- 'commanding' you can use 'iwidget'.
iwidget' :: Widget ctl => WX.Event ctl (IO ()) -> MkWidget ctl a (IWidget a)
iwidget' ev filler mkWid attr initial = toUI $ \ win ->
  do  ctl  <- mkWid win [ attr := initial ]
      src  <- attrSource ev attr ctl
      -- In the case of 'choices', the creation-time attribute set is not
      -- enough, so set it here again.
      set ctl [ attr := initial ]
      --   and invoke any event handlers
      join $ getAttr (on ev) ctl
      return ((src, widgetL filler ctl), mempty)

-- TODO: look in WinEvents for helpers.

-- | Tweaks output style
outFun :: OWidget' a -> OWidget a
outFun ui src =
  -- Apply sinks to values & move to actions
  act $ fmap (<$> src) ui

-- | Make a high-level output widget
owidget :: Widget widget => MkWidget widget a (OWidget a)
owidget filler mkWid attr = outFun (owidget' filler mkWid attr)

-- | Output widget, alternative style
owidget' :: Widget ctl => MkWidget ctl a (OWidget' a)
owidget' filler mkWid attr = toUI $ \ win ->
  do  ctl <- mkWid win [ ]
      return ((setAttr attr ctl, widgetL filler ctl), mempty)

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

-- | For testing out WinEvents
testWidget :: WioS a -> UI (Source a)
testWidget wios = toUI $ \ win ->
  do pan <- panel win [ size := Size 20 20 ]
     s   <- wios pan
     return ((s, widgetL fill pan), mempty)

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



-- | Fractional slider, alternative interface
fslider :: forall a. RealFrac a => (a,a) -> IWidget a
fslider (lo,hi) initial = toUI $ \ win ->
  do pan  <- panel win [ ]
     pbg  <- get pan bgcolor
     cval <- textEntry pan [ clientSize :~ \ (Size _ h) -> Size 50 h
                           , bgcolor := pbg
                           ]
     slid <- hslider pan False (toI lo) (toI hi)
             [ selection := toI initial
             , size :~ \ (Size _ h) -> (Size 80 h)]
     set pan [ layout := row 5 [ widget cval, label (show lo)
                               , fill $ widget slid, label (show hi) ] ]
     isrc <- attrSource command selection slid
     let fsrc = fmap toF isrc
     -- update the value display when it changes
     forkR $ (setText cval . show) <$> fsrc
     return ((fsrc, widgetL hfill pan), mempty)
 where
   toI x = round ((x - lo) * scale)
   toF i = fromIntegral i / scale + lo
   scale = steps / (hi - lo)
   steps = 3000 :: a


-- Set the text attribute, and make sure the beginning is visible
setText :: TextCtrl a -> String -> IO ()
setText ctl str =
  do setAttr text ctl str
     WXC.textCtrlSetInsertionPoint ctl 0

-- TODO: some factoring between fslider and fsliderDisplay'.

-- | Fractional slider
fsliderDisplay :: forall a. RealFrac a => (a,a) -> OWidget a
fsliderDisplay = outFun . fsliderDisplay'

-- | Fractional slider, alternative interface
fsliderDisplay' :: forall a. RealFrac a => (a,a) -> OWidget' a
fsliderDisplay' (lo,hi) = toUI $ \ win ->
  do pan  <- panel win [ ]
     pbg  <- get pan bgcolor
     cval <- textEntry pan [ clientSize :~ \ (Size _ h) -> Size 50 h
                           , bgcolor := pbg
                           , on keyboard := mempty -- ignore input
                           ]
     slid <- hslider pan False (toI lo) (toI hi) [ enabled := False ]
     set pan [ layout := row 5 [ widget cval, label (show lo)
                               , fill $ widget slid, label (show hi) ] ]
     let update x = do set slid [ selection := toI x ]
                       setText cval (show x)
     return ((update, widgetL hfill pan), mempty)
 where
   toI x = round ((x - lo) * scale)
   scale = steps / (hi - lo)
   steps = 3000 :: a

-- -- | Alternative output widget type
-- type OWidget' a = UI (Sink a)



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

-- | Input from a \"menu\" of string choices.
choices :: [String] -> IWidget String
choices strings dflt = iwidget' select hfill combo text' dflt
 where
   combo w props =
     do ctl <- comboBox w props
        mapM_ (appendText ctl) strings
        -- I don't know why the following line is required
        -- set ctl [ text' := dflt ]
        return ctl
   text' = newAttr "choiceSelection"
             (\ w -> fmap (strings !!) (getAttr selection w))
             (\ w str -> setAttr selection w (fromJust (elemIndex str strings)))


-- | Input from a timer and a means of polling.  Interval is in seconds.
-- If 'poll' is expensive, then apply 'cache' to the resulting UI.
timedPoll :: Double -> IO a -> UI (Source a)
timedPoll secs poll = toUI $ \ w ->
  do tim <- timer w [ interval := round (1000 * secs) ]
     (ev,snk) <- mkEvent
     set tim [ on command := poll >>= snk ]
     a0 <- poll
     return ((a0 `stepper` ev, mempty), mempty)

-- type UI' a = Win -> IO ((a, CxLayout), Source Action)



-- Wrap a title around a 'UI'
instance Title_f UI where title_f str = onCxLayout' (boxed str .)


-- | Simple button with value & label.  Use 'button\'' for custom properties.
button :: a -> String -> UI (Event a)
button a txt = button' a [ text := txt ]

-- | Button with value & properties.  If you just want a label, use 'button'.
button' :: a -> [Prop (Button ())] -> UI (Event a)
button' a props = toUI $ \ win ->
  do ctl   <- WX.button win props
     press <- wEvent_ command ctl
     return ( (replace a press, widgetL fill ctl)
            , mempty)

-- | Minimal size button with value & label
smallButton :: a -> String -> UI (Event a)
smallButton a txt = toUI $ \ win ->
  do ctl <- WX.smallButton win [ text := txt ]
     press <- wEvent_ command ctl
     return ( (replace a press, widgetL fill ctl)
            , mempty)

-- TODO: rewrite button', smallButton in >=> style.  See how it looks.



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

fromTop, fromBottom, fromLeft, fromRight :: Unop (UI a)
fromTop    = withDir above
fromBottom = withDir below
fromLeft   = withDir leftOf
fromRight  = withDir rightOf

withDir :: Binop Layout -> Unop (UI a)
withDir op = withCxMonoid (empty',op)

withCxMonoid :: MonoidDict Layout -> Unop (UI a)
withCxMonoid dict = compCxMonoid (const dict)

compCxMonoid :: Unop (MonoidDict Layout) -> Unop (UI a)
compCxMonoid f = onCxLayout' (. f)

onCxLayout :: Unop CxLayout -> Unop (UI a)
onCxLayout f = inUI $ (fmap.fmap.first.second) f

onCxLayout' :: Unop (MonoidDict Layout -> Layout) -> Unop (UI a)
onCxLayout' f' = onCxLayout (CxMonoid . f' . unCxMonoid)