src/RMCA/GUI/Buttons.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module RMCA.GUI.Buttons where
   4
   5 import Data.ReactiveValue
   6 import Graphics.UI.Gtk
   7 import Graphics.UI.Gtk.Reactive
   8 import RMCA.GUI.StockId
   9
  10 buttonNewFromStockWithLabel :: StockId -> String -> IO Button
  11 buttonNewFromStockWithLabel s l = do
  12   button <- buttonNew
  13   buttonBox <- hBoxNew False 0
  14   buttonImg <- imageNewFromStock s IconSizeButton
  15   buttonLabel <- labelNew (Just l)
  16   labelSetUseUnderline buttonLabel True
  17   containerAdd button buttonBox
  18   boxPackStart buttonBox buttonImg PackRepel 0
  19   boxPackStart buttonBox buttonLabel PackRepel 0
  20   return button
  21
  22 toggleButtonNewFromStock :: StockId -> IO ToggleButton
  23 toggleButtonNewFromStock s = do
  24   button <- toggleButtonNew
  25   buttonBox <- hBoxNew False 0
  26   buttonImg <- imageNewFromStock s IconSizeButton
  27   stockTxt <- stockLookupItem s
  28   buttonLabel <- labelNew (siLabel <$> stockTxt)
  29   labelSetUseUnderline buttonLabel True
  30   containerAdd button buttonBox
  31   boxPackStart buttonBox buttonImg PackRepel 0
  32   boxPackStart buttonBox buttonLabel PackRepel 0
  33   return button
  34
  35 getButtons :: IO ( VBox
  36                  , ReactiveFieldRead IO ()
  37                  , ReactiveFieldRead IO ()
  38                  , ReactiveFieldRead IO Bool
  39                  , ReactiveFieldRead IO Bool
  40                  , ReactiveFieldRead IO ()
  41                  , ReactiveFieldRead IO ()
  42                  , ReactiveFieldRead IO ()
  43                  , ReactiveFieldRead IO ()
  44                  )
  45 getButtons = do
  46   buttonBox <- vBoxNew False 10
  47
  48   buttonBoxAddRmLayers <- hBoxNew True 10
  49   boxPackStart buttonBox buttonBoxAddRmLayers PackNatural 0
  50
  51   buttonAddLayer <- buttonNewFromStockWithLabel gtkMediaAdd "Add layer"
  52   let addLayerRV = buttonActivateField buttonAddLayer
  53   boxPackStart buttonBoxAddRmLayers buttonAddLayer PackGrow 0
  54
  55   buttonRmLayer <- buttonNewFromStockWithLabel gtkMediaRemove "Remove layer"
  56   let rmLayerRV = buttonActivateField buttonRmLayer
  57   boxPackStart buttonBoxAddRmLayers buttonRmLayer PackGrow 0
  58
  59   buttonBoxSaveLoad <- hBoxNew True 10
  60   boxPackStart buttonBox buttonBoxSaveLoad PackNatural 0
  61
  62   buttonSave <- buttonNewFromStockWithLabel gtkMediaSave "_Save configuration"
  63   let confSaveRV = buttonActivateField buttonSave
  64   boxPackStart buttonBoxSaveLoad buttonSave PackGrow 0
  65
  66   buttonLoad <- buttonNewFromStockWithLabel gtkMediaOpen "_Load configuration"
  67   let confLoadRV = buttonActivateField buttonLoad
  68   boxPackStart buttonBoxSaveLoad buttonLoad PackGrow 0
  69
  70
  71   buttonBoxBot <- hBoxNew True 10
  72   boxPackStart buttonBox buttonBoxBot PackNatural 0
  73   buttonPlay <- buttonNewFromStock gtkMediaPlay
  74   let playRV = buttonActivateField buttonPlay
  75   boxPackStart buttonBoxBot buttonPlay PackRepel 0
  76
  77   buttonPause <- toggleButtonNewFromStock gtkMediaPause
  78   let pauseRV = readOnly $ toggleButtonActiveReactive buttonPause
  79   boxPackStart buttonBoxBot buttonPause PackRepel 0
  80
  81   buttonStop <- buttonNewFromStock gtkMediaStop
  82   let stopRV = buttonActivateField buttonStop
  83   boxPackStart buttonBoxBot buttonStop PackRepel 0
  84
  85   buttonRecord <- toggleButtonNewFromStock gtkMediaRecord
  86   let recordRV = readOnly $ toggleButtonActiveReactive buttonRecord
  87   boxPackStart buttonBoxBot buttonRecord PackRepel 0
  88
  89   return ( buttonBox
  90          , playRV
  91          , stopRV
  92          , pauseRV
  93          , recordRV
  94          , confSaveRV
  95          , confLoadRV
  96          , addLayerRV
  97          , rmLayerRV
  98          )