wxFruit-0.1: WXFruit.hs

-----------------------------------------------------------
-- WXFruit: an implementation of Fruit using wxHaskell.
--   Version 0.1, May 2004
--   Contributors: Antony Courtney, Bart Robinson
-----------------------------------------------------------

module WXFruit where

-----------------------------------------------------------
-- Module imports.

import qualified Graphics.UI.WX as WX
import qualified Graphics.UI.WXCore as WXCore
import AFRP
import AFRPUtilities
import Control.Arrow

import Data.IORef
import System.Time


-----------------------------------------------------------
-- Data types for communication between widgets and the
-- system.  (These are likely to change dramatically.)

-- Raw input: kind of a hack...
data WXRawInput = WXRawInput {
     wxMousePos :: WX.Point -- relative to topmost frame
     -- add other raw inputs here: keyboard, mouse presses?
  }

-- Responses/Requests: This is rather clumsy, as any new
-- widgets would have to add their own alternatives to
-- these sums.  A way to do more dynamic run-time typing
-- could help with this problem.
data WXWidgetResp = WXWInit -- currently not used
                  | WXWButtonCreateResp (WX.Button ())
                  | WXWTextCreateResp (WX.StaticText ())
                  | WXWPictureCreateResp (WX.Panel ())
                  | WXWSliderCreateResp (WX.Slider ())
                  | WXWButtonCommandEvent -- button pressed
                  | WXWSliderCommandEvent Int -- new value selected
                  | WXWDeComp (Event WXWidgetResp,Event WXWidgetResp)

data WXWidgetReq = WXWButtonCreateReq WXButtonState
                 | WXWTextCreateReq WXTextState
                 | WXWPictureCreateReq WXPictureState
                 | WXWSliderCreateReq WXSliderState
                 | WXWButtonSetReq (WX.Button ()) WXButtonState
                 | WXWTextSetReq (WX.StaticText ()) WXTextState
                 | WXWPictureSetReq (WX.Panel ()) WXPictureState
                 | WXWSliderSetReq (WX.Slider ()) WXSliderState
                 | WXWComp Orientation (Event WXWidgetReq,Event WXWidgetReq)

data Orientation = Horiz | Vert
  deriving (Eq)


-----------------------------------------------------------
-- Widgets, GUIs, and Boxes.  The basic WXFruit building
-- blocks.

-- Widget: just a fancy signal function.
type Widget a b = SF (WXRawInput,Event WXWidgetResp,a) (Event WXWidgetReq,b)

-- WXGUI: conceptually the same as a Widget, but a newtype
-- is used so that it can be made into an Arrow.
newtype WXGUI b c = WXGUI (Widget b c)

-- WXGUI functions for Arrow instance.  This makes WXGUI
-- correspond to the GA type in the original Fruit.  I'm
-- not actually not sure this is necessary, because the
-- preferred idiom is to use WXBoxes, anyway.

-- Lifting/lowering

wxUnGUI :: WXGUI b c -> Widget b c
wxUnGUI (WXGUI w) = w

wxSF :: SF b c -> WXGUI b c
wxSF sf = WXGUI $ proc (_,_,b) -> do
  c <- sf -< b
  returnA -< (noEvent,c)

wxArr :: (b -> c) -> WXGUI b c
wxArr f = wxSF (arr f)

-- Composing: handles the "plumbing" involved in composing
-- widgets together -- makes sure the system input/output
-- streams are hooked up correctly.  The ugliness this
-- hides is basically the motivation for creating an Arrow
-- instance for WXGUI (and WXBox).

decompResp :: Event WXWidgetResp -> (Event WXWidgetResp,Event WXWidgetResp)
decompResp (Event WXWInit) = (Event WXWInit,Event WXWInit)
decompResp (Event (WXWDeComp (resp0,resp1))) = (resp0,resp1)
decompResp _ = (noEvent,noEvent)

compReq :: Orientation -> Event WXWidgetReq -> Event WXWidgetReq -> Event WXWidgetReq
compReq _ NoEvent NoEvent = noEvent
compReq orient req0 req1 = Event (WXWComp orient (req0,req1))

