src/RMCA/GUI/Buttons.hs

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