This is Barrie's Gtk2hs rendering engine

    See module Barrie.Render for a discussion of the RunnableGUI type,
    which renderers return.

> module Barrie.Render.Gtk (gtkMain, initGtk, renderGtk, runGtk) where

> import qualified Graphics.UI.Gtk as Gtk
> import System.Glib.Attributes

> import Control.Monad

       IORefs are Barrie's dirty little secret.  There are three: one
       is for saving a global state that the GUI works with, the other
       two save the contents of lists and choosers, so that we don't
       update them more than necessary.

> import Data.IORef


       We import approximately everything

> import Barrie.Config
> import Barrie.Render
> import Barrie.Style
> import Barrie.Gadgets
> --  import Barrie.GadgetValue
> --  import Barrie.GadgetValueType
> import Barrie.Trace
> import Barrie.Widgets

 
       The rendering model is defined by the RenderF type in the
       Barrie.Render module.  Implementations of the renderer provide
       a type which describes the GUI.  In this case, it's just a
       Gtk.Widget.

> type GtkGUI = Gtk.Widget

       All rendering functions in this module use the following type
       GtkRenderFn.
 
       It is a function from:
           -  a list of child guis (i.e. widgets inside the one being rendered)
           -  a style
           -  an optional gadget, which will be connected to the
              rendered widget if present.
       It returns a runnable GUI.

> type GtkRenderFn a = [RunnableGUI GtkGUI a]
>                    -> Style
>                    -> Maybe (Gadget a)
>                    -> IO (RunnableGUI GtkGUI a)


 gtkMain is a convenience function for launching a gadget/widget pair,
 with a given state.  It should only be called once, at the top level,
 since it initialises Gtk (although I think multiple calls are
 harmless).

> gtkMain :: Gadget a -> Widget -> a -> IO a
> gtkMain gadget widget state = do
>   initGtk
>   gui <- renderWidget (gadgets gadget) widget renderGtk
>   runGtk gui state False


> initGtk :: IO ()
> initGtk = do Gtk.initGUI
>              return ()

> renderGtk :: RenderF GtkGUI a
> renderGtk nm gs style gadget popupChild = do
>   let rendererList = case popupChild of
>                         Nothing -> renderers
>                         Just w  -> map (\ (x,y) -> (x, y w)) popupRenderers
>   case lookup nm rendererList of
>     Nothing -> error $ "rendering element '" ++ nm ++ "' not found"
>     Just r  -> do traceMessage ("rendering: " ++ nm)
>                   r gs style gadget

> runGtk :: RunnableGUI GtkGUI a -> a -> Bool -> IO a
> runGtk (top, start, connect) state modal = do
>   stateref <- newIORef state
>   let update st = do writeIORef stateref st
>                      start st
>       getState = readIORef stateref
>   connect getState update
>   startGtk top start state modal
>   getState

> startGtk ::  Gtk.Widget -> (a -> IO ()) -> a -> Bool -> IO ()
> startGtk top start state modal = do
>   Gtk.initGUI
>   window <- Gtk.windowNew
>   Gtk.windowSetModal window modal
>   Gtk.onDestroy window Gtk.mainQuit
>   set window [ Gtk.containerChild := top ]
>   Gtk.widgetShowAll window
>   start state
>   Gtk.mainGUI

 -----------------------------
 Renderers and popup renderers
 -----------------------------

 Two kinds of renderers are used.  The normal one puts widgets inside
 other widgets in the normal way.  The popup renderer instead puts
 widgets into a modal popup.  The choice of which to used is made
 based on the popupChild argument to renderGtk, which is taken from
 the widget corresponding to the gadget.

 I find this a bit dodgy, since one could come up with all sorts of
 information that might be useful for a widget to pass to a gadget,
 but we certainly don't want to add an argument for each.  If I come
 up with a bunch, I'll change the type from Maybe Widget to a record
 of properties.

> renderers :: [(String, GtkRenderFn a)]
> renderers = [("button", renderButton),
>              ("label", renderLabel),
>              ("textbox", renderTextBox),
>              ("droplist", renderChooser),
>              ("list", renderSingleColumnList),
>              ("vbox", renderBox Gtk.vBoxNew),
>              ("hbox", renderBox Gtk.hBoxNew)]

    Currently, we only do popup buttons, but it should be easily
    generalisable.

