]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Configuration.hs
Multiple layer internals done. Translator not finished.
[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.Auxiliary
12 import RMCA.GUI.Board
13 import RMCA.Layer.Layer
14 import RMCA.Semantics
15 import Text.Read
16
17 type InstrumentNo = Int
18
19 data BoardConf = BoardConf { confLayer :: (Layer,InstrumentNo)
20 , confBoard :: BoardInit
21 , confTempo :: Tempo
22 } deriving(Read,Show)
23
24 newtype BoardInit = BoardInit { toList :: [(Pos,Cell)] } deriving(Show,Read)
25
26 mkInit :: Board -> BoardInit
27 mkInit = BoardInit . filter (uncurry (&&) . BF.bimap onBoard notDef) . assocs
28 where notDef (Inert,1) = False
29 notDef _ = True
30
31 boardInit :: BoardInit -> Board
32 boardInit = makeBoard . toList
33
34 saveConfiguration :: ( ReactiveValueRead tempo Tempo IO
35 , ReactiveValueRead layer Layer IO
36 , ReactiveValueRead board Board IO
37 , ReactiveValueRead instr InstrumentNo IO) =>
38 FilePath -> tempo -> layer -> board -> instr -> IO ()
39 saveConfiguration fp t l b i = do
40 tempo <- reactiveValueRead t
41 layer <- reactiveValueRead l
42 board <- reactiveValueRead b
43 instr <- reactiveValueRead i
44 let bc = BoardConf { confLayer = (layer,instr)
45 , confTempo = tempo
46 , confBoard = mkInit board
47 }
48 catch (writeFile fp $ show bc) (\(_ :: IOError) -> errorSave)
49
50 loadConfiguration :: ( ReactiveValueWrite tempo Tempo IO
51 , ReactiveValueWrite layer Layer IO
52 , ReactiveValueWrite cell GUICell IO
53 , ReactiveValueWrite instr InstrumentNo IO) =>
54 FilePath -> tempo -> layer
55 -> Array Pos cell -> instr -> IO ()
56 loadConfiguration fp t l arr i = do
57 conf <- readMaybe <$> readFile fp
58 if isNothing conf then errorLoad else
59 do let BoardConf { confLayer = (layer,instr)
60 , confTempo = tempo
61 , confBoard = (BoardInit board)
62 } = fromJust conf
63 reactiveValueWrite t tempo
64 reactiveValueWrite l layer
65 mapM_ (\rv -> catch (reactiveValueWrite rv inertCell)
66 (\(_ :: ErrorCall) -> return ())) $ elems arr
67 mapM_ (\(p,(a,r)) -> reactiveValueWrite (arr ! toGUICoords p) $
68 inertCell { cellAction = a
69 , repeatCount = r
70 }) board
71 reactiveValueWrite i instr
72
73 errorLoad :: IO ()
74 errorLoad = messageDialogNewWithMarkup Nothing [] MessageError ButtonsClose
75 "Error loading the configuration file!" >>= widgetShow
76
77 errorSave :: IO ()
78 errorSave = messageDialogNewWithMarkup Nothing [] MessageError ButtonsClose
79 "Error saving the configuration file!" >>= widgetShow
80
81 handleSaveLoad :: ( ReactiveValueRead save () IO
82 , ReactiveValueRead load () IO
83 , ReactiveValueReadWrite instr InstrumentNo IO
84 , ReactiveValueReadWrite layer Layer IO
85 , ReactiveValueRead board Board IO
86 , ReactiveValueReadWrite tempo Tempo IO
87 , ReactiveValueWrite cell GUICell IO) =>
88 tempo -> board -> layer -> instr
89 -> Array Pos cell -> save -> load -> IO ()
90 handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV confSaveRV confLoadRV = do
91 fcs <- fileChooserDialogNew (Just "Save configuration") Nothing
92 FileChooserActionSave [("Cancel",ResponseCancel),("Ok",ResponseOk)]
93 reactFilt <- fileFilterNew
94 fileFilterAddPattern reactFilt "*.react"
95 fileFilterSetName reactFilt "RMCA conf files."
96 fileChooserAddFilter fcs reactFilt
97
98 fcl <- fileChooserDialogNew (Just "Load configuration") Nothing
99 FileChooserActionOpen [("Cancel",ResponseCancel),("Ok",ResponseOk)]
100 fileChooserAddFilter fcl reactFilt
101
102 reactiveValueOnCanRead confSaveRV $ postGUIAsync $ do
103 widgetShowAll fcs
104 let respHandle ResponseOk =
105 fileChooserGetFilename fcs >>= fromMaybeM_ .
106 fmap (\f -> saveConfiguration f tempoRV layerRV boardRV instrRV)
107 respHandle _ = return ()
108
109 onResponse fcs (\r -> respHandle r >> widgetHide fcs)
110 return ()
111
112 reactiveValueOnCanRead confLoadRV $ postGUIAsync $ do
113 widgetShowAll fcl
114 let respHandle ResponseOk =
115 fileChooserGetFilename fcl >>= fromMaybeM_ .
116 fmap (\f -> loadConfiguration f tempoRV layerRV pieceArrRV instrRV)
117 respHandle _ = return ()
118
119 onResponse fcl (\r -> respHandle r >> widgetHide fcl)
120 return ()