-- Composition generalized over orientations
wxGComp :: Orientation -> WXGUI b c -> WXGUI c d -> WXGUI b d
wxGComp orient (WXGUI w1) (WXGUI w2) = WXGUI $ proc (inp,resp,b) -> do
  let (resp1,resp2) = decompResp resp
  (req1,c) <- w1 -< (inp,resp1,b)
  (req2,d) <- w2 -< (inp,resp2,c)
  returnA -< (compReq orient req1 req2,d)

-- Default layout for composed widgets is horizontal.
wxComp :: WXGUI b c -> WXGUI c d -> WXGUI b d
wxComp = wxGComp Horiz

wxFirst :: WXGUI b c -> WXGUI (b,d) (c,d)
wxFirst (WXGUI w) = WXGUI $ proc (inp,resp,(b,d)) -> do
  (req,c) <- w -< (inp,resp,b)
  returnA -< (req,(c,d))

instance Arrow WXGUI where
  arr = wxArr
  (>>>) = wxComp
  first = wxFirst

wxLoop :: WXGUI (b,d) (c,d) -> WXGUI b c
wxLoop (WXGUI w) = WXGUI $ proc (inp,resp,b) -> do
  rec (req,(c,d)) <- w -< (inp,resp,(b,d))
  returnA -< (req,c)

instance ArrowLoop WXGUI where
  loop = wxLoop

-- WXBox: Builds upon WXGUI, adding the ability to defer
-- the specification of the orientation of a collection of
-- widgets.

newtype WXBox b c = WXBox (Orientation -> WXGUI b c)

-- Lift a GUI into a Box, keeping the GUI's internal
-- orientation(s)
wxBox :: WXGUI b c -> WXBox b c
wxBox w = WXBox (const w)

-- Compose Boxes by threading orientation to children.
wxCompBox :: WXBox b c -> WXBox c d -> WXBox b d
wxCompBox (WXBox b1f) (WXBox b2f) = WXBox $
  \orient -> wxGComp orient (b1f orient) (b2f orient)

wxFirstBox :: WXBox b c -> WXBox (b,d) (c,d)
wxFirstBox (WXBox bf) = WXBox $ \orient -> first (bf orient)

instance Arrow WXBox where
  arr = wxBox . arr
  (>>>) = wxCompBox
  first = wxFirstBox

wxLoopBox :: WXBox (b,d) (c,d) -> WXBox b c
wxLoopBox (WXBox bf) = WXBox $ \orient -> loop (bf orient)

instance ArrowLoop WXBox where
  loop = wxLoopBox

-- Some useful Box functions

wxBoxGUI :: Widget b c -> WXBox b c
wxBoxGUI = wxBox . WXGUI

wxBoxSF :: SF b c -> WXBox b c
wxBoxSF = wxBox . wxSF

-- These two are used to surround collections of Boxes and
-- make them go left-to-right or top-to-bottom.  They both
-- have the same effect when applied to a WXBox containing
-- just a single widget.

wxHBox :: WXBox b c -> WXGUI b c
wxHBox (WXBox bf) = bf Horiz

wxVBox :: WXBox b c -> WXGUI b c
wxVBox (WXBox bf) = bf Vert


-----------------------------------------------------------
-- Individual Widget definitions.  These are defined as
-- WXBoxes to allow easy composition.  They all employ a
-- similar pattern: they have a state-modifier function as
-- input, and use the same internal idioms to communicate
-- with the system.  See Button for extensive comments.
--   As more of these are added, it might be helpful to
-- move them into other modules/files.  (Which might be
-- tricky, as they are currently closed tied up with the
-- response/request data types.)

-- Utility to detect when a widget's state has changed
maybeChanged :: Eq a => a -> a -> Maybe ()
maybeChanged s s' = if s == s' then Nothing else Just ()


-----------------------------------------------------------
-- Button widget: has a string label, can be enabled and
-- disabled, and outputs an Event () when pressed

-- State

