diff --git a/salak.cabal b/salak.cabal --- a/salak.cabal +++ b/salak.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: salak -version: 0.2.2 +version: 0.2.3 license: BSD3 license-file: LICENSE copyright: (c) 2018 Daniel YU @@ -27,6 +27,7 @@ Data.Salak.Aeson Data.Salak.Yaml Data.Salak.Operation + Data.Salak.Dynamic default-language: Haskell2010 ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures build-depends: @@ -34,8 +35,10 @@ base >=4.7 && <5, directory <1.4, filepath <1.5, + menshen <0.1, mtl <2.3, scientific <0.4, + stm <2.6, text <1.3, transformers <0.6, unordered-containers <0.3, @@ -50,6 +53,7 @@ Data.Salak Data.Salak.Aeson Data.Salak.CommandLine + Data.Salak.Dynamic Data.Salak.Environment Data.Salak.Operation Data.Salak.Types @@ -64,8 +68,10 @@ directory <1.4, filepath <1.5, hspec ==2.*, + menshen <0.1, mtl <2.3, scientific <0.4, + stm <2.6, text <1.3, transformers <0.6, unordered-containers <0.3, diff --git a/src/Data/Salak.hs b/src/Data/Salak.hs --- a/src/Data/Salak.hs +++ b/src/Data/Salak.hs @@ -36,7 +36,6 @@ -- * Types , Property(..) , Properties(..) - , Key , FromProperties(..) , Return -- * Properties Loader Helper @@ -46,12 +45,15 @@ , FileName -- * Operations , module Data.Salak.Operation + -- * Dynamic Load + , module Data.Salak.Dynamic ) where import Control.Monad.Trans.Class (lift) import Data.Maybe import Data.Salak.Aeson import Data.Salak.CommandLine +import Data.Salak.Dynamic import Data.Salak.Environment import Data.Salak.Operation import Data.Salak.Types diff --git a/src/Data/Salak/Aeson.hs b/src/Data/Salak/Aeson.hs --- a/src/Data/Salak/Aeson.hs +++ b/src/Data/Salak/Aeson.hs @@ -7,7 +7,9 @@ import Control.Monad.IO.Class import Control.Monad.State import Data.Aeson +import Data.Aeson.Types import qualified Data.HashMap.Strict as M +import Data.Menshen import Data.Salak.Types import Data.Vector (toList) @@ -24,6 +26,9 @@ jsonToProperties :: Value -> Properties jsonToProperties = (`makePropertiesFromJson` empty) + +instance HasValid Parser where + invalid = fail . toI18n fromArray v = foldl g3 ([],[]) $ go . jsonToProperties <$> toList v where diff --git a/src/Data/Salak/Dynamic.hs b/src/Data/Salak/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Salak/Dynamic.hs @@ -0,0 +1,56 @@ +module Data.Salak.Dynamic( + LoaderT + , load + , runLoader + , askSetProperties + ) where + +import Control.Concurrent.STM.TVar +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.State +import Control.Monad.STM +import qualified Data.HashMap.Strict as M +import Data.Salak.Operation +import Data.Salak.Types +import Data.Text (Text) + +type Loader = (IO Properties, Properties -> IO ()) + +type LoaderT = StateT Loader + +dynamicLoader :: Properties -> IO Loader +dynamicLoader mp = do + m <- newTVarIO mp + return (readTVarIO m,\np -> atomically $ modifyTVar' m (go np)) + where + go (Properties [] m1) (Properties p m2) = Properties p (gm m1 m2) + go (Properties p m1) (Properties _ m2) = Properties p (gm m1 m2) + gm [] m = m + gm [m] [n] = [M.unionWithKey (\_ -> go) m n] + gm m _ = m + +-- | Load default properties +load :: (FromProperties a, MonadIO m, Show a) => Text -> LoaderT m (IO a) +load key = do + (iop, ios) <- get + p <- liftIO iop + v <- liftIO $ newTVarIO $ p .>> key + let go np = do + ios np + p' <- iop + let a = p' .>> key + atomically $ writeTVar v a + put (iop, go) + return (readTVarIO v) + +-- | Run loader +runLoader :: MonadIO m => Properties -> LoaderT m a -> m a +runLoader p a = do + l <- liftIO $ dynamicLoader p + fst <$> runStateT a l + +-- | Ask properties setter. +askSetProperties :: MonadIO m => LoaderT m (Properties -> m ()) +askSetProperties = do + (_, ios) <- get + return $ liftIO . ios diff --git a/src/Data/Salak/Types.hs b/src/Data/Salak/Types.hs --- a/src/Data/Salak/Types.hs +++ b/src/Data/Salak/Types.hs @@ -12,6 +12,7 @@ import qualified Data.HashMap.Strict as M import Data.Int import Data.Maybe +import Data.Menshen import Data.Scientific import Data.String import Data.Text (Text) @@ -123,6 +124,9 @@ -- | Return of `FromProperties` type Return = Either ErrResult data ErrResult = EmptyKey Text | Fail String deriving Show + +instance HasValid Return where + invalid = Left . Fail . toI18n -- | Convert `Properties` to Haskell value. class FromProperties a where diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -18,8 +18,9 @@ spec :: Spec spec = do - describe "Data.Salak.Types" specProperty - describe "Data.Salak" specProperties + describe "Data.Salak.Types" specProperty + describe "Data.Salak" specProperties + describe "Data.Salak.Dynamic" specDynamic shouldFail :: (Show a, Eq a) => a -> a -> Expectation shouldFail f a = (f `shouldBe` a) `shouldThrow` anyErrorCall @@ -122,6 +123,19 @@ (p .>> "array" :: Maybe [String]) `shouldBe` Just ["a","b"] (p .>> "array" :: Maybe [Int]) `shouldFail` Nothing (p .>> "array" :: Maybe String) `shouldFail` Nothing + +specDynamic = do + context "Dynamic" $ do + it "dynamic load" $ do + p <- defaultPropertiesWithFile "salak.yml" + (c,s) <- runLoader p $ (,) <$> load "config" <*> askSetProperties + c1 <- c + s $ insert ["config","name"] "world" empty + c2 <- c + name c1 `shouldBe` "hello" + name c2 `shouldBe` "world" + dir c1 `shouldBe` dir c2 + ext c1 `shouldBe` ext c2 diff --git a/test/salak.yml b/test/salak.yml --- a/test/salak.yml +++ b/test/salak.yml @@ -1,3 +1,9 @@ array: - a - b +hello: + world + +config: + name: hello + dir: /root