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