data WXButtonState = WXButtonState {
     bsLabel :: String,
     bsEnabled :: Bool
  } deriving (Eq, Show)

type WXButtonConf = WXButtonState -> WXButtonState

-- Constructors to initialize and alter state.  Note that
-- the state of a button should not (cannot?) be modified
-- other than through the use of these functions.

btext :: String -> WXButtonConf
btext l bs = bs {bsLabel = l}

benabled :: Bool -> WXButtonConf
benabled e bs = bs {bsEnabled = e}

-- The button GUI

wxbutton :: WXButtonConf -> WXBox WXButtonConf (Event ())
wxbutton conf0 =
  let -- Initial state
      defState = WXButtonState {bsLabel = "Default", bsEnabled = True}
      initState = conf0 defState
      
      -- Detect creation
      maybeCreate (WXWButtonCreateResp b) = Just (True,b)
      maybeCreate _ = Nothing
      
      -- Detect button press
      maybeCommand WXWButtonCommandEvent = Just ()
      maybeCommand _ = Nothing
  
  -- Make an ordinary, atomic signal function (in order to have access
  -- to the response/request mechanism), then lift it into a WXBox
  -- with wxBoxGUI.
  in wxBoxGUI $ proc (_,resp,conf) -> do
    -- Keep track of the state.
    rec state <- iPre initState -< conf state
    
    -- Has the state changed?  If so, generate set request.
    stateChanged <- edgeBy maybeChanged initState -< state
    
    -- Ensure that the system hands us back a WX.Button ().
    (isCreated,button) <- hold (False,undefined) -< mapFilterE maybeCreate resp
        
    -- Send a creation request if we haven't been created yet.
    -- WARNING: this is probably a bad way to do this.  It can
    -- create an infinitely-dense stream of Events, which is a
    -- big no-no in the AFRP world (at least, conceptually).
    -- We used to use WXWInit for this purpose, but with the
    -- dynamic switching of widgets, the system wouldn't know
    -- when to send the WXWInit events to widgets that have
    -- been switched-into.
    let doCreate = if isCreated then noEvent else Event ()
    
    -- Merge create/set requests.
    let req = lMerge (tag doCreate (WXWButtonCreateReq state))
                     (tag stateChanged (WXWButtonSetReq button state))
    
    -- Pass button presses through.
    let press = mapFilterE maybeCommand resp
    
    returnA -< (req,press)


-----------------------------------------------------------
-- Static text (label) widget: Displays a string, and has
-- no output.

-- State

data WXTextState = WXTextState {            
     tsLabel :: String
  } deriving (Eq, Show)

type WXTextConf = WXTextState -> WXTextState

-- Constructor

ttext :: String -> WXTextConf
ttext l ts = ts {tsLabel = l}

-- The text GUI

wxtext :: WXTextConf -> WXBox WXTextConf ()
wxtext conf0 = 
  let -- Initial state
      defState = WXTextState {tsLabel = "Default"}
      initState = conf0 defState
      
      -- Detect creation
      maybeCreate (WXWTextCreateResp t) = Just (True,t)
      maybeCreate _ = Nothing
  
  in wxBoxGUI $ proc (_,resp,conf) -> do
    -- State
    rec state <- iPre initState -< conf state
    stateChanged <- edgeBy maybeChanged initState -< state
    
    -- Creation
    (isCreated,text) <- hold (False,undefined) -< mapFilterE maybeCreate resp
    let doCreate = if isCreated then noEvent else Event ()
    
    -- Output
    let req = lMerge (tag doCreate (WXWTextCreateReq state))
                     (tag stateChanged (WXWTextSetReq text state))
    returnA -< (req,())


-----------------------------------------------------------
-- Slider widget: a slider that the user can move along a
-- bar between minimum and maximum values.  Can be oriented
-- horizontally or vertically (upon creation), and
-- enabled/disabled dynamically.  Outputs a continuous
-- signal indicating the currently-selected value.

-- State

