Render.hs

module Barrie.Render (RunnableGUI, RenderF,
                      updates, renderWidget,
                      renderText, renderBool, renderInt, renderDouble) where

import Data.Dynamic
import Data.List
import Data.Maybe

import Barrie.Gadgets
import Barrie.Style
import Barrie.Trace
import Barrie.Widgets

-- |RenderF is the type of rendering functions.  A rendering
-- function should be implmeneted for each backend.  Currently,
-- we have Gtk and IO.

type RenderF a b =  String            --  name of the gui element type
                 -> [RunnableGUI a b] --  children of this gui element
                 -> Style
                 -> Maybe (Gadget b)  --  corresponding implementation
                 -> Maybe Widget      --  possible popup
                 -> IO (RunnableGUI a b)

-- RunnableGUI is a type representing a rendered set of gadgets,
-- widgets, and styles.

-- A rendering function retuns a single RunnableGUI, which
-- represents the top level gui element.  Each of the inner
-- elements is also a RunnableGUI, and they are rendered in the
-- same way.  Anything that can be rendered can be used as a top
-- level element, either in the main application, or in a
-- pop-up.  Of course, this isn't enforced by this module, but
-- the RenderF functions should make sure it's true, because we
-- rely on it.

-- A RunnableGUI contains three fields.  First is the GUI, which
-- is of a type chosen by the renderer (e.g. Gtk uses
-- Gtk.Widget).  Second is an update from state function.  When
-- the state changes, this is called for each widget, causing it
-- to display according to the latest state.  Finally comes a
-- function which, give a function to extract state from IO
-- should call when the state is updated, which allows everything
-- else to be kept up to date.  The final field is a function
-- which, given a way of extracting the current state from IO,
-- and a way of putting it back, can update it via its gadget
-- functionality.

-- One will rightly point out that this is all very ugly and
-- procedural, but luckily, anybody using Barrie doesn't have to
-- worry about it.  It's the sewer of side-effects beneath the
--  cathedral of functional gui-ness.

type RunnableGUI gui state =
    (gui,                                    --  the GUI
     state -> IO (),                         --  update from state
     IO state -> (state -> IO ()) -> IO ())  --  state update function

-- The updates function extracts all the update functions from a
-- runnable gui.  This is convenient for the implementation of
-- renderers.

updates :: [RunnableGUI gui state] -> [state -> IO ()]
updates = map (\ (_, update, _) -> update)

-- A behaviour is just a flat list of gadgets.  Gadgets are defined
-- in a hierarchical way, but are flattened for rendering.

-- Note that the gadget hierarchy is only tangentially related to the
-- widget layout.  The hierarchy is intended to be a functional
-- grouping, although in practice it will often look similar to the
-- widget layout.

renderWidget :: [String]         -- ^ name prefix for gadgets
             -> Gadget w         -- ^ top gadget
             -> Widget           -- ^ rendered widget
             -> RenderF r w      -- ^ GUI rendering action
             -> IO (RunnableGUI r w)
renderWidget prefix behaviour widget render = go widget
    where go w = do let elmt = widgetElementName w
                        style = widgetStyle w
                        gadget = if (not . null . uiElementName) w
                                    then findGadget (uiElementName w)
                                                    behaviour
                                    else Nothing
                    traceMessage ("rendering element: " ++ elmt);
                    traceMessage ("ui name = " ++
                                 intercalate "." (uiElementName w))
                    traceMessage ("gadget = " ++
                                  maybe "Nothing" flatName gadget)
                    ws <- mapM go $ widgetChildren w
                    render elmt ws style gadget (widgetPopupChild w)

getRenderer :: String -> [(TypeRep, Dynamic -> a)] -> Dynamic -> a
getRenderer nm known d =
   case filter ((ty==) . fst) known of
      []        -> error $ "can't render as " ++ nm ++ ": " ++ show d
      ((_,f):_) -> f d
    where ty = dynTypeRep d

renderText :: Dynamic -> String
renderText = getRenderer "text" knownTextTypes
    where knownTextTypes =
              [(typeOf "", flip fromDyn "")
              ,(typeOf (0::Int), show . flip fromDyn (0::Int))
              ,(typeOf (0::Double), show . flip fromDyn (0::Double))
              ]

renderBool :: Dynamic -> Bool
renderBool = getRenderer "bool" knownBoolTypes
    where knownBoolTypes = [(typeOf False, flip fromDyn False)
                           ]

renderInt :: Dynamic -> Int
renderInt = getRenderer "int" knownIntTypes
    where knownIntTypes =
              [(typeOf (0::Int), flip fromDyn 0)
              ,(typeOf (0::Double), round . flip fromDyn (0::Double))
              ]

renderDouble :: Dynamic -> Double
renderDouble = getRenderer "double" knownDoubleTypes
    where knownDoubleTypes =
              [(typeOf (0::Double), flip fromDyn 0)
              ,(typeOf (0::Int), realToFrac . flip fromDyn (0::Int))
              ]