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