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 (siLabel <$> stockTxt)
  41   labelSetUseUnderline buttonLabel True
  42   packButton button buttonBox buttonLabel buttonImg
  43
  44 buttonBoxNewWithLabelFromStock :: StockId -> IO HBox
  45 buttonBoxNewWithLabelFromStock s = do
  46   buttonBox <- hBoxNew False 0
  47   buttonImg <- imageNewFromStock s IconSizeButton
  48   stockTxt <- stockLookupItem s
  49   buttonLabel <- labelNew (siLabel <$> stockTxt)
  50   labelSetUseUnderline buttonLabel True
  51   boxPackStart buttonBox buttonImg PackRepel 0
  52   boxPackStart buttonBox buttonLabel PackRepel 0
  53   return buttonBox
  54
  55 getButtons :: (ReactiveValueRead boardStatus RunStatus IO) =>
  56               boardStatus -> IO ( VBox
  57                                 , ReactiveFieldRead IO ()
  58                                 , ReactiveFieldRead IO ()
  59                                 , ReactiveFieldRead IO Bool
  60                                 , ReactiveFieldRead IO Bool
  61                                 , ReactiveFieldRead IO ()
  62                                 , ReactiveFieldRead IO ()
  63                                 , ReactiveFieldRead IO ()
  64                                 , ReactiveFieldRead IO ()
  65                                 )
  66 getButtons boardStatusRV = do
  67   --addRestartButton
  68   restartM <- stockLookupItem gtkMediaRestart
  69   when (isJust restartM) $ do
  70     stockAddItem [(fromJust restartM) { siLabel = "_Restart" }]
  71   buttonBox <- vBoxNew False 10
  72
  73   buttonBoxAddRmLayers <- hBoxNew True 10
  74   boxPackStart buttonBox buttonBoxAddRmLayers PackNatural 0
  75
  76   buttonAddLayer <- buttonNewFromStockWithLabel gtkMediaAdd "Add layer"
  77   let addLayerRV = buttonActivateField buttonAddLayer
  78   boxPackStart buttonBoxAddRmLayers buttonAddLayer PackGrow 0
  79
  80   buttonRmLayer <- buttonNewFromStockWithLabel gtkMediaRemove "Remove layer"
  81   let rmLayerRV = buttonActivateField buttonRmLayer
  82   boxPackStart buttonBoxAddRmLayers buttonRmLayer PackGrow 0
  83
  84   buttonBoxSaveLoad <- hBoxNew True 10
  85   boxPackStart buttonBox buttonBoxSaveLoad PackNatural 0
  86
  87   buttonSave <- buttonNewFromStockWithLabel gtkMediaSave "_Save configuration"
  88   let confSaveRV = buttonActivateField buttonSave
  89   boxPackStart buttonBoxSaveLoad buttonSave PackGrow 0
  90
  91   buttonLoad <- buttonNewFromStockWithLabel gtkMediaOpen "_Load configuration"
  92   let confLoadRV = buttonActivateField buttonLoad
  93   boxPackStart buttonBoxSaveLoad buttonLoad PackGrow 0
  94
  95   buttonBoxBot <- hBoxNew True 10
  96   boxPackStart buttonBox buttonBoxBot PackNatural 0
  97   buttonPlay <- buttonNewFromStock gtkMediaPlay
  98   let playRV = buttonActivateField buttonPlay
  99       playStockId = wrapMW (buttonSetLabel buttonPlay)
 100   reactiveValueWrite playStockId gtkMediaPlay
 101   reactiveValueOnCanRead boardStatusRV $ reactiveValueRead boardStatusRV >>=
 102     \case
 103       Stopped -> reactiveValueWrite playStockId $ gtkMediaPlay
 104       Running -> reactiveValueWrite playStockId $ gtkMediaRestart
 105   boxPackStart buttonBoxBot buttonPlay PackRepel 0
 106
 107   buttonPause <- toggleButtonNewFromStock gtkMediaPause
 108   let pauseRV = readOnly $ toggleButtonActiveReactive buttonPause
 109   boxPackStart buttonBoxBot buttonPause PackRepel 0
 110
 111   buttonStop <- buttonNewFromStock gtkMediaStop
 112   let stopRV = buttonActivateField buttonStop
 113   boxPackStart buttonBoxBot buttonStop PackRepel 0
 114
 115   buttonRecord <- toggleButtonNewFromStock gtkMediaRecord
 116   let recordRV = readOnly $ toggleButtonActiveReactive buttonRecord
 117   boxPackStart buttonBoxBot buttonRecord PackRepel 0
 118
 119   return ( buttonBox
 120          , playRV
 121          , stopRV
 122          , pauseRV
 123          , recordRV
 124          , confSaveRV
 125          , confLoadRV
 126          , addLayerRV
 127          , rmLayerRV
 128          )