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
  (
  -- * Widget & layout tools
    hwidget,lhwidget ,hsliderDyn, mkNews, commandNews
  -- * Simple abstraction around widget containers and frames
  , Win, Wio, runWio
  )
  where

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

import Data.IORef
import Control.Monad (join)
import Data.Monoid (mappend)
import Control.Instances () -- For Monoid (IO a) instance

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

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

-- -- | Set a single attribute
-- set1 :: w -> Attr w a -> a -> IO ()
-- set1 w attr val = set w [ attr := val ]

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

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


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

-- | Make a \"news\" publisher given a function that (destructively) assigns
-- a single action to be executed upon some event.  The publisher can
-- remember any number of actions (the "subscribers").
mkNews :: (IO () -> IO ()) -> IO (IO () -> IO ())
mkNews setNotify = 
  do  ref <- newIORef (return ())  -- contains subscribed actions
      setNotify (join (readIORef ref))
      return $ modifyIORef ref . mappend

-- | Make a \"news\" publisher for a widget's command.
commandNews :: Commanding wid => wid -> IO (IO () -> IO ())
commandNews wid = mkNews (\ act -> set wid [ on command := act ])

-- cmdNews wid = 
--     do -- putStrLn "mkNews"
--        ref <- newIORef (return ())  -- contains subscribed actions
--        set wid [ on command := join (readIORef ref) ]
--        return $ modifyIORef ref . mappend

-- TODO: perform action only when the value actually changes.  I get an
-- extra kick on grabbing a slider and two extra on releasing.  Is there a
-- way to eliminate them?


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