Support loading and saving to JSON, step 5
This commit is contained in:
parent
c8e5de868c
commit
6440550f48
2 changed files with 40 additions and 1 deletions
|
@ -36,6 +36,7 @@ module Vervis
|
||||||
, Project (..)
|
, Project (..)
|
||||||
, Vervis ()
|
, Vervis ()
|
||||||
, runVervis
|
, runVervis
|
||||||
|
, saveState
|
||||||
, Server (..)--TODO remove this type later...
|
, Server (..)--TODO remove this type later...
|
||||||
, subdirs
|
, subdirs
|
||||||
, lastChange
|
, lastChange
|
||||||
|
@ -46,7 +47,7 @@ where
|
||||||
|
|
||||||
import Control.Monad (join)
|
import Control.Monad (join)
|
||||||
import Control.Monad.Fix (MonadFix)
|
import Control.Monad.Fix (MonadFix)
|
||||||
import Control.Monad.IO.Class (MonadIO)
|
import Control.Monad.IO.Class
|
||||||
import Control.Monad.Trans.RWS (RWST (..))
|
import Control.Monad.Trans.RWS (RWST (..))
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.CaseInsensitive (CI)
|
import Data.CaseInsensitive (CI)
|
||||||
|
@ -61,15 +62,43 @@ import Data.Hourglass
|
||||||
import Data.JsonState
|
import Data.JsonState
|
||||||
import Data.Maybe (fromMaybe, mapMaybe)
|
import Data.Maybe (fromMaybe, mapMaybe)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
import Data.Time.Units
|
||||||
import GHC.Generics
|
import GHC.Generics
|
||||||
import System.Directory.Tree hiding (name, file, err)
|
import System.Directory.Tree hiding (name, file, err)
|
||||||
import System.FilePath ((</>))
|
import System.FilePath ((</>))
|
||||||
import System.Hourglass (dateCurrent)
|
import System.Hourglass (dateCurrent)
|
||||||
|
|
||||||
|
import qualified Control.Monad.Trans.RWS as RWS
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
import qualified Data.HashMap.Lazy as M
|
import qualified Data.HashMap.Lazy as M
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
|
||||||
|
-- | Fetch the value of the environment.
|
||||||
|
ask :: Vervis (VervisEnv)
|
||||||
|
ask = Vervis RWS.ask
|
||||||
|
|
||||||
|
-- | Retrieve a function of the current environment.
|
||||||
|
asks :: (VervisEnv -> a) -> Vervis a
|
||||||
|
asks = Vervis . RWS.asks
|
||||||
|
|
||||||
|
-- | Fetch the current value of the state within the monad.
|
||||||
|
get :: Vervis (VervisState)
|
||||||
|
get = Vervis RWS.get
|
||||||
|
|
||||||
|
-- | Get a specific component of the state, using a projection function
|
||||||
|
-- supplied.
|
||||||
|
gets :: (VervisState -> a) -> Vervis a
|
||||||
|
gets = Vervis . RWS.gets
|
||||||
|
|
||||||
|
-- | @'put' s@ sets the state within the monad to @s@.
|
||||||
|
put :: VervisState -> Vervis ()
|
||||||
|
put = Vervis . RWS.put
|
||||||
|
|
||||||
|
-- | @'modify' f@ is an action that updates the state to the result of
|
||||||
|
-- applying @f@ to the current state.
|
||||||
|
modify :: (VervisState -> VervisState) -> Vervis ()
|
||||||
|
modify = Vervis . RWS.modify
|
||||||
|
|
||||||
instance (CI.FoldCase a, FromJSON a) => FromJSON (CI a) where
|
instance (CI.FoldCase a, FromJSON a) => FromJSON (CI a) where
|
||||||
parseJSON v = CI.mk <$> parseJSON v
|
parseJSON v = CI.mk <$> parseJSON v
|
||||||
|
|
||||||
|
@ -197,6 +226,7 @@ instance FromJSON Project
|
||||||
data VervisEnv = VervisEnv
|
data VervisEnv = VervisEnv
|
||||||
{ veName :: Text
|
{ veName :: Text
|
||||||
, veDir :: FilePath
|
, veDir :: FilePath
|
||||||
|
, veSave :: VervisState -> Vervis ()
|
||||||
}
|
}
|
||||||
|
|
||||||
data VervisState = VervisState
|
data VervisState = VervisState
|
||||||
|
@ -232,13 +262,21 @@ runVervis name file dir comp = do
|
||||||
Left (False, err) -> error $ "Loading JSON state failed: " ++ err
|
Left (False, err) -> error $ "Loading JSON state failed: " ++ err
|
||||||
Left (True, err) -> error $ "Parsing JSON state failed: " ++ err
|
Left (True, err) -> error $ "Parsing JSON state failed: " ++ err
|
||||||
Right vstate -> do
|
Right vstate -> do
|
||||||
|
save <- mkSaveState (3 :: Second) file
|
||||||
let venv = VervisEnv
|
let venv = VervisEnv
|
||||||
{ veName = name
|
{ veName = name
|
||||||
, veDir = dir
|
, veDir = dir
|
||||||
|
, veSave = liftIO . save
|
||||||
}
|
}
|
||||||
(a, _s) <- runVervis' venv vstate comp
|
(a, _s) <- runVervis' venv vstate comp
|
||||||
return a
|
return a
|
||||||
|
|
||||||
|
saveState :: Vervis ()
|
||||||
|
saveState = do
|
||||||
|
save <- asks veSave
|
||||||
|
vstate <- get
|
||||||
|
save vstate
|
||||||
|
|
||||||
data Server = Server
|
data Server = Server
|
||||||
{ serverName :: Text
|
{ serverName :: Text
|
||||||
, serverDir :: FilePath
|
, serverDir :: FilePath
|
||||||
|
|
|
@ -39,6 +39,7 @@ library
|
||||||
, hashable
|
, hashable
|
||||||
, hourglass
|
, hourglass
|
||||||
, text >=1
|
, text >=1
|
||||||
|
, time-units
|
||||||
, transformers >=0.4.2
|
, transformers >=0.4.2
|
||||||
, unordered-containers >=0.2.5
|
, unordered-containers >=0.2.5
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
|
|
Loading…
Reference in a new issue