module Barrie.Render.Gtk (gtkMain, initGtk, renderGtk, runGtk) where import Data.Dynamic import Data.Maybe 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.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 (gadgetName gadget) 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), ("fileChooser", renderFileChooser) ] -- 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 (gadgetName g) 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) when (configQuits cfg) $ do let closeCurrent w = Gtk.widgetGetToplevel w >>= Gtk.widgetDestroy Gtk.onClicked btn (closeCurrent btn) >> return () 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 $ ": " ++ msg traceGadget (Just g) msg = traceMessage $ (flatName g) ++ msg -} -- |ModelRender: a record for rendering models. data ModelRender = MR { mrSetChoices :: [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. renderListModel :: IO (Gtk.ListStore Dynamic) -- ^ get model from widget -> (IO () -> IO ()) -- ^ selection change handler -> IO Int -- ^ current selection from widget -> (Int -> IO ()) -- ^ set selection -> IO ModelRender renderListModel getModel onChanged getCursor setCursor = do currentChoices <- newIORef ([] :: [Dynamic]) let setChoices xs = do 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]) getValue = do cursor <- getCursor model <- getModel values <- Gtk.listStoreToList model return $ toDyn (values, cursor) hasChanged d = do let (_, x) = fromDyn d ([d], -100) when (x == (-100)) (putStrLn $ "trouble converting " ++ show d) 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]) chooser <- Gtk.comboBoxNewWithModel store r <- Gtk.cellRendererTextNew Gtk.cellLayoutPackStart chooser r True case gadget of Nothing -> return () Just g -> Gtk.cellLayoutSetAttributes chooser r store $ \ row -> [ Gtk.cellText := renderText (head (gadgetRenderer g) row) ] let getModel = return store onChanged = \ handler -> Gtk.on chooser Gtk.changed handler >> return () getSel = Gtk.comboBoxGetActive chooser setSel = Gtk.comboBoxSetActive chooser mr <- renderListModel getModel onChanged getSel setSel let connect = case gadget of Nothing -> \ _ -> return () Just g -> connectChooser (mrSetChoices mr) (mrSetSelection 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 ()) addTextColumn :: Gtk.TreeView -- ^ view that gets the column -> Gtk.ListStore Dynamic -> (Dynamic -> Dynamic) -- ^ column data fetcher -> IO () addTextColumn view store fetch = do col <- Gtk.treeViewColumnNew r <- Gtk.cellRendererTextNew Gtk.cellLayoutPackStart col r True Gtk.cellLayoutSetAttributes col r store $ \ row -> [ Gtk.cellText := renderText (fetch row) ] Gtk.treeViewAppendColumn view col return () renderSingleColumnList :: GtkRenderFn a renderSingleColumnList _ style gadget = do store <- Gtk.listStoreNew [] list <- Gtk.treeViewNewWithModel store case gadget of Nothing -> return () Just g -> do mapM_ (addTextColumn list store) (gadgetRenderer g) cols <- Gtk.treeViewGetColumns list mapM_ (\ (c,t) -> Gtk.treeViewColumnSetTitle c t) (zip cols (configTitles (gadgetConfig g))) 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 <- renderListModel getModel onChanged getSel setSel let connect = case gadget of Nothing -> \ _ -> return () Just g -> connectChooser (mrSetChoices mr) (mrSetSelection 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) renderFileChooser :: GtkRenderFn a renderFileChooser ws style gadget = do case fileChooserAction style of FileOpen -> renderFileOpen ws style gadget FileSave -> renderFileSave ws style gadget renderFileOpen :: GtkRenderFn a renderFileOpen _ style gadget = do chooser <- Gtk.fileChooserDialogNew (getCaption style) Nothing Gtk.FileChooserActionOpen [("Open", Gtk.ResponseOk), ("Cancel", Gtk.ResponseCancel)] Gtk.fileChooserSetDoOverwriteConfirmation chooser True let runChooseFile = do response <- Gtk.dialogRun chooser Gtk.widgetHide chooser if response == Gtk.ResponseOk then do fname <- Gtk.fileChooserGetFilename chooser case fname of Nothing -> return (toDyn "") Just name -> readFile name >>= return . toDyn else return (toDyn "") btn <- Gtk.buttonNew applyStyle (Gtk.buttonSetLabel btn) (getCaption style) let onClicked = \ handler -> Gtk.onClicked btn handler >> return () clickUpdate = \ gets -> case gadget of Just g -> connectUpdater onClicked gets runChooseFile g Nothing -> const (return ()) return (Gtk.castToWidget btn, configureButton btn style gadget (const (return ())), clickUpdate) renderFileSave :: GtkRenderFn a renderFileSave _ style gadget = do chooser <- Gtk.fileChooserDialogNew (getCaption style) Nothing Gtk.FileChooserActionSave [("Save", Gtk.ResponseOk), ("Cancel", Gtk.ResponseCancel)] let runSaveFile gets getStrVal = do response <- Gtk.dialogRun chooser Gtk.widgetHide chooser when (response == Gtk.ResponseOk) $ do fname <- Gtk.fileChooserGetFilename chooser case fname of Nothing -> return () Just name -> do st <- gets writeFile name (renderText (getStrVal st)) btn <- Gtk.buttonNew applyStyle (Gtk.buttonSetLabel btn) (getCaption style) let onClicked = \ handler -> Gtk.onClicked btn handler >> return () clickUpdate = \ gets _ -> case gadget of Just g -> onClicked $ runSaveFile gets (gadgetDisplay g) Nothing -> return () return (Gtk.castToWidget btn, configureButton btn style gadget (const (return ())), clickUpdate)