Use the LiBro monad for Config-ured effects

lib/LiBro/Base.hs

@@ -0,0 +1,18 @@
+-- |  Basic definitions.
+module LiBro.Base where
+
+import LiBro.Config
+import Control.Monad.Reader
+
+newtype LiBro a = LiBro
+  { unLiBro :: ReaderT Config IO a
+  } deriving  ( Functor
+              , Applicative
+              , Monad
+              , MonadReader Config
+              , MonadFail
+              , MonadIO
+              )
+
+runLiBro :: Config -> LiBro a -> IO a
+runLiBro config = flip runReaderT config . unLiBro

lib/LiBro/Control.hs

@@ -1,10 +1,12 @@
 -- |  Controlling the LiBro data flow.
 module LiBro.Control where
 
+import LiBro.Base
 import LiBro.Config
 import LiBro.Data
 import LiBro.Data.Storage
 import Control.Concurrent
+import Control.Monad.Reader
 
 -- |  Represents a blocking action because the system is loading
 --    or saving data.
@@ -15,22 +17,23 @@ data Blocking
 
 -- |  Initially load data and put it into the shared state.
 --    Expects the given 'MVar' to be empty.
-initData :: Config -> MVar Blocking -> MVar LiBroData -> IO ()
-initData config blocking libroData = do
-  putMVar blocking Reading
-  putMVar libroData =<< loadData config
-  _ <- takeMVar blocking
+initData :: MVar Blocking -> MVar LiBroData -> LiBro ()
+initData blocking libroData = do
+  liftIO $ putMVar blocking Reading
+  ld <- loadData
+  _ <- liftIO $ putMVar libroData ld
+  _ <- liftIO $ takeMVar blocking
   return ()
 
 -- |  Try to store shared state data. Expects the given blocking 'MVar'
 --    to be empty. Iff not, returns 'False'.
-saveData :: Config -> MVar Blocking -> MVar LiBroData -> IO Bool
-saveData config blocking libroData = do
-  isBlocked <- not <$> isEmptyMVar blocking
+saveData :: MVar Blocking -> MVar LiBroData -> LiBro Bool
+saveData blocking libroData = do
+  isBlocked <- not <$> liftIO (isEmptyMVar blocking)
   if isBlocked
     then return False
     else do
-      putMVar blocking Writing
-      storeData config =<< readMVar libroData
-      _ <- takeMVar blocking
+      liftIO $ putMVar blocking Writing
+      storeData =<< liftIO (readMVar libroData)
+      _ <- liftIO $ takeMVar blocking
       return True

lib/LiBro/Data/Storage.hs

@@ -18,6 +18,7 @@ module LiBro.Data.Storage
   , loadData
   ) where
 
+import LiBro.Base
 import LiBro.Config
 import LiBro.Data
 import LiBro.Data.SafeText
@@ -28,6 +29,7 @@ import qualified Data.Map as M
 import Data.Tree
 import Data.Csv
 import qualified Data.ByteString.Char8 as B
+import Control.Monad.Reader
 import GHC.Generics
 import System.FilePath
 import System.Directory
@@ -97,56 +99,55 @@ taskRecordsToTasks pmap trs =
           }
 
 -- |  Store 'Person's at the configured storage space
---    via 'Config'.
-storePersons :: Config -> Persons -> IO ()
-storePersons conf pmap = do
-  let sconf = storage conf
-      fp    = directory sconf </> personFile sconf
-  storeAsXlsx fp $ M.elems pmap
+storePersons :: Persons -> LiBro ()
+storePersons pmap = do
+  sconf <- asks storage
+  let fp = directory sconf </> personFile sconf
+  liftIO $ storeAsXlsx fp $ M.elems pmap
 
--- |  Load a list of 'Person's from the configured storage space
---    via 'Config'. Returns empty data if no input file was found.
-loadPersons :: Config -> IO Persons
-loadPersons conf = do
-  let sconf = storage conf
-      fp    = directory sconf </> personFile sconf
-  exists <- doesFileExist fp
+-- |  Load a list of 'Person's from the configured storage space.
+--    Returns empty data if no input file was found.
+loadPersons :: LiBro Persons
+loadPersons = do
+  sconf <- asks storage
+  let fp = directory sconf </> personFile sconf
+  exists <- liftIO $ doesFileExist fp
   if not exists then return M.empty
     else do
-      Right prs <- loadFromXlsx fp
+      Right prs <- liftIO $ loadFromXlsx fp
       return $ personMap prs
 
--- |  Store 'Tasks' at the configured storage space via 'Config'.
-storeTasks :: Config -> Tasks -> IO ()
-storeTasks conf ts = do
-  let sconf = storage conf
-      fp    = directory sconf </> tasksFile sconf
-  storeAsXlsx fp $ tasksToTaskRecords ts
+-- |  Store 'Tasks' at the configured storage space.
+storeTasks :: Tasks -> LiBro ()
+storeTasks ts = do
+  sconf <- asks storage
+  let fp = directory sconf </> tasksFile sconf
+  liftIO $ storeAsXlsx fp $ tasksToTaskRecords ts
 
--- |  Load 'Tasks' from the configured storage space via 'Config'.
+-- |  Load 'Tasks' from the configured storage space.
 --    Needs an additional 'Data.Map.Map' to find 'Person's for given
 --    person ids ('Int'). Returns empty data if no input file was found.
-loadTasks :: Config -> Persons -> IO Tasks
-loadTasks conf pmap = do
-  let sconf = storage conf
-      fp    = directory sconf </> tasksFile sconf
-  exists <- doesFileExist fp
+loadTasks :: Persons -> LiBro Tasks
+loadTasks pmap = do
+  sconf <- asks storage
+  let fp = directory sconf </> tasksFile sconf
+  exists <- liftIO $ doesFileExist fp
   if not exists then return []
     else do
-      Right records <- loadFromXlsx fp
+      Right records <- liftIO $ loadFromXlsx fp
       return $ taskRecordsToTasks pmap records
 
--- |  Store a complete dataset at the 'Config'ured file system
+-- |  Store a complete dataset at the configured file system
 --    locations.
-storeData :: Config -> LiBroData -> IO ()
-storeData conf ld = do
-  storePersons  conf (persons ld)
-  storeTasks    conf (tasks ld)
+storeData :: LiBroData -> LiBro ()
+storeData ld = do
+  storePersons  $ persons ld
+  storeTasks    $ tasks ld
 
--- |  Load a complete dataset from the 'Config'ured file system
+-- |  Load a complete dataset from the configured file system
 --    locations. Returns empty data if no input files were found.
-loadData :: Config -> IO LiBroData
-loadData conf = do
-  pmap <- loadPersons conf
-  ts   <- loadTasks   conf pmap
+loadData :: LiBro LiBroData
+loadData = do
+  pmap <- loadPersons
+  ts   <- loadTasks pmap
   return $ LBS pmap ts

libro-backend.cabal

@@ -33,8 +33,10 @@ common consumer
 library
   import:             basic
   default-extensions: OverloadedStrings
+                    , GeneralizedNewtypeDeriving
                     , DeriveGeneric
-  exposed-modules:    LiBro.Config
+  exposed-modules:    LiBro.Base
+                    , LiBro.Config
                     , LiBro.Data
                     , LiBro.Data.Storage
                     , LiBro.Data.SafeText