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 ()