barrie-0.4: src/Barrie/Render/Gtk.hs
module Barrie.Render.Gtk (gtkMain, initGtk, renderGtk, runGtk) where
import Data.Dynamic
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.Gadgets.Connections
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)
-- |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 -> 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),
("checkbutton", renderCheckButton),
("droplist", renderChooser),
("list", renderSingleColumnList),
("hslider", renderScale Gtk.hScaleNewWithRange),
("vslider", renderScale Gtk.vScaleNewWithRange),
("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 = do
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 -> case gadget of
Just g -> connectCommand onClicked gets g
Nothing -> const (return ())
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 gui <- renderWidget (gadgets g) popup renderGtk
runGtk gui st True
clickUpdate = \ gets -> case gadget of
Nothing -> \ _ -> return ()
Just g ->
connectChild onClicked inner gets g
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
let cfg = gadgetConfig gadget
when (configHasLabel cfg) $ do
Gtk.buttonSetLabel btn (configLabel cfg state)
configureWidget btn style (Just gadget) update state
configureButton _ _ _ update state = update state
configureTreeView :: Gtk.TreeView -> Style -> Maybe (Gadget a)
-> (a -> IO ()) -> a -> IO ()
configureTreeView view style (Just gadget) update state = do
Gtk.treeViewSetHeadersVisible view (getTreeHeaderVisible style)
configureWidget view style (Just gadget) update state
configureTreeView _ _ _ 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
renderScale :: (Gtk.ScaleClass scale) =>
(Double -> Double -> Double -> IO scale) -- ^ constructor
-> GtkRenderFn a
renderScale new _ style gadget = do
scale <- new (getMinValue style) (getMaxValue style) (getAdjustment style)
let onChanged = \ h -> (Gtk.onRangeValueChanged scale h >>
return ())
hasChanged = \ d -> (Gtk.rangeGetValue scale >>=
\ t -> return $ t /= renderDouble d)
getDynValue = Gtk.rangeGetValue scale >>= return . toDyn
setDynValue d = Gtk.rangeSetValue scale (renderDouble d)
changeUpdate getSt = case gadget of
Nothing -> \ _ -> return ()
Just g -> connectEditor onChanged getSt
hasChanged getDynValue g
updateValue = case gadget of
Nothing -> \ _ -> return ()
Just g -> connectDisplay setDynValue g
return (Gtk.castToWidget scale,
configureWidget scale style gadget updateValue,
changeUpdate)
renderTextBox :: GtkRenderFn a
renderTextBox _ style gadget = do
tb <- Gtk.entryNew
let onChanged = \ h -> (Gtk.onEntryActivate tb h >>
Gtk.onFocusOut tb (\ _ -> (h >> return False)) >>
return ())
hasChanged = \ d -> (Gtk.entryGetText tb >>=
\ t -> return $ t /= renderText d)
getDynValue = Gtk.entryGetText tb >>= return . toDyn
setDynValue d = Gtk.entrySetText tb (renderText d)
changeUpdate getSt = case gadget of
Nothing -> \ _ -> return ()
Just g -> connectEditor onChanged getSt
hasChanged getDynValue g
updateValue = case gadget of
Nothing -> \ _ -> return ()
Just g -> connectDisplay setDynValue g
return (Gtk.castToWidget tb,
configureWidget tb style gadget updateValue,
changeUpdate)
renderCheckButton :: GtkRenderFn a
renderCheckButton _ style gadget = do
cb <- Gtk.checkButtonNew
let onChanged = \ h -> (Gtk.onToggled cb h >> return ())
hasChanged = \ d -> (Gtk.toggleButtonGetActive cb >>=
\ t -> return $ t /= renderBool d)
getDynValue = Gtk.toggleButtonGetActive cb >>= return . toDyn
setDynValue d = Gtk.toggleButtonSetActive cb (renderBool d)
changeUpdate getSt = case gadget of
Nothing -> \ _ -> return ()
Just g -> connectEditor onChanged getSt
hasChanged getDynValue g
updateValue = case gadget of
Nothing -> \ _ -> return ()
Just g -> connectDisplay setDynValue g
return (Gtk.castToWidget cb,
configureWidget cb style gadget updateValue,
changeUpdate)
traceGadget :: Maybe (Gadget a) -> String -> IO ()
traceGadget Nothing msg = traceMessage $ "<no gadget>: " ++ msg
traceGadget (Just g) msg = traceMessage $ (flatName g) ++ msg
-- |ModelRender: a record for rendering models.
data ModelRender = MR { mrSetChoices :: [(Dynamic, Dynamic)] -> IO (),
mrSetSelection :: Int -> IO (),
mrGetValue :: IO Dynamic,
mrHasChanged :: Dynamic -> IO Bool
}
-- |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 (Dynamic, Dynamic)) -- ^ 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
-- needUpdateRef <- newIORef True
currentChoices <- newIORef ([] :: [(Dynamic, Dynamic)])
let setChoices xs = do
-- needUpdate <- readIORef needUpdateRef
-- writeIORef needUpdateRef False
model <- getModel
es <- Gtk.listStoreToList model
-- Note that we don't have a very good way of deciding
-- when to update the list elements.
when (length es /= length xs) $ do
Gtk.listStoreClear model
mapM_ (Gtk.listStoreAppend model) xs
writeIORef currentChoices (xs :: [(Dynamic, Dynamic)])
getValue = do
cursor <- getCursor
model <- getModel
values <- Gtk.listStoreToList model
return $ toDyn (values, cursor)
hasChanged d = do
let (_, x) = fromDyn d ([(d,d)], -100)
s = fromDyn d "not a string"
curr <- getCursor
return (x /= curr)
return MR { mrSetChoices = setChoices,
mrSetSelection = setCursor,
mrGetValue = getValue,
mrHasChanged = hasChanged
}
renderChooser :: GtkRenderFn a
renderChooser _ style gadget = do
store <- Gtk.listStoreNew ([] :: [(Dynamic, Dynamic)])
chooser <- Gtk.comboBoxNewWithModel store
r <- Gtk.cellRendererTextNew
Gtk.cellLayoutPackStart chooser r True
Gtk.cellLayoutSetAttributes chooser r store $
\ row -> [ Gtk.cellText := renderText $ fst 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 = case gadget of
Nothing -> \ _ -> return ()
Just g -> connectChooser (mrSetChoices mr) (mrSetSelection mr)
(mrGetValue mr) g
update getSt = case gadget of
Nothing -> \ _-> return ()
Just g -> connectEditor onChanged getSt
(mrHasChanged mr)
(mrGetValue mr) g
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)
let setDynText d = Gtk.labelSetText label (renderText d)
updateText = case gadget of
Nothing -> \ _ -> return ()
Just g -> connectDisplay setDynText g
return (Gtk.castToWidget label, updateText, \ _ _ -> 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 := renderText (fst 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 = case gadget of
Nothing -> \ _ -> return ()
Just g -> connectChooser (mrSetChoices mr) (mrSetSelection mr)
(mrGetValue mr) g
update getSt = case gadget of
Nothing -> \ _-> return ()
Just g -> connectEditor onChanged getSt
(mrHasChanged mr)
(mrGetValue mr) g
return (Gtk.castToWidget list,
configureTreeView list style gadget connect,
update)