src/RMCA/Configuration.hs

   1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, PartialTypeSignatures,
   2              ScopedTypeVariables #-}
   3
   4 module RMCA.Configuration where
   5
   6 import           Control.Arrow
   7 import           Control.Exception
   8 import           Data.Array
   9 import qualified Data.IntMap         as M
  10 import           Data.List
  11 import           Data.Maybe
  12 import           Data.ReactiveValue
  13 import           Graphics.UI.Gtk
  14 import           RMCA.Auxiliary
  15 import           RMCA.GUI.Board
  16 import           RMCA.GUI.MultiBoard
  17 import           RMCA.Layer.Layer
  18 import           RMCA.Semantics
  19 import           Text.Read
  20
  21 type InstrumentNo = Int
  22
  23 data BoardConf = BoardConf { confLayers :: [(BoardInit,Layer,InstrumentNo)]
  24                            , confTempo  :: Tempo
  25                            } deriving(Read,Show)
  26
  27 newtype BoardInit = BoardInit { toList :: [(Pos,Cell)] } deriving(Show,Read)
  28
  29 mkInit :: Board -> BoardInit
  30 mkInit = BoardInit . filter (uncurry (&&) . (onBoard *** notDef)) . assocs
  31   where notDef (Inert,1) = False
  32         notDef _ = True
  33
  34 boardInit :: BoardInit -> Board
  35 boardInit = makeBoard . toList
  36
  37 saveConfiguration :: ( ReactiveValueRead tempo Tempo IO
  38                      , ReactiveValueRead layer (M.IntMap Layer) IO
  39                      , ReactiveValueRead board (M.IntMap Board) IO
  40                      , ReactiveValueRead instr (M.IntMap InstrumentNo) IO) =>
  41                      FilePath -> tempo -> layer -> board -> instr -> IO ()
  42 saveConfiguration fp t l b i = do
  43   tempo  <- reactiveValueRead t
  44   layers <- M.elems <$> reactiveValueRead l
  45   boards <- map mkInit <$> M.elems <$> reactiveValueRead b
  46   instrs <- M.elems <$> reactiveValueRead i
  47   let bc = BoardConf { confLayers = zip3 boards layers instrs
  48                      , confTempo = tempo
  49                      }
  50   catch (writeFile fp $ show bc) (\(_ :: IOError) -> errorSave)
  51
  52 -- Current solution to delete all existing layers is to write to the
  53 -- rm button, which is not that nice.
  54 loadConfiguration :: ( ReactiveValueWrite tempo Tempo IO
  55                      , ReactiveValueWrite layer (M.IntMap Layer) IO
  56                      , ReactiveValueWrite cell GUICell IO
  57                      , ReactiveValueWrite instr (M.IntMap InstrumentNo) IO
  58                      , ReactiveValueWrite addLayer () IO
  59                      , ReactiveValueWrite rmLayer () IO
  60                      , ReactiveValueRead boards (M.IntMap (Array Pos cell)) IO) =>
  61                      FilePath -> tempo -> layer
  62                   -> boards -> instr -> addLayer -> rmLayer -> IO ()
  63 loadConfiguration fp t l arrs i addLayer rmLayer = do
  64   conf <- readMaybe <$> readFile fp
  65   if isNothing conf then errorLoad else
  66     do let BoardConf { confLayers = cl
  67                      , confTempo = tempo
  68                      } = fromJust conf
  69            (boards,layers,instrs) = unzip3 cl
  70            layNum = length cl
  71        sequence_ $ replicate maxLayers $ reactiveValueWrite rmLayer ()
  72        sequence_ $ replicate layNum $ reactiveValueWrite addLayer ()
  73        reactiveValueWrite t tempo
  74        reactiveValueWrite l $ M.fromList $ zip [1..] layers
  75        reactiveValueWrite i $ M.fromList $ zip [1..] instrs
  76        cellArrs <- reactiveValueRead arrs
  77        mapM_ (\(arr,board) ->
  78                 do mapM_ (\rv -> catch (reactiveValueWrite rv inertCell)
  79                            (\(_ :: ErrorCall) -> return ())) $ elems arr
  80                    mapM_ (\(p,(a,r)) -> reactiveValueWrite (arr ! toGUICoords p) $
  81                                         inertCell { cellAction = a
  82                                                   , repeatCount = r
  83                                                   }) board
  84              ) $ M.intersectionWith (,) cellArrs
  85          $ M.fromList $ zip [1..] $ map (\(BoardInit b) -> b) boards
  86
  87 errorLoad :: IO ()
  88 errorLoad =  messageDialogNewWithMarkup Nothing [] MessageError ButtonsClose
  89              "Error loading the configuration file!" >>= widgetShow
  90
  91 errorSave :: IO ()
  92 errorSave =  messageDialogNewWithMarkup Nothing [] MessageError ButtonsClose
  93              "Error saving the configuration file!" >>= widgetShow
  94
  95 handleSaveLoad :: ( ReactiveValueReadWrite tempo Tempo IO
  96                   , ReactiveValueReadWrite layer (M.IntMap Layer) IO
  97                   , ReactiveValueWrite cell GUICell IO
  98                   , ReactiveValueReadWrite instr (M.IntMap InstrumentNo) IO
  99                   , ReactiveValueWrite addLayer () IO
 100                   , ReactiveValueWrite rmLayer () IO
 101                   , ReactiveValueRead boards (M.IntMap (Array Pos cell)) IO
 102                   , ReactiveValueRead load () IO
 103                   , ReactiveValueRead save () IO
 104                   , ReactiveValueRead board (M.IntMap Board) IO) =>
 105                   tempo -> board -> layer -> instr
 106                -> boards -> addLayer -> rmLayer -> save -> load -> IO ()
 107 --handleSaveLoad :: _
 108 handleSaveLoad tempoRV boardRV layerRV instrRV pieceArrRV addLayerRV rmLayerRV confSaveRV confLoadRV = do
 109   fcs <- fileChooserDialogNew (Just "Save configuration") Nothing
 110          FileChooserActionSave [("Cancel",ResponseCancel),("Ok",ResponseOk)]
 111   reactFilt <- fileFilterNew
 112   fileFilterAddPattern reactFilt "*.react"
 113   fileFilterSetName reactFilt "RMCA conf files."
 114   fileChooserAddFilter fcs reactFilt
 115
 116   fcl <- fileChooserDialogNew (Just "Load configuration") Nothing
 117          FileChooserActionOpen [("Cancel",ResponseCancel),("Ok",ResponseOk)]
 118   fileChooserAddFilter fcl reactFilt
 119
 120   reactiveValueOnCanRead confSaveRV $ postGUIAsync $ do
 121     widgetShowAll fcs
 122     let respHandle ResponseOk =
 123           fileChooserGetFilename fcs >>= fromMaybeM_ .
 124           fmap (\f -> saveConfiguration f tempoRV layerRV boardRV instrRV)
 125         respHandle _ = return ()
 126
 127     onResponse fcs (\r -> respHandle r >> widgetHide fcs)
 128     return ()
 129
 130   reactiveValueOnCanRead confLoadRV $ postGUIAsync $ do
 131     widgetShowAll fcl
 132     let respHandle ResponseOk =
 133           fileChooserGetFilename fcl >>= fromMaybeM_ .
 134           fmap (\f -> loadConfiguration f tempoRV layerRV pieceArrRV instrRV
 135                       addLayerRV rmLayerRV )
 136         respHandle _ = return ()
 137
 138     onResponse fcl (\r -> respHandle r >> widgetHide fcl)
 139
 140     return ()