Imperative.hs

{-# OPTIONS #-}

----------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.Phooey.Imperative
-- Copyright   :  (c) Conal Elliott 2006
-- License     :  LGPL
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  provisional
-- Portability :  portable
-- 
-- Some imperative UI tools.
----------------------------------------------------------------------

module Graphics.UI.Phooey.Imperative
  (
  -- * Producers & consumers of values
    Source,Sink,Updater, skip, munch, set1
  -- * Widget & layout tools
  , getSel, onCommand, hwidget,lhwidget ,hsliderDyn
  -- * Wio
  , Win, Wio, runWio
  -- * Testing
  , runUI1
  )
  where

import Graphics.UI.WX
import Graphics.UI.WXCore (sliderGetMin,sliderGetMax,sliderSetRange)


{-----------------------------------------------------------------------
    Producers & consumers of values
------------------------------------------------------------------------}

type Source a  = IO a           -- ^ A producer (/source/) of values
type Sink   a  = a -> Updater   -- ^ A consumer (/sink/) of values
type Updater   = IO ()          -- ^ Something that /updates/ state

-- | The do-nothing 'Updater'
skip :: Updater
skip = return ()

-- | The do-nothing 'Sink'
munch :: Sink a
munch = const skip

set1 :: w -> Attr w a -> Sink a
set1 w attr val = set w [ attr := val ]


{-----------------------------------------------------------------------
    Widget & layout tools
-----------------------------------------------------------------------}

-- | Get the current 'selection' value of a widget
getSel :: Selection ctl => ctl -> IO Int
getSel ctl = get ctl selection

-- | Set the 'command' callback
onCommand :: Commanding ctl => ctl -> Updater -> IO ()
onCommand ctl upd = set ctl [ on command := upd ]

-- | Horizontally-filled widget layout
hwidget :: Widget w => w -> Layout
hwidget = hfill . widget

-- | Labeled, horizontally-filled widget layout
lhwidget :: Widget w => String -> w -> Layout
lhwidget str = boxed str . hwidget

{-  -- Unused

-- | Vertical layout
vertical :: [Layout] -> Layout
vertical  layouts = fill (column 0 layouts)

-- | Horizontal layout
horizontal :: [Layout] -> Layout
horizontal     layouts = fill (row 0 layouts)

-}

-- | Dynamically bounded slider.  The main complication is keeping the
-- slider value within the dynamic bounds.
hsliderDyn  ::  Window a -> Bool -> [Prop (Slider ())]
            ->  IO (Slider (), Sink (Int,Int))
hsliderDyn win showBounds props =
  do  -- The reason for +- 1000 in |makeISlider| is simply to reserve
      -- space.  There's a wxWidgets (I think) oddity that requires manual
      -- resizing otherwise.
      ctl <- hslider win showBounds (-1000) (1000) props
      return (ctl, setBounds ctl)
 where
   setBounds ctl (lo',hi') =
     do  sliderSetRange ctl lo' hi'
         val  <- getSel ctl
         when (val < lo')  (setVal ctl lo')
         when (val > hi')  (setVal ctl hi')
   setVal ctl x  =
     do  lo   <- sliderGetMin ctl
         hi   <- sliderGetMax ctl
         when (lo <= x && x <= hi)
           (set ctl [ selection := x ])

{-----------------------------------------------------------------------
    Wio -- simple abstraction around widget containers and frames
-----------------------------------------------------------------------}

type Win  = Panel ()            -- ^ Container of widgets
type Wio  = Win -> IO Layout    -- ^ Consumes container and yield layout

-- | "Run" a 'Wio': handle frame & widget creation, and apply layout.
runWio :: String -> Wio -> IO ()
runWio name wio = start $
  do  f        <- frame [visible := False, text := name]
      win      <- panel f []
      l        <- wio win
      set win  [ layout := l ]
      set f    [ layout := hwidget win, visible := True ]



----  Examples

runUI1  ::  IO ()
runUI1  = start $
  do  f        <- frame [ visible := False, text := "ui1" ]
      pan      <- panel f  []
      apples   <- hslider pan True 0 10 [ selection := 3 ]
      bananas  <- hslider pan True 0 10 [ selection := 7 ]
      total    <- textEntry pan [ ]
      let updTot = do  a  <- getSel apples
                       b  <- getSel bananas
                       set total [ text := show (a+b) ]
      onCommand apples   updTot
      onCommand bananas  updTot
      updTot
      set pan  [  layout :=
                   boxed "Shopping List" $
                   fill $ column 0
                     [  lhwidget "apples"   apples
                     ,  lhwidget "bananas"  bananas  {-""-}
                     ,  lhwidget "total"    total    ]  ]
      set f    [ layout := hwidget pan, visible := True ]