> popupRenderers :: [(String, Widget -> GtkRenderFn a)]
> popupRenderers = [("button", renderPopupButton)]

    Tables will come back when I work out a nice way to make them
    dynamic.  Yes, boxes should be dynamic too, but there's something
    about tables which just seems to demand it.

    Barrie, of course, is not terribly at ease with dynamic gadgets
    and widgets.

> {-
> renderTable :: GtkRenderFn a
> renderTable ss children widgets = do
>   case tableShape children of
>     (1, 1) -> head children
>     (1, _) -> renderBox Gtk.hBoxNew ss (head children) widgets
>     (_, 1) -> renderBox Gtk.vBoxNew ss (map head children) widgets
>     (n, m) -> do table <- Gtk.tableNew n m False
>                  return $ (table,
>                            startTable table n m ss children widgets,
>                            updateContainer (Gtk.castToWidget table)
>                                             ss (concat children) widgets)
> -}

> -- |The renderBox function renders horizontal and vertical layout boxes.

> -- |Note the return type: it's a RunnableGUI from module Barrie.Render.

> renderBox :: (Gtk.BoxClass b) =>
>              (Bool -> Int -> IO b)
>           -> GtkRenderFn a
> renderBox new gs style gadget = do
>   box <- new (getHomogenous style) 1
>   startBox box gs gadget
>   let result = Gtk.castToWidget box
>   let connectBox getS update =
>           mapM_ (\ (_, _, connect) -> connect getS update) gs
>   return $ (result,
>             configureWidget box style gadget $ onUpdate result (updates gs),
>             connectBox)

> startBox :: (Gtk.BoxClass b) =>
>             b
>          -> [RunnableGUI GtkGUI a]
>          -> Maybe (Gadget a)
>          -> IO ()
> startBox box gs _ = do
>   mapM_ (\ (w, _, _) -> Gtk.boxPackStartDefaults box w) gs

> onUpdate :: Gtk.Widget -> [a -> IO ()] -> a -> IO ()
> onUpdate _ childUpdates state =
>     mapM_ ($ state) childUpdates

> applyStyle :: (a -> IO ()) -> Maybe a -> IO ()
> applyStyle _ Nothing = return ()
> applyStyle applier (Just style) = applier style

> {-
> tableShape :: [[a]] -> (Int, Int)
> tableShape cells = (length cells, length (head cells))

> startTable :: Gtk.Table
>            -> StyleSheet -> [RunnableGUI GtkGUI a] -> [TreeWidget a]
>            -> a -> IO ()
> startTable table ss children widgets state = do
>   let attachCell row col widget =
>           Gtk.tableAttachDefaults table widget
>                                   col (col + 1)
>                                   row (row + 1)
>       attachRow row cells = mapM_ attach (zip [0 ..] cells)
>           where attach (col, (w, _, _)) = attachCell row col w
>       attachRows = mapM_ attach (zip [0 ..] children)
>           where attach (row, ws) = attachRow row (map (\ (w,_,_) -> w) ws)
>   attachRows
> -}

> renderButton :: GtkRenderFn a
> renderButton _ style gadget = do
>   btn <- Gtk.buttonNew
>   applyStyle (Gtk.buttonSetLabel btn) (getCaption style)
>   let onClicked = \ handler -> Gtk.onClicked btn handler >> return ()
>       clickUpdate = \ gets -> connectCommandGadget onClicked gets gadget
>   return (Gtk.castToWidget btn,
>           configureButton btn style gadget (const (return ())),
>           clickUpdate)

> renderPopupButton :: Widget -> GtkRenderFn a
> renderPopupButton popup _ style gadget = do
>   btn <- Gtk.buttonNew
>   applyStyle (Gtk.buttonSetLabel btn) (getCaption style)
>   let onClicked = \ handler -> Gtk.onClicked btn handler >> return ()
>       inner = \ g st -> do traceMessage ("popup: gadget = " ++
>                                          gadgetName g)
>                            gui <- renderWidget (gadgets g) popup renderGtk
>                            runGtk gui st True
>       clickUpdate = \ gets -> connectInnerGadget onClicked
>                                           inner gets gadget
>   return (Gtk.castToWidget btn,
>           configureButton btn style gadget (const (return ())),
>           clickUpdate)

