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 System.Glib
   9
  10 gtkMediaPlay :: DefaultGlibString
  11 gtkMediaPlay = stringToGlib "gtk-media-play"
  12
  13 gtkMediaStop :: DefaultGlibString
  14 gtkMediaStop = stringToGlib "gtk-media-stop"
  15
  16 gtkMediaPause :: DefaultGlibString
  17 gtkMediaPause = stringToGlib "gtk-media-pause"
  18
  19 gtkMediaRecord :: DefaultGlibString
  20 gtkMediaRecord = stringToGlib "gtk-media-record"
  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 PackNatural 0
  32   boxPackStart buttonBox buttonLabel PackNatural 0
  33   return button
  34
  35 getButtons :: IO ( HBox
  36                  , ReactiveFieldRead IO ()
  37                  , ReactiveFieldRead IO ()
  38                  , ReactiveFieldRead IO Bool
  39                  , ReactiveFieldRead IO Bool
  40                  )
  41 getButtons = do
  42   buttonBox <- hBoxNew True 10
  43   buttonPlay <- buttonNewFromStock gtkMediaPlay
  44   let playRV = buttonActivateField buttonPlay
  45   boxPackStart buttonBox buttonPlay PackRepel 0
  46
  47   buttonPause <- toggleButtonNewFromStock gtkMediaPause
  48   let pauseRV = readOnly $ toggleButtonActiveReactive buttonPause
  49   boxPackStart buttonBox buttonPause PackRepel 0
  50
  51   buttonStop <- buttonNewFromStock gtkMediaStop
  52   let stopRV = buttonActivateField buttonStop
  53   boxPackStart buttonBox buttonStop PackRepel 0
  54
  55   buttonRecord <- toggleButtonNewFromStock gtkMediaRecord
  56   let recordRV = readOnly $ toggleButtonActiveReactive buttonRecord
  57   boxPackStart buttonBox buttonRecord PackRepel 0
  58
  59   return ( buttonBox
  60          , playRV
  61          , stopRV
  62          , pauseRV
  63          , recordRV
  64          )