{-# LANGUAGE Arrows #-}

-----------------------------------------------------------
-- 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 FRP.Yampa
import FRP.Yampa.Utilities
import Control.Arrow

import Data.IORef
import System.Time

import Control.Category
import Prelude hiding (id, (.))
import qualified Prelude (id, (.))
	
-----------------------------------------------------------
-- 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
                  | 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
  first = wxFirst

instance Category WXGUI where
  (.) = flip wxComp
  id  = arr Prelude.id

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
  first = wxFirstBox

instance Category WXBox where
  (.) = flip wxCompBox
  id  = arr Prelude.id 

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