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                                 )
  55 getButtons boardStatusRV = do
  56   --addRestartButton
  57   restartM <- stockLookupItem gtkMediaRestart
  58   when (isJust restartM) $
  59     stockAddItem [(fromJust restartM) { siLabel = "_Restart" }]
  60   buttonBox <- vBoxNew False 5
  61
  62   buttonBoxAddRmLayers <- hBoxNew True 10
  63   boxPackStart buttonBox buttonBoxAddRmLayers PackNatural 0
  64
  65   buttonAddLayer <- buttonNewFromStockWithLabel gtkMediaAdd "Add layer"
  66   let addLayerRV = buttonActivateField buttonAddLayer
  67   boxPackStart buttonBoxAddRmLayers buttonAddLayer PackGrow 0
  68
  69   buttonRmLayer <- buttonNewFromStockWithLabel gtkMediaRemove "Remove layer"
  70   let rmLayerRV = buttonActivateField buttonRmLayer
  71   boxPackStart buttonBoxAddRmLayers buttonRmLayer PackGrow 0
  72
  73   buttonBoxSaveLoad <- hBoxNew True 10
  74   boxPackStart buttonBox buttonBoxSaveLoad PackNatural 0
  75
  76   buttonSave <- buttonNewFromStockWithLabel gtkMediaSave "_Save configuration"
  77   let confSaveRV = buttonActivateField buttonSave
  78   boxPackStart buttonBoxSaveLoad buttonSave PackGrow 0
  79
  80   buttonLoad <- buttonNewFromStockWithLabel gtkMediaOpen "_Load configuration"
  81   let confLoadRV = buttonActivateField buttonLoad
  82   boxPackStart buttonBoxSaveLoad buttonLoad PackGrow 0
  83
  84   buttonBoxBot <- hBoxNew True 10
  85   boxPackStart buttonBox buttonBoxBot PackNatural 0
  86   buttonPlay <- buttonNewFromStock gtkMediaPlay
  87   let playRV = buttonActivateField buttonPlay
  88       playStockId = wrapMW (buttonSetLabel buttonPlay)
  89   reactiveValueWrite playStockId gtkMediaPlay
  90   reactiveValueOnCanRead boardStatusRV $ reactiveValueRead boardStatusRV >>=
  91     \case
  92       Stopped -> reactiveValueWrite playStockId gtkMediaPlay
  93       Running -> reactiveValueWrite playStockId gtkMediaRestart
  94   boxPackStart buttonBoxBot buttonPlay PackRepel 0
  95
  96   buttonPause <- toggleButtonNewFromStock gtkMediaPause
  97   let pauseRV = readOnly $ toggleButtonActiveReactive buttonPause
  98   boxPackStart buttonBoxBot buttonPause PackRepel 0
  99
 100   buttonStop <- buttonNewFromStock gtkMediaStop
 101   let stopRV = buttonActivateField buttonStop
 102   boxPackStart buttonBoxBot buttonStop PackRepel 0
 103
 104   buttonRecord <- toggleButtonNewFromStock gtkMediaRecord
 105   let recordRV = readOnly $ toggleButtonActiveReactive buttonRecord
 106   boxPackStart buttonBoxBot buttonRecord PackRepel 0
 107
 108   return ( buttonBox
 109          , playRV
 110          , stopRV
 111          , pauseRV
 112          , recordRV
 113          , confSaveRV
 114          , confLoadRV
 115          , addLayerRV
 116          , rmLayerRV
 117          )