Gtk.hs

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 $ "<no gadget>: " ++ 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)