]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Configuration.hs
Hlint suggestions.
[tmp/julm/arpeggigon.git] / src / RMCA / Configuration.hs
1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables #-}
2
3 module RMCA.Configuration where
4
5 import Control.Exception
6 import Data.Array
7 import qualified Data.Bifunctor as BF
8 import Data.Maybe
9 import Data.ReactiveValue
10 import Graphics.UI.Gtk
11 import RMCA.GUI.Board
12 import RMCA.Layer.Layer
13 import RMCA.Semantics
14 import Text.Read
15
16 type InstrumentNo = Int
17
18 data BoardConf = BoardConf { confLayer :: (Layer,InstrumentNo)
19 , confBoard :: BoardInit
20 , confTempo :: Tempo
21 } deriving(Read,Show)
22
23 newtype BoardInit = BoardInit { toList :: [(Pos,Cell)] } deriving(Show,Read)
24
25 mkInit :: Board -> BoardInit
26 mkInit = BoardInit . filter (uncurry (&&) . BF.bimap onBoard notDef) . assocs
27 where notDef (Inert,1) = False
28 notDef _ = True
29
30 boardInit :: BoardInit -> Board
31 boardInit = makeBoard . toList
32
33 saveConfiguration :: ( ReactiveValueRead tempo Tempo IO
34 , ReactiveValueRead layer Layer IO
35 , ReactiveValueRead board Board IO
36 , ReactiveValueRead instr InstrumentNo IO) =>
37 FilePath -> tempo -> layer -> board -> instr -> IO ()
38 saveConfiguration fp t l b i = do
39 tempo <- reactiveValueRead t
40 layer <- reactiveValueRead l
41 board <- reactiveValueRead b
42 instr <- reactiveValueRead i
43 let bc = BoardConf { confLayer = (layer,instr)
44 , confTempo = tempo
45 , confBoard = mkInit board
46 }
47 catch (writeFile fp $ show bc) (\(_ :: IOError) -> errorSave)
48
49 loadConfiguration :: ( ReactiveValueWrite tempo Tempo IO
50 , ReactiveValueWrite layer Layer IO
51 , ReactiveValueWrite cell GUICell IO
52 , ReactiveValueWrite instr InstrumentNo IO) =>
53 FilePath -> tempo -> layer
54 -> Array Pos cell -> instr -> IO ()
55 loadConfiguration fp t l arr i = do
56 conf <- readMaybe <$> readFile fp
57 if isNothing conf then errorLoad else
58 do let BoardConf { confLayer = (layer,instr)
59 , confTempo = tempo
60 , confBoard = (BoardInit board)
61 } = fromJust conf
62 reactiveValueWrite t tempo
63 reactiveValueWrite l layer
64 mapM_ (\rv -> catch (reactiveValueWrite rv inertCell)
65 (\(_ :: ErrorCall) -> return ())) $ elems arr
66 mapM_ (\(p,(a,r)) -> reactiveValueWrite (arr ! toGUICoords p) $
67 inertCell { cellAction = a
68 , repeatCount = r
69 }) board
70 reactiveValueWrite i instr
71
72 errorLoad :: IO ()
73 errorLoad = messageDialogNewWithMarkup Nothing [] MessageError ButtonsClose
74 "Error loading the configuration file!" >>= widgetShow
75
76 errorSave :: IO ()
77 errorSave = messageDialogNewWithMarkup Nothing [] MessageError ButtonsClose
78 "Error saving the configuration file!" >>= widgetShow