> configureButton :: Gtk.Button -> Style -> Maybe (Gadget a)
>                 -> (a -> IO ()) -> a -> IO ()
> configureButton btn style (Just gadget) update state = do
>   when (gadgetConfig gadget configHasLabel) $ do
>     Gtk.buttonSetLabel btn (gadgetConfig gadget configLabel state)
>   configureWidget btn style (Just gadget) update state

> configureButton _ _ _ update state = update state

> configureWidget :: (Gtk.WidgetClass w) =>
>                    w
>                 -> Style
>                 -> Maybe (Gadget a)
>                 -> (a -> IO ())
>                 -> a -> IO ()
> configureWidget widget style (Just gadget) update state = do
>    let enable = case (gadgetEnabled gadget state, getHideDisabled style) of
>                   (True, True)     -> Gtk.widgetShow
>                   (False, True)    -> Gtk.widgetHide
>                   (isEnbld, False) -> flip Gtk.widgetSetSensitivity isEnbld
>    enable widget
>    update state

> configureWidget _ _ _ update state = update state

> renderTextBox :: GtkRenderFn a
> renderTextBox _ style gadget = do
>   tb <- Gtk.entryNew
>   let onChanged = \ handler -> (Gtk.onEntryActivate tb handler >>
>                                 Gtk.onFocusOut tb (\ _ -> (handler >> return False)) >>
>                                 return ())
>       changeUpdate = \ getState ->
>                      connectEditorGadget onChanged getState
>                                   (Gtk.entryGetText tb)
>                                   gadget
>   return (Gtk.castToWidget tb,
>           configureWidget tb style gadget $
>                     connectDisplayGadget (Gtk.entrySetText tb) gadget,
>           changeUpdate)

> traceGadget :: Maybe (Gadget a) -> String -> IO ()
> traceGadget Nothing msg = traceMessage $ "<no gadget>: " ++ msg
> traceGadget (Just g) msg = traceMessage $ (gadgetName g) ++ msg

> -- |ModelRender: a record for rendering models.

> data ModelRender = MR { mrSetChoices   :: [String] -> IO (),
>                         mrSetSelection :: Int -> IO (),
>                         mrGetValue     :: IO String
>                       }

> -- |The function renderModel uses the Gtk combo box/list/tree
> -- |abstraction to do some abstracting of its own.

> -- |Currently, we only render single-column lists. This makes the
> -- |implementation almost trivial.  Yay!

> renderSingleColumnModel :: IO (Gtk.ListStore String)   -- ^ get model from widget
>                         -> (IO () -> IO ())        -- ^ selection change handler
>                         -> IO Int        -- ^ current selection from widget
>                         -> (Int -> IO ()) -- ^ set selection
>                         -> IO ModelRender
> renderSingleColumnModel getModel onChanged getCursor setCursor = do
>   elemsRef <- newIORef []
>   let setChoices xs = do
>           current <- readIORef elemsRef
>           when (current /= xs) $ do
>             model <- getModel
>             Gtk.listStoreClear model
>             mapM_ (Gtk.listStoreAppend model) xs
>             writeIORef elemsRef xs
>   let getValue = do cursor <- getCursor
>                     model  <- getModel
>                     if cursor < 0
>                          then return ""
>                          else Gtk.listStoreGetValue model cursor
>   let setValue n | n < 0     = setCursor n
>                  | otherwise = setCursor n
>   return MR { mrSetChoices = setChoices,
>               mrSetSelection = setValue,
>               mrGetValue = getValue
>             }

> renderChooser :: GtkRenderFn a
> renderChooser _ style gadget = do
>   store <- Gtk.listStoreNew []
>   chooser <- Gtk.comboBoxNewWithModel store
>   r <- Gtk.cellRendererTextNew
>   Gtk.cellLayoutPackStart chooser r True
>   Gtk.cellLayoutSetAttributes chooser r store $
>                          \ row -> [ Gtk.cellText := row ]
>   let getModel = return store
>       onChanged = \ handler -> Gtk.on chooser Gtk.changed handler >> return ()
>       getSel = Gtk.comboBoxGetActive chooser
>       setSel = Gtk.comboBoxSetActive chooser
>   mr <- renderSingleColumnModel getModel onChanged getSel setSel
>   let connect = connectChooserDisplay (mrSetChoices mr) (mrSetSelection mr)
>                                       gadget
>       update = \getState -> connectEditorGadget onChanged getState
>                                                     (mrGetValue mr) gadget
>   return (Gtk.castToWidget chooser,
>           configureWidget chooser style gadget connect,
>           update)

> renderLabel :: GtkRenderFn a
> renderLabel _ style gadget = do
>   label <- Gtk.labelNew Nothing
>   applyStyle (Gtk.labelSetText label) (getCaption style)
>   return (Gtk.castToWidget label,
>           connectDisplayGadget (Gtk.labelSetText label) gadget,
>           \ _ _ -> return ())

> renderSingleColumnList :: GtkRenderFn a
> renderSingleColumnList children style gadget = do
>   store <- Gtk.listStoreNew []
>   list <- Gtk.treeViewNewWithModel store
>   col <- Gtk.treeViewColumnNew
>   r <- Gtk.cellRendererTextNew
>   Gtk.cellLayoutPackStart col r True
>   Gtk.cellLayoutSetAttributes col r store $ \ row -> [ Gtk.cellText := row ]
>   Gtk.treeViewAppendColumn list col
>   let getModel = return store
>       onChanged = \ handler -> Gtk.onCursorChanged list handler >>
>                                                return ()
>       getSel = do (path, _) <- Gtk.treeViewGetCursor list
>                   case path of
>                     []  -> return (-1)
>                     [x] -> return x
>                     _   -> error $ "can't render tree view "
>       setSel n | n < 0 = Gtk.treeViewSetCursor list [] Nothing
>                | otherwise = Gtk.treeViewSetCursor list [n] Nothing
>   mr <- renderSingleColumnModel getModel onChanged getSel setSel
>   let connect = connectChooserDisplay (mrSetChoices mr) (mrSetSelection mr)
>                                       gadget
>       update = \getState -> connectEditorGadget onChanged getState
>                                                     (mrGetValue mr) gadget
>   return (Gtk.castToWidget list,
>           configureWidget list style gadget connect,
>           update)


>   {- list <- Gtk.treeViewNew
>   col <- Gtk.treeViewColumnNew
>   Gtk.treeViewAppendColumn list col
>   tr <- Gtk.cellRendererTextNew
>   Gtk.treeViewColumnPackStart col tr True
>   Gtk.treeViewColumnAddAttribute col tr "text" 0
>   let onChanged = \ handler -> Gtk.onCursorChanged list handler >>
>                                return ()
>   let getValue rd = do Just store <- Gtk.treeViewGetModel list
>                        (path, col) <- Gtk.treeViewGetCursor list
>                        miter <- Gtk.treeModelGetIter store path
>                        case miter of
>                           Nothing   -> return gvNoValue
>                           (Just iter) -> do
>                              (Gtk.GVstring (Just s)) <-
>                                       Gtk.treeModelGetValue store iter 0
>                              return (rd s)
>   return (Gtk.castToWidget list,
>           setListChanger (\ m -> Gtk.treeViewSetModel list m) gadget,
>           \ getState -> connectTextEditorGadget onChanged getState
>                                                 getValue gadget)
> -}

> {- setListChanger :: (Gtk.ListStore -> IO ())
>                -> Maybe (Gadget a)
>                -> a -> IO ()
> setListChanger update gadget st = connectDisplayGadget update' gadget st
>     where update' gv = toListStore gv >>= update
>           toListStore gv = case gvType gv of
>                              (GVList t) ->
>                                  toSingleColumnList t (gvListValues gv)
>                              _ -> error ("can't display value in a list: " ++
>                                          toString gv)
>           toSingleColumnList t list = do
>             store <- Gtk.listStoreNew [toGtkType t]
>             mapM_ (listModelAddRow store) (map (toGtkValue t) list)
>             return store
>   -}