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