Commit 080d8882 by Guerric Chupin

Restart icon working.

parent 2ebf9b76
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts, LambdaCase, MultiParamTypeClasses,
OverloadedStrings #-}
module RMCA.GUI.Buttons ( buttonNewFromStockWithLabel
, toggleButtonNewFromStock
, getButtons
) where
import Control.Monad
import Data.Maybe
import Data.ReactiveValue
import Graphics.UI.Gtk
import Graphics.UI.Gtk.Reactive
import RMCA.GUI.StockId
import RMCA.Layer.Board
packButton :: (BoxClass a, ButtonClass b, ImageClass i, LabelClass l) =>
b -> a -> l -> i -> IO b
......@@ -37,17 +41,33 @@ toggleButtonNewFromStock s = do
labelSetUseUnderline buttonLabel True
packButton button buttonBox buttonLabel buttonImg
getButtons :: IO ( VBox
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO Bool
, ReactiveFieldRead IO Bool
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO ()
)
getButtons = do
buttonBoxNewWithLabelFromStock :: StockId -> IO HBox
buttonBoxNewWithLabelFromStock s = do
buttonBox <- hBoxNew False 0
buttonImg <- imageNewFromStock s IconSizeButton
stockTxt <- stockLookupItem s
buttonLabel <- labelNew (siLabel <$> stockTxt)
labelSetUseUnderline buttonLabel True
boxPackStart buttonBox buttonImg PackRepel 0
boxPackStart buttonBox buttonLabel PackRepel 0
return buttonBox
getButtons :: (ReactiveValueRead boardStatus RunStatus IO) =>
boardStatus -> IO ( VBox
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO Bool
, ReactiveFieldRead IO Bool
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO ()
, ReactiveFieldRead IO ()
)
getButtons boardStatusRV = do
--addRestartButton
restartM <- stockLookupItem gtkMediaRestart
when (isJust restartM) $ do
stockAddItem [(fromJust restartM) { siLabel = "_Restart" }]
buttonBox <- vBoxNew False 10
buttonBoxAddRmLayers <- hBoxNew True 10
......@@ -72,11 +92,16 @@ getButtons = do
let confLoadRV = buttonActivateField buttonLoad
boxPackStart buttonBoxSaveLoad buttonLoad PackGrow 0
buttonBoxBot <- hBoxNew True 10
boxPackStart buttonBox buttonBoxBot PackNatural 0
buttonPlay <- buttonNewFromStock gtkMediaPlay
let playRV = buttonActivateField buttonPlay
playStockId = wrapMW (buttonSetLabel buttonPlay)
reactiveValueWrite playStockId gtkMediaPlay
reactiveValueOnCanRead boardStatusRV $ reactiveValueRead boardStatusRV >>=
\case
Stopped -> reactiveValueWrite playStockId $ gtkMediaPlay
Running -> reactiveValueWrite playStockId $ gtkMediaRestart
boxPackStart buttonBoxBot buttonPlay PackRepel 0
buttonPause <- toggleButtonNewFromStock gtkMediaPause
......
......@@ -160,17 +160,17 @@ layerSettings isStartedRV = do
bpbSensitiveRV <- swapHandlerStorage $
widgetSensitiveReactive bpbButton
reactiveValueOnCanRead isStartedRV $ do
reactiveValueOnCanRead isStartedRV $
reactiveValueRead isStartedRV >>=
\case
Running -> do reactiveValueRead repeatCheckRV
reactiveValueWrite repeatSensitive False
reactiveValueWrite bpbSensitiveRV False
reactiveValueWrite repeatCheckSensitive False
Stopped -> do reactiveValueRead repeatCheckRV >>=
reactiveValueWrite repeatSensitive
reactiveValueWrite bpbSensitiveRV True
reactiveValueWrite repeatCheckSensitive True
\case
Running -> do reactiveValueRead repeatCheckRV
reactiveValueWrite repeatSensitive False
reactiveValueWrite bpbSensitiveRV False
reactiveValueWrite repeatCheckSensitive False
Stopped -> do reactiveValueRead repeatCheckRV >>=
reactiveValueWrite repeatSensitive
reactiveValueWrite bpbSensitiveRV True
reactiveValueWrite repeatCheckSensitive True
repeatCheckRV =:> repeatSensitive
reactiveValueWrite repeatCheckRV False
......
......@@ -28,11 +28,11 @@ data SynthConf = SynthConf { volume :: Int
} deriving (Show, Read, Eq)
synthMessage :: Int -> SynthConf -> [Message]
synthMessage chan (SynthConf { volume = v
, instrument = i
}) = [ Volume (mkChannel chan) v
, Instrument (mkChannel chan) (mkProgram i)
]
synthMessage chan SynthConf { volume = v
, instrument = i
} = [ Volume (mkChannel chan) v
, Instrument (mkChannel chan) (mkProgram i)
]
type LayerConf = (StaticLayerConf, DynLayerConf, SynthConf)
......
{-# LANGUAGE LambdaCase, MultiParamTypeClasses, ScopedTypeVariables,
TupleSections #-}
{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TupleSections #-}
module Main where
......@@ -45,15 +44,16 @@ main = do
globalSep <- hSeparatorNew
boxPackStart settingsBox globalSep PackNatural 10
boardStatusRV <- newCBMVarRW Stopped
(buttonBox,
playRV,stopRV,pauseRV,recordRV,
confSaveRV,confLoadRV,
addLayerRV,rmLayerRV) <- getButtons
addLayerRV,rmLayerRV) <- getButtons boardStatusRV
boxPackEnd settingsBox buttonBox PackNatural 0
boardQueue <- newCBRef mempty
--isStartMVar <- newMVar False
boardStatusRV <- newCBMVarRW Stopped
(layerSettingsVBox, statMCBMVar, dynMCBMVar, synthMCBMVar) <- layerSettings boardStatusRV
boxPackStart settingsBox layerSettingsVBox PackNatural 0
laySep <- hSeparatorNew
......@@ -77,11 +77,7 @@ main = do
Stopped -> reactiveValueWrite statConfSensitiveRV True
-}
boardStatusEP <- getEPfromRV boardStatusRV
reactiveValueOnCanRead playRV $
reactiveValueRead boardStatusRV >>=
\case
Running -> reactiveValueWrite boardStatusRV Running
Stopped -> reactiveValueWrite boardStatusRV Running
reactiveValueOnCanRead playRV $ reactiveValueWrite boardStatusRV Running
reactiveValueOnCanRead stopRV $ reactiveValueWrite boardStatusRV Stopped
boardMap <- reactiveValueRead boardMapRV
layerMap <- reactiveValueRead layerMapRV
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment