src/RMCA/GUI/Buttons.hs

   1 {-# LANGUAGE FlexibleContexts, LambdaCase, MultiParamTypeClasses,
   2              OverloadedStrings #-}
   3
   4 module RMCA.GUI.Buttons ( buttonNewFromStockWithLabel
   5                         , toggleButtonNewFromStock
   6                         , getButtons
   7                         ) where
   8
   9 import Control.Monad
  10 import Data.Maybe
  11 import Data.ReactiveValue
  12 import Graphics.UI.Gtk
  13 import Graphics.UI.Gtk.Reactive
  14 import RMCA.GUI.StockId
  15 import RMCA.Layer.Board
  16
  17 packButton :: (BoxClass a, ButtonClass b, ImageClass i, LabelClass l) =>
  18               b -> a -> l -> i -> IO b
  19 packButton button buttonBox buttonLabel buttonImg = do
  20   containerAdd button buttonBox
  21   boxPackStart buttonBox buttonImg PackRepel 0
  22   boxPackStart buttonBox buttonLabel PackRepel 0
  23   return button
  24
  25 buttonNewFromStockWithLabel :: StockId -> String -> IO Button
  26 buttonNewFromStockWithLabel s l = do
  27   button <- buttonNew
  28   buttonBox <- hBoxNew False 0
  29   buttonImg <- imageNewFromStock s IconSizeButton
  30   buttonLabel <- labelNew (Just l)
  31   labelSetUseUnderline buttonLabel True
  32   packButton button buttonBox buttonLabel buttonImg
  33
  34 toggleButtonNewFromStock :: StockId -> IO ToggleButton
  35 toggleButtonNewFromStock s = do
  36   button <- toggleButtonNew
  37   buttonBox <- hBoxNew False 0
  38   buttonImg <- imageNewFromStock s IconSizeButton
  39   stockTxt <- stockLookupItem s
  40   buttonLabel <- labelNew (fmap siLabel stockTxt)
  41   labelSetUseUnderline buttonLabel True
  42   packButton button buttonBox buttonLabel buttonImg
  43
  44 getButtons :: (ReactiveValueRead boardStatus RunStatus IO) =>
  45               boardStatus -> IO ( VBox
  46                                 , ReactiveFieldRead IO ()
  47                                 , ReactiveFieldRead IO ()
  48                                 , ReactiveFieldRead IO Bool
  49                                 , ReactiveFieldRead IO Bool
  50                                 , ReactiveFieldRead IO ()
  51                                 , ReactiveFieldRead IO ()
  52                                 , ReactiveFieldRead IO ()
  53                                 , ReactiveFieldRead IO ()
  54                                 , ReactiveFieldRead IO ()
  55                                 )
  56 getButtons boardStatusRV = do
  57   --addRestartButton
  58   restartM <- stockLookupItem gtkMediaRestart
  59   when (isJust restartM) $
  60     stockAddItem [(fromJust restartM) { siLabel = "_Restart" }]
  61   buttonBox <- vBoxNew False 5
  62
  63   buttonBoxAddRmLayers <- hBoxNew True 10
  64   boxPackStart buttonBox buttonBoxAddRmLayers PackNatural 0
  65
  66   buttonAddLayer <- buttonNewFromStockWithLabel gtkMediaAdd "Add layer"
  67   let addLayerRV = buttonActivateField buttonAddLayer
  68   boxPackStart buttonBoxAddRmLayers buttonAddLayer PackGrow 0
  69
  70   buttonRmLayer <- buttonNewFromStockWithLabel gtkMediaRemove "Remove layer"
  71   let rmLayerRV = buttonActivateField buttonRmLayer
  72   boxPackStart buttonBoxAddRmLayers buttonRmLayer PackGrow 0
  73
  74   buttonRmAll <- buttonNewFromStockWithLabel gtkMediaRemove "Clear"
  75   let rmAllRV = buttonActivateField buttonRmAll
  76   boxPackStart buttonBoxAddRmLayers buttonRmAll PackGrow 0
  77
  78   buttonBoxSaveLoad <- hBoxNew True 10
  79   boxPackStart buttonBox buttonBoxSaveLoad PackNatural 0
  80
  81   buttonSave <- buttonNewFromStockWithLabel gtkMediaSave "_Save configuration"
  82   let confSaveRV = buttonActivateField buttonSave
  83   boxPackStart buttonBoxSaveLoad buttonSave PackGrow 0
  84
  85   buttonLoad <- buttonNewFromStockWithLabel gtkMediaOpen "_Load configuration"
  86   let confLoadRV = buttonActivateField buttonLoad
  87   boxPackStart buttonBoxSaveLoad buttonLoad PackGrow 0
  88
  89   buttonBoxBot <- hBoxNew True 10
  90   boxPackStart buttonBox buttonBoxBot PackNatural 0
  91   buttonPlay <- buttonNewFromStock gtkMediaPlay
  92   let playRV = buttonActivateField buttonPlay
  93       playStockId = wrapMW (buttonSetLabel buttonPlay)
  94   reactiveValueWrite playStockId gtkMediaPlay
  95   reactiveValueOnCanRead boardStatusRV $ reactiveValueRead boardStatusRV >>=
  96     \case
  97       Stopped -> reactiveValueWrite playStockId gtkMediaPlay
  98       Running -> reactiveValueWrite playStockId gtkMediaRestart
  99   boxPackStart buttonBoxBot buttonPlay PackRepel 0
 100
 101   buttonPause <- toggleButtonNewFromStock gtkMediaPause
 102   let pauseRV = readOnly $ toggleButtonActiveReactive buttonPause
 103   boxPackStart buttonBoxBot buttonPause PackRepel 0
 104
 105   buttonStop <- buttonNewFromStock gtkMediaStop
 106   let stopRV = buttonActivateField buttonStop
 107   boxPackStart buttonBoxBot buttonStop PackRepel 0
 108
 109   buttonRecord <- toggleButtonNewFromStock gtkMediaRecord
 110   let recordRV = readOnly $ toggleButtonActiveReactive buttonRecord
 111   boxPackStart buttonBoxBot buttonRecord PackRepel 0
 112
 113   return ( buttonBox
 114          , playRV
 115          , stopRV
 116          , pauseRV
 117          , recordRV
 118          , confSaveRV
 119          , confLoadRV
 120          , addLayerRV
 121          , rmLayerRV
 122          , rmAllRV
 123          )