]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/GUI/Buttons.hs
Whiter hexagon.
[tmp/julm/arpeggigon.git] / 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 )