data WXSliderState = WXSliderState {
     -- These properties are determined upon creation,
     -- and cannot be subsequently altered.
     ssMin :: Int,
     ssMax :: Int,
     ssOrientation :: Orientation,
     
     ssSelection :: Int, -- user- and programmer-modifiable
     ssEnabled :: Bool -- programmer-modifiable
  } deriving (Eq)

type WXSliderConf = WXSliderState -> WXSliderState

-- Constructors

senabled :: Bool -> WXSliderConf
senabled e ss = ss {ssEnabled = e}

sselection :: Int -> WXSliderConf
sselection sel ss = ss {ssSelection = sel}

-- The slider GUI

wxslider :: Orientation -> Int -> Int -> WXSliderConf -> WXBox WXSliderConf Int
wxslider orient min max conf0 =
  let -- Initial state
      defState = WXSliderState
        {ssMin = min, ssMax = max, ssOrientation = orient,
         ssSelection = 0, ssEnabled = True}
      initState = conf0 defState
      
      -- Change state when user moves slider
      changeSel state (Event (WXWSliderCommandEvent sel)) =
        state {ssSelection = sel}
      changeSel state _ = state
      
      -- Define our own maybeChanged, because we don't want to generate
      -- a WXWSliderSetReq if the only change in the state that occurred
      -- was via user input.
      maybeChangedInternal (_,state) (Event (WXWSliderCommandEvent _), state') =
        if (state {ssSelection = ssSelection state'}) == state'
          then Nothing
          else Just () 
      maybeChangedInternal (_,state) (_,state') =
        maybeChanged state state'
      
      -- Detect creation
      maybeCreate (WXWSliderCreateResp s) = Just (True,s)
      maybeCreate _ = Nothing
      
  in wxBoxGUI $ proc (_,resp,conf) -> do
    -- State
    rec let newState = changeSel (conf state) resp
        state <- iPre initState -< newState
    
    -- Detect actionable state changes
    stateChanged <- edgeBy maybeChangedInternal (noEvent,initState) -< (resp,state)
    
    -- Creation
    (isCreated,slider) <- hold (False,undefined) -< mapFilterE maybeCreate resp
    let doCreate = if isCreated then noEvent else Event ()
    
    -- Output
    let req = lMerge (tag doCreate (WXWSliderCreateReq state))
                     (tag stateChanged (WXWSliderSetReq slider state))
    returnA -< (req,ssSelection state)


-----------------------------------------------------------
-- Picture widget: a box for doing arbitrary graphics.
-- Uses a WX.Panel () with a custom repaint handler.

-- State

data WXPictureState = WXPictureState {
    psSize :: WX.Size,
    psPicture :: WXPicture
  }

type WXPictureConf = WXPictureState -> WXPictureState

-- Constructors

ppic :: WXPicture -> WXPictureConf
ppic pic ps = ps {psPicture = pic}

psize :: WX.Size -> WXPictureConf
psize size ps = ps {psSize = size}

-- The picture GUI

wxpicture :: WXPictureConf -> WXBox WXPictureConf ()
wxpicture conf0 =
  let -- Initial state
      defState = WXPictureState {psSize = WX.sizeNull, psPicture = wxblank}
      initState = conf0 defState
      
      -- Detect creation
      maybeCreate (WXWPictureCreateResp panel) = Just (True,panel)
      maybeCreate _ = Nothing
      
  in wxBoxGUI $ proc (_,resp,conf) -> do
    -- State
    rec state <- iPre initState -< conf state
    
    -- Creation
    (isCreated,panel) <- hold (False,undefined) -< mapFilterE maybeCreate resp
    let doCreate = if isCreated then noEvent else Event ()
    
    -- Output.  Note that here we are again violating the
    -- rules of AFRP by sending an infinitely-dense stream
    -- of events, because we want a new picture at every
    -- sample time so that animation will work.
    let req = lMerge (tag doCreate (WXWPictureCreateReq state))
                     (Event (WXWPictureSetReq panel state))
    returnA -< (req,())


-----------------------------------------------------------
-- Mouse widget: this is problematic.  It just outputs the
-- current mouse position, relative to the client space of
-- the topmost frame.  There is currently no way to
-- translate this into coordinates relative to a particular
-- widget.

wxmouse :: WXBox () WX.Point
wxmouse = wxBoxGUI $ proc (inp,_,_) -> do
  returnA -< (noEvent,wxMousePos inp)


-----------------------------------------------------------
-- The WXFruit graphics library!  (Just wrappers for
-- wxHaskell functions, basically, adapting them to the
-- SOE/Haven graphics idiom.)  Just enough is implemented
-- here to get paddleball working.

-- Picture type: This corresponds to a wxHaskell repaint handler.
type WXPicture = [WX.Prop (WX.DC ())] -> WX.DC () -> WX.Rect -> IO ()

-- Draw nothing.
wxblank :: WXPicture
wxblank _ _ _ = return () 

-- Fill the picture with a single color.
wxfill :: WXPicture
wxfill props dc rect = wxPicFill (wxrect rect) props dc rect

-- Draw an ellipse bounded by a rectangle.
wxellipse :: WX.Rect -> WXPicture
wxellipse rect props dc _ = WX.ellipse dc rect props

-- Draw a rectangle.
wxrect :: WX.Rect -> WXPicture
wxrect rect props dc _ = WX.drawRect dc rect props

-- Write graphical text.  Don't confuse this with wxtext;
-- it's an entirely different animal.
wxwrite :: String -> WX.Point -> WXPicture
wxwrite str pt props dc _ = WX.drawText dc str pt props

-- Make drawings use a particular color.
wxWithColor :: WX.Color -> WXPicture -> WXPicture
wxWithColor color pic props =
  pic (props ++ [WX.color WX.:= color, WX.brushColor WX.:= color])

-- Make rectangles and ellipses be filled in.
wxPicFill :: WXPicture -> WXPicture
wxPicFill pic props =
  pic (props ++ [WX.brushKind WX.:= WX.BrushSolid])

-- Combine two drawings.
wxPicOver :: WXPicture -> WXPicture -> WXPicture
wxPicOver pic1 pic2 props dc rect = do
  pic2 props dc rect
  pic1 props dc rect


-----------------------------------------------------------
-- Data types and functions for composition of widgets.
-- This is where the connection is made between the tree-
-- structure of WXGUIs and WXBoxes and the actual layout
-- of widgets sent to wxHaskell.  This is all rather
-- clumsy.

-- Contents widget tree: wxFruit version of WX.Layout.
data WXContents = WXCEmpty
                | WXCLeaf WXWidget
                | WXCComp Orientation WXContents WXContents

data WXWidget = WXButton (WX.Button ())
              | WXText (WX.StaticText ())
              | WXPicture (WX.Panel ())
              | WXSlider (WX.Slider ())

-- Compositional path to a widget.  A True entry means
-- go down the left/top branch of a WXContents tree; False
-- means go down the right/bottom.
type WXPath = [Bool]

-- Convert contents into layout.  The tricky part is
-- making sure that nested WXCComps with the same
-- orientation are merged into a single list (see
-- c2lList).
contents2layout :: WXContents -> WX.Layout
contents2layout WXCEmpty = WX.empty
contents2layout (WXCLeaf (WXButton b)) = WX.widget b
contents2layout (WXCLeaf (WXText t)) = WX.widget t
contents2layout (WXCLeaf (WXPicture p)) = WX.widget p
contents2layout (WXCLeaf (WXSlider s)) = WX.widget s
contents2layout comp@(WXCComp orient c1 c2) =
  (if orient == Horiz then WX.row else WX.column) 5 (c2lList orient comp)

-- Merge similarly-orientated WXCComps together.
c2lList :: Orientation -> WXContents -> [WX.Layout]
c2lList orient comp@(WXCComp orient' c1 c2) =
  if orient == orient'
    then (c2lList orient c1) ++ (c2lList orient c2)
    else [contents2layout comp]
c2lList _ WXCEmpty = []
c2lList _ c = [contents2layout c]

-- Destroy the windows in a contents tree.  This shouldn't
-- really be necessary, except wxHaskell doesn't currently
-- handle window destruction properly (IMO) -- simply
-- resetting the layout doesn't get rid of any windows
-- in the old layout.  This is really only needed if/when
-- widget-switching is implemented.
removeContents :: WX.Frame () -> WXContents -> IO Bool
removeContents f WXCEmpty = return True
removeContents f (WXCLeaf (WXButton b)) = WXCore.windowDestroy b
removeContents f (WXCLeaf (WXText t)) = WXCore.windowDestroy t
removeContents f (WXCLeaf (WXSlider s)) = WXCore.windowDestroy s
removeContents f (WXCLeaf (WXPicture p)) = WXCore.windowDestroy p
removeContents f (WXCComp _ c0 c1) =
  do removeContents f c0
     removeContents f c1


-----------------------------------------------------------
-- The guts of the WXFruit system.  This is where the
-- connection between wxHaskell and Yampa is made.

-- State maintained across calls to react: the frame
-- window, the time of the last sample, and the contents
-- of the window (i.e. the entire widget tree).
type WXGUIState = (WX.Frame (),Int,WXContents)
type WXGUIRef = IORef WXGUIState

type WXRHandle = ReactHandle (WXRawInput,Event WXWidgetResp,()) (Event WXWidgetReq,())

-- Start a WXGUI running in a top-level frame.
startGUI :: String -> WXGUI () () -> IO ()
startGUI title (WXGUI g) = WX.start $ do
  -- Set up frame window and internal state.
  f <- WX.frame [WX.text WX.:= title]
  epoch <- getCurrentTime  
  gsr <- newIORef (f,epoch,WXCEmpty)
  
  -- Initialize Yampa.
  rh <- reactInit (initSense f) (actuate gsr) g
  
  -- Set up heartbeat timer to make periodic calls to react.
  -- This is necessary for animation.  Note that this is
  -- not the only place react is called from: button
  -- presses and other user actions may generate calls of
  -- their own.
  timer <- WX.timer f [WX.interval WX.:= 30, WX.on WX.command WX.:= respond gsr rh noEvent]
  
  return ()

-- Get an input sample from the OS.
getRawInput :: WX.Frame () -> IO WXRawInput
getRawInput f = do
  mouse <- WXCore.windowGetMousePosition f
  return WXRawInput {wxMousePos = mouse}

-- The very first input sample.
initSense :: WX.Frame () -> IO (WXRawInput,Event WXWidgetResp,())
initSense f = do
  inp <- getRawInput f
  return (inp,Event WXWInit,())

-- Push an input sample/widget response.
respond :: WXGUIRef -> WXRHandle -> Event WXWidgetResp -> IO ()
respond gsr rh resp = do
  -- Obtain input sample.
  (f,prevt,c) <- readIORef gsr
  inp <- getRawInput f
  
  -- Make sure time's elapsed since the last call to react.
  -- With the timer set up in startGUI, this is probably
  -- unnecessary, but we'll leave it in to be safe.
  et <- getCurrentTime
  (dtf,t) <- ensureTimeElapses prevt et getCurrentTime
  writeIORef gsr (f,t,c)
  
  -- Let Yampa work its magic.
  react rh (dtf,Just (inp,resp,()))
  return ()

-- Process an output sample (i.e. a widget request).
actuate :: WXGUIRef -> WXRHandle -> Bool -> (Event WXWidgetReq,()) -> IO Bool
actuate gsr rh _ (wre,_) = 
  do -- Handle requests, if any.
     (f,t,prevc) <- readIORef gsr
     (resp,c,cch) <- handleWidgetReq gsr rh f [] prevc wre
     
     -- Reset layout if contents changed.
     if cch
       then do WX.set f [WX.layout WX.:= WX.margin 5 (contents2layout c)]
               WX.windowReLayoutMinimal f
       else return ()
     writeIORef gsr (f,t,c)
     
     -- Turn around and respond to the widgets, if necessary.
     -- Note that this causes a reentrant call to react.
     case resp of
       NoEvent -> return ()
       _ -> respond gsr rh resp
     
     return False

-- Handle a single widget request by making the appropriate
-- calls into wxHaskell.  Returns a response to the
-- request (if any), the new contents of the window, and
-- a boolean indicating whether the contents have changed.
handleWidgetReq :: WXGUIRef -> WXRHandle -> WX.Frame ()
                   -> WXPath -> WXContents -> (Event WXWidgetReq)
                   -> IO (Event WXWidgetResp,WXContents,Bool)

-- Do nothing if no request.
handleWidgetReq _ _ _ _ c NoEvent = return (noEvent,c,False)

-- Handle creation by calling the wxHaskell constructor with
-- properties corresponding to the given initial state,
-- removing any old contents, and returning the new widget.
handleWidgetReq gsr rh f path c (Event (WXWButtonCreateReq bstate)) =
  do let bprops = mkButtonProps gsr rh path bstate
     b <- WX.smallButton f bprops
     removeContents f c
     return (Event (WXWButtonCreateResp b),WXCLeaf (WXButton b),True)
handleWidgetReq _ _ f path c (Event (WXWTextCreateReq tstate)) =
  do let tprops = mkTextProps tstate
     t <- WX.staticText f tprops
     removeContents f c
     return (Event (WXWTextCreateResp t),WXCLeaf (WXText t),True)
handleWidgetReq _ _ f path c (Event (WXWPictureCreateReq pstate)) =
  do let pprops = mkPictureProps pstate
     p <- WX.panel f pprops
     removeContents f c
     return (Event (WXWPictureCreateResp p),WXCLeaf (WXPicture p),True)
handleWidgetReq gsr rh f path c (Event (WXWSliderCreateReq sstate)) =
  do -- Here we create the slider before setting up its properties
     -- because the event handler in the properties needs a pointer
     -- to the slider.
     s <- (if ssOrientation sstate == Horiz then WX.hslider else WX.vslider)
            f False (ssMin sstate) (ssMax sstate) []
     let sprops = mkSliderProps gsr rh path s sstate
     WX.set s sprops
     removeContents f c
     return (Event (WXWSliderCreateResp s),WXCLeaf (WXSlider s),True)

-- Handle creation requests by resetting the properties
-- of the widget.
handleWidgetReq gsr rh f path c (Event (WXWButtonSetReq b bstate)) =
  do let bprops = mkButtonProps gsr rh path bstate
     WX.set b bprops
     return (noEvent,c,False)
handleWidgetReq _ _ f path c (Event (WXWTextSetReq t tstate)) =
  do let tprops = mkTextProps tstate
     WX.set t tprops
     return (noEvent,c,False)
handleWidgetReq _ _ f path c (Event (WXWPictureSetReq p pstate)) =
  do let pprops = mkPictureProps pstate
     WX.set p pprops
     WX.repaint p -- paint the new picture
     return (noEvent,c,False)
handleWidgetReq gsr rh f path c (Event (WXWSliderSetReq s sstate)) =
  do -- Note that if properties other than the selection and
     -- enable are modified, this will not change them.
     let sprops = mkSliderProps gsr rh path s sstate
     WX.set s sprops
     return (noEvent,c,False)

-- Pass requests down the widget tree.
handleWidgetReq gsr rh f path c (Event (WXWComp orient (lreq,rreq))) =
  do (lresp,lc',lcch) <- handleWidgetReq gsr rh f (True:path) (subCont True c) lreq
     (rresp,rc',rcch) <- handleWidgetReq gsr rh f (False:path) (subCont False c) rreq
     -- If both children returned no response, don't compose
     -- them together.
     return (case (lresp,rresp) of
               (NoEvent,NoEvent) -> noEvent
               resp -> Event (WXWDeComp resp),
             WXCComp orient lc' rc',lcch || rcch)
  where subCont which (WXCComp _ l r) =
          if which then l else r
        subCont _ _ = WXCEmpty -- contents tree has not been set up yet

-- Construct button properties list
mkButtonProps :: WXGUIRef -> WXRHandle -> WXPath -> WXButtonState
                 -> [WX.Prop (WX.Button ())]
mkButtonProps gsr rh path bs =
  [WX.text WX.:= bsLabel bs, WX.enabled WX.:= bsEnabled bs,
   WX.on WX.command WX.:= mkButtonCommand gsr rh path]

-- Button-press event handler.  Causes a call to react.
mkButtonCommand :: WXGUIRef -> WXRHandle -> WXPath -> IO ()
mkButtonCommand gsr rh path =
  do let e = pathify (Event WXWButtonCommandEvent) path
     respond gsr rh e

-- Contruct text label properties list.
mkTextProps :: WXTextState -> [WX.Prop (WX.StaticText ())]
mkTextProps ts =
  [WX.text WX.:= tsLabel ts]

-- Construct slider properties list.
mkSliderProps :: WXGUIRef -> WXRHandle -> WXPath
                 -> WX.Slider () -> WXSliderState -> [WX.Prop (WX.Slider ())]
mkSliderProps gsr rh path s ss =
  [WX.enabled WX.:= ssEnabled ss, WX.selection WX.:= ssSelection ss,
   WX.on WX.command WX.:= mkSliderCommand gsr rh path s]

-- Event handler called when slider is moved by user.
-- Causes a call to react.
mkSliderCommand :: WXGUIRef -> WXRHandle -> WXPath -> WX.Slider () -> IO ()
mkSliderCommand gsr rh path s =
  do sel <- WX.get s WX.selection
     let e = pathify (Event (WXWSliderCommandEvent sel)) path
     respond gsr rh e

-- Construct picture widget properties list.
mkPictureProps :: WXPictureState -> [WX.Prop (WX.Panel ())]
mkPictureProps ps =
  [WX.clientSize WX.:= psSize ps, WX.on WX.paint WX.:= psPicture ps []]

-- Construct a WXWidgetResp corresponding to a given
-- path.  This response will then be directed to the
-- correct widget (e.g. a button-pressed event will be sent
-- through the widget tree to the appropriate wxbutton).
pathify :: Event WXWidgetResp -> WXPath -> Event WXWidgetResp
pathify e [] = e
pathify e (True:path) = pathify (Event (WXWDeComp (e,noEvent))) path
pathify e (False:path) = pathify (Event (WXWDeComp (noEvent,e))) path


-----------------------------------------------------------
-- Utility functions copied from Yampa.

getCurrentTime :: IO Int
getCurrentTime =
  do (TOD sec psec) <- getClockTime
     let usec = fromIntegral psec / 1000000
     let msec = (fromIntegral ((sec - ctEpoch) * 1000)) + (usec / 1000)
     -- let dmsec = (fromIntegral $ msec) :: Double
     let imsec = round msec
     -- putStrLn ("getCurrentTime(): sec == " ++ show sec ++ ", usec == " ++
     --           show usec)
     -- putStrLn ("getCurrentTime() returning: " ++ (show imsec))
     return imsec
  where
    -- an arbitrary epoch, in seconds, to prevent Int wraparound:
    ctEpoch :: Integer
    ctEpoch = 1037286000


-- ensure an observable amount of time elapses by busy-waiting.
--
-- arguments:
--   t0 :: Int -- time of last sample
--   t1 :: Int -- current time, in milliseconds
--   getTime :: IO Int -- returns the current time, in milliseconds
-- result: (dtf,t1)
--   dtf -- the elapsed time since last sample, in seconds, as a Float
--   t1 -- the current time, in millisec.
--
-- We perform the floating point conversion, and perform our comparison
-- with respect to that conversion here to ensure that we are using
-- the same test as used by reactimate.
--
ensureTimeElapses :: Int -> Int -> IO Int -> IO (Double,Int)
ensureTimeElapses t0 t1 getTime = do
  let dt = t1 - t0
      dtf = (fromIntegral dt) / 1000
  if (dtf > 0) then return (dtf,t1)
               else do t' <- getTime
                       ensureTimeElapses t0 t' getTime