salak 0.1.11 → 0.2.0
raw patch · 16 files changed
+675/−996 lines, 16 filesdep +aeson-prettydep +bytestringdep −attoparsecdep −containersdep −data-defaultdep ~QuickCheckdep ~aesondep ~base
Dependencies added: aeson-pretty, bytestring
Dependencies removed: attoparsec, containers, data-default, menshen, mtl, pqueue, transformers
Dependency ranges changed: QuickCheck, aeson, base, directory, filepath, scientific, text, unordered-containers, vector, yaml
Files
- README.md +2/−42
- salak.cabal +70/−71
- src/Data/Salak.hs +143/−0
- src/Data/Salak/Aeson.hs +47/−0
- src/Data/Salak/CommandLine.hs +35/−0
- src/Data/Salak/Environment.hs +18/−0
- src/Data/Salak/Types.hs +239/−0
- src/Data/Salak/Yaml.hs +11/−0
- src/Salak.hs +0/−206
- src/Salak/Dynamic.hs +0/−71
- src/Salak/Env.hs +0/−34
- src/Salak/Json.hs +0/−38
- src/Salak/Prop.hs +0/−240
- src/Salak/Types.hs +0/−204
- test/Spec.hs +110/−84
- test/salak.yml +0/−6
README.md view
@@ -1,47 +1,7 @@ # salak -[](https://hackage.haskell.org/package/salak)-[](http://stackage.org/lts/package/salak)-[](http://stackage.org/nightly/package/salak)+[](https://hackage.haskell.org/package/salak) [](https://travis-ci.org/leptonyu/salak) -Configuration Loader in Haskell.--This library default a standard configuration load process. It can load properties from `CommandLine`, `Environment`,-`JSON value` and `Yaml` files. They all load to the same format `SourcePack`. Earler property source has higher order-to load property. For example:--```-CommandLine: --package.a.enabled=true-Environment: PACKAGE_A_ENABLED: false--lookup "package.a.enabled" properties => Just True-```--`CommandLine` has higher order then `Environment`, for the former load properties earler then later.--Usage:--```Haskell-data Config = Config- { name :: Text- , dir :: Maybe Text- , ext :: Int- } deriving (Eq, Show)--instance FromProp Config where- fromProp = Config- <$> "user"- <*> "pwd"- <*> "ext" .?= 1--main = do- c :: Config <- defaultLoadSalak def $ require ""- print c-```--```-λ> c-Config {name = "daniel", dir = Nothing, ext = 1}-```+Configuration Loader for Production in Haskell.
salak.cabal view
@@ -1,79 +1,78 @@ cabal-version: 1.12-name: salak-version: 0.1.11-license: BSD3-license-file: LICENSE-copyright: (c) 2018 Daniel YU-maintainer: Daniel YU <leptonyu@gmail.com>-author: Daniel YU-homepage: https://github.com/leptonyu/salak#readme-synopsis: Configuration Loader-category: Library-build-type: Simple++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 65d137fa16b84c27133c76282e7859306d30f334f45be6cb7332a144552ef7ce++name: salak+version: 0.2.0+synopsis: Configuration Loader+description: Configuration Loader for Production in Haskell+category: Library+homepage: https://github.com/leptonyu/salak#readme+author: Daniel YU+maintainer: Daniel YU <leptonyu@gmail.com>+copyright: (c) 2018 Daniel YU+license: BSD3+license-file: LICENSE+build-type: Simple extra-source-files: README.md test/salak.yml library- exposed-modules:- Salak- hs-source-dirs: src- other-modules:- Salak.Types- Salak.Env- Salak.Json- Salak.Prop- Salak.Dynamic- default-language: Haskell2010- ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures- build-depends:- aeson <1.5,- attoparsec <0.14,- base >=4.7 && <5,- containers <0.7,- data-default <0.8,- directory <1.4,- filepath <1.5,- menshen <0.1,- mtl <2.3,- pqueue <1.5,- scientific <0.4,- text <1.3,- transformers <0.6,- unordered-containers <0.3,- vector <0.13,- yaml <0.12+ exposed-modules:+ Data.Salak+ other-modules:+ Data.Salak.Types+ Data.Salak.Environment+ Data.Salak.CommandLine+ Data.Salak.Aeson+ Data.Salak.Yaml+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans -fno-warn-missing-signatures+ build-depends:+ aeson+ , base >=4.7 && <5+ , directory+ , filepath+ , scientific+ , text+ , unordered-containers+ , vector+ , yaml+ default-language: Haskell2010 test-suite spec- type: exitcode-stdio-1.0- main-is: Spec.hs- hs-source-dirs: test src- other-modules:- Salak- Salak.Dynamic- Salak.Env- Salak.Json- Salak.Prop- Salak.Types- Paths_salak- default-language: Haskell2010- ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures- build-depends:- QuickCheck <2.14,- aeson <1.5,- attoparsec <0.14,- base >=4.7 && <5,- containers <0.7,- data-default <0.8,- directory <1.4,- filepath <1.5,- hspec ==2.*,- menshen <0.1,- mtl <2.3,- pqueue <1.5,- scientific <0.4,- text <1.3,- transformers <0.6,- unordered-containers <0.3,- vector <0.13,- yaml <0.12+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Data.Salak+ Data.Salak.Aeson+ Data.Salak.CommandLine+ Data.Salak.Environment+ Data.Salak.Types+ Data.Salak.Yaml+ Paths_salak+ hs-source-dirs:+ test+ src+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans -fno-warn-missing-signatures+ build-depends:+ QuickCheck+ , aeson+ , aeson-pretty+ , base >=4.7 && <5+ , bytestring+ , directory+ , filepath+ , hspec ==2.*+ , scientific+ , text+ , unordered-containers+ , vector+ , yaml+ default-language: Haskell2010
+ src/Data/Salak.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module: Data.Salak+-- Copyright: (c) 2018 Daniel YU+-- License: BSD3+-- Maintainer: Daniel YU <leptonyu@gmail.com>+-- Stability: experimental+-- Portability: portable+--+-- Configuration Loader for Production in Haskell.+--+module Data.Salak(+ -- * How to use this library+ -- $use++ -- * Properties Loader+ defaultProperties+ , ParseCommandLine+ , defaultProperties'+ , defaultPropertiesWithFile+ , defaultPropertiesWithFile'+ , empty+ -- * Lookup Properties+ , lookup+ , lookup'+ , toKeys+ -- * Types+ , Property(..)+ , Properties(..)+ , Key+ , FromProperties(..)+ , Return(..)+ -- * Properties Loader Helper+ , insert+ , makePropertiesFromEnvironment+ , defaultParseCommandLine+ , makePropertiesFromCommandLine+ , makePropertiesFromJson+ , makePropertiesFromYaml+ , FileName+ ) where++import Data.Maybe+import Data.Salak.Aeson+import Data.Salak.CommandLine+import Data.Salak.Environment+import Data.Salak.Types+import Data.Salak.Yaml+import Data.Text (Text, unpack)+import Prelude hiding (lookup)+import System.Directory+import System.FilePath ((</>))++-- | Initialize default properties from `CommandLine` and `Environment`.+-- `CommandLine` use default parser.+defaultProperties :: IO Properties+defaultProperties = defaultProperties' defaultParseCommandLine++-- | Initialize default properties from `CommandLine` and `Environment`.+defaultProperties' :: ParseCommandLine -> IO Properties+defaultProperties' dpc+ = makePropertiesFromCommandLine dpc empty+ >>= makePropertiesFromEnvironment++-- | Yaml file name.+type FileName = Text++-- | Initialize default properties from `CommandLine`, `Environment` and `Yaml` files.+-- All these configuration sources has orders, from highest order to lowest order:+--+-- > 1. CommandLine+-- > 2. Environment+-- > 3. Specified Yaml file(file in "salak.config.dir")+-- > 4. Yaml file in current directory+-- > 5. Yaml file in home directory+--+defaultPropertiesWithFile+ :: FileName -- ^ specify default config file name, can reset by config "salak.config.name" from `CommandLine` or `Environment`.+ -> IO Properties+defaultPropertiesWithFile name = defaultPropertiesWithFile' name defaultParseCommandLine++-- | Initialize default properties from `CommandLine`, `Environment` and `Yaml` files.+-- All these configuration sources has orders, from highest order to lowest order:+--+-- > 1. CommandLine+-- > 2. Environment+-- > 3. Specified Yaml file(file in "salak.config.dir")+-- > 4. Yaml file in current directory+-- > 5. Yaml file in home directory+--+defaultPropertiesWithFile'+ :: FileName -- ^ specify default config file name, can reset by config "salak.config.name" from `CommandLine` or `Environment`.+ -> ParseCommandLine -- ^ parser for command line+ -> IO Properties+defaultPropertiesWithFile' name dpc = do+ p <- defaultProperties' dpc+ let n = fromMaybe name $ lookup "salak.config.name" p+ p' = insert (toKeys "salak.config.name") (PStr n) p+ c <- getCurrentDirectory+ h <- getHomeDirectory+ foldl (go n) (return p') [(lookup "salak.config.dir" p, False), (Just c, True), (Just h, True)]+ where+ go _ p (Nothing, _) = p+ go n p (Just d, ok) = let f = d </> unpack n in do+ p' <- p+ b <- doesFileExist f+ if b+ then makePropertiesFromYaml f p'+ else if ok then return p' else error $ "File " ++ f ++ " not found"++-- $use+--+-- | This library default a standard configuration load process. It can load properties from `CommandLine`, `Environment`,+-- `JSON value` and `Yaml` files. They all load to the same format `Properties`. Earler property source has higher order+-- to load property. For example:+--+-- > CommandLine: --package.a.enabled=true+-- > Environment: PACKAGE_A_ENABLED: false+--+-- > lookup "package.a.enabled" properties => Just True+--+-- `CommandLine` has higher order then `Environment`, for the former load properties earler then later.+--+-- Usage:+--+-- > data Config = Config+-- > { name :: Text+-- > , dir :: Maybe Text+-- > , ext :: Int+-- > } deriving (Eq, Show)+-- >+-- > instance FromJSON Config where+-- > parseJSON = withObject "Config" $ \v -> Config+-- > <$> v .: "name"+-- > <*> v .:? "dir"+-- > <*> (fromMaybe 1 <$> v .:? "ext")+--+-- > main = do+-- > p <- defaultPropertiesWithFile "salak.yml"+-- > let Just config = lookup "salak.config" p :: Maybe Config+-- > print config+
+ src/Data/Salak/Aeson.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Salak.Aeson where++import Data.Aeson+import qualified Data.HashMap.Strict as M+import Data.Salak.Types+import Data.Vector (fromList, toList)++-- | Load `Properties` from JSON `Value`+makePropertiesFromJson :: Value -> Properties -> Properties+makePropertiesFromJson Null p = p+makePropertiesFromJson (Bool b) p = insert [] (PBool b) p+makePropertiesFromJson (Number n) p = insert [] (PNum n) p+makePropertiesFromJson (String s) p = insert [] (PStr s) p+makePropertiesFromJson (Array v) (Properties ps ms) = let (nps,nms) = fromArray v in Properties (ps++nps) (ms++nms)+makePropertiesFromJson (Object o) (Properties ps []) = Properties ps [M.map jsonToProperties o]+makePropertiesFromJson (Object o) (Properties ps [m]) = Properties ps [m `M.union` M.map jsonToProperties o]+makePropertiesFromJson (Object _) p = p++jsonToProperties :: Value -> Properties+jsonToProperties = (`makePropertiesFromJson` empty)++fromArray v = foldl g3 ([],[]) $ go . jsonToProperties <$> toList v+ where+ go (Properties ps ms) = (g2 ps,g2 ms)+ g2 [] = []+ g2 (a:_) = [a]+ g3 (as,bs) (a,b) = (as++a,bs++b)++instance FromProperties Value where+ fromProperties (Properties [] []) = Empty+ fromProperties (Properties [PBool p] []) = OK $ Bool p+ fromProperties (Properties [PNum p] []) = OK $ Number p+ fromProperties (Properties [PStr p] []) = OK $ String p+ fromProperties (Properties ps []) = Array . fromList <$> traverse (fromProperties.singleton) ps+ fromProperties (Properties _ [m]) = OK $ Object $ M.map (fromReturn Null . fromProperties) m+ fromProperties (Properties _ ms) = Array . fromList <$> traverse (fromProperties.singletonMap) ms++instance {-# OVERLAPPABLE #-} FromJSON a => FromProperties a where+ fromProperties a = do+ v :: Value <- fromProperties a+ case fromJSON v of+ Success r -> OK r+ Error e -> Fail e
+ src/Data/Salak/CommandLine.hs view
@@ -0,0 +1,35 @@+module Data.Salak.CommandLine where++import Data.Maybe+import Data.Salak.Types+import Data.Text (pack)+import System.Environment++-- | CommandLine parser. Parse command line into property key values.+type ParseCommandLine = [String] -> IO [(String,Property)]++-- | Default command line parsers.+-- Use format:+--+-- > --KEY=VALUE+--+-- For example:+--+-- > --salak.config.name=test.yml => ("salak.config.name", PStr "test.yml")+--+defaultParseCommandLine :: ParseCommandLine+defaultParseCommandLine = return . mapMaybe go+ where+ go ('-':'-':as) = case break (=='=') as of+ (a,'=':b) -> Just (a,PStr $ pack b)+ _ -> Nothing+ go _ = Nothing++-- | Load `Properties` from 'CommandLine'+makePropertiesFromCommandLine :: ParseCommandLine -> Properties -> IO Properties+makePropertiesFromCommandLine parser p = getArgs >>= (\a -> makePropertiesFromCommandLine' a parser p)++makePropertiesFromCommandLine' :: [String] -> ParseCommandLine -> Properties -> IO Properties+makePropertiesFromCommandLine' args parser p = do+ v <- parser args+ return $ makeProperties (fmap (\(a,b) -> (pack a,b)) v) p
+ src/Data/Salak/Environment.hs view
@@ -0,0 +1,18 @@+module Data.Salak.Environment where++import Data.Char+import Data.Salak.Types+import Data.Text (pack)+import System.Environment++-- | Load `Properties` from 'Environment'+makePropertiesFromEnvironment :: Properties -> IO Properties+makePropertiesFromEnvironment p = getEnvironment >>= (\v -> return $ makePropertiesFromEnvironment' v p)+++makePropertiesFromEnvironment' :: [(String,String)] -> Properties -> Properties+makePropertiesFromEnvironment' vs = makeProperties $ go <$> vs+ where+ go (k,v) = (pack $ fmap g2 k,PStr $ pack v)+ g2 '_' = '.'+ g2 a = toLower a
+ src/Data/Salak/Types.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Data.Salak.Types where++import Control.Monad ((>=>))+import Data.Char+import qualified Data.HashMap.Strict as M+import Data.Int+import Data.Maybe+import Data.Scientific+import Data.String+import Data.Text (Text)+import qualified Data.Text as T+import Data.Word+import Text.Read++-- | Property key+type Key = Text++-- | A Property value represented as a Haskell value.+data Property+ = PNum !Scientific -- ^ Numeric Property+ | PStr !Text -- ^ String Property+ | PBool !Bool -- ^ Bool Property+ deriving Eq++instance Show Property where+ {-# INLINE show #-}+ show (PNum n) = show n+ show (PStr n) = T.unpack n+ show (PBool n) = toLower <$> show n++instance IsString Property where+ fromString = PStr . T.pack++-- | A Property Container to hold all properties+data Properties+ = Properties [Property] [M.HashMap Key Properties]+ deriving (Eq)++instance Show Properties where+ {-# INLINE show #-}+ show = unlines . go ""+ where+ {-# INLINE go #-}+ {-# INLINE g2 #-}+ {-# INLINE g3 #-}+ {-# INLINE g4 #-}+ {-# INLINE convert #-}+ go p (Properties ps ms) = convert p g2 ps ++ concat (convert p g3 ms)+ g2 "" a = ".=" ++ show a+ g2 p a = p ++ "=" ++ show a+ g3 :: String -> M.HashMap Key Properties -> [String]+ g3 p = concatMap (g4 p) . M.toList+ g4 "" (p2,ps) = go (T.unpack p2) ps+ g4 p (p2,ps) = go (p ++ "." ++ T.unpack p2) ps+ convert _ _ [] = []+ convert p f [a] = [f p a]+ convert p f as = zipWith (\(i :: Int) a -> f (p ++ "[" ++ show i ++ "]") a) [0..] as++-- | The empty `Properties`+empty :: Properties+empty = Properties [] []+++singleton :: Property -> Properties+singleton p = Properties [p] []++singletonMap :: M.HashMap Key Properties -> Properties+singletonMap m = Properties [] [m]++-- | Split origin key by '.' to sub keys:+--+-- > "salak.config.name" -> ["salak","config","name"]+-- > "" -> []+-- > "a..b" -> ["a","b"]+--+toKeys :: Text -> [Key]+toKeys = filter (not.T.null) . T.splitOn "."++-- | Insert simple `Property` into `Properties` by `Key`.+-- If the key already have values then the new property will discard.+insert :: [Key] -> Property -> Properties -> Properties+insert [] p (Properties [] m) = Properties [p] m+insert [] _ (Properties ps m) = Properties ps m+insert (a:as) p (Properties ps []) = Properties ps [insertMap as p a M.empty]+insert (a:as) p (Properties ps ms) = Properties ps $ insertMap as p a <$> ms++insertMap as p = M.alter (Just . insert as p . fromMaybe empty)++-- | Find `Properties` by key and convert to specific Haskell value.+-- Return `Nothing` means not found, and throw `ErrorCall` means convert failed.+lookup :: FromProperties a => Text -> Properties -> Maybe a+lookup k = from . lookup' k+ where+ from :: Return a -> Maybe a+ from (OK a) = Just a+ from Empty = Nothing+ from (Fail e) = error e++-- | Find `Properties` by key and convert to specific Haskell value.+lookup' :: FromProperties a => Text -> Properties -> Return a+lookup' = go . toKeys+ where+ go [] p = fromProperties p+ go (a:as) (Properties _ [m]) = case M.lookup a m of+ Just n -> go as n+ _ -> Empty+ go _ _ = Empty++-- | Insert batch properties to `Properties`+makeProperties :: [(Text, Property)] -> Properties -> Properties+makeProperties = flip (foldl go)+ where+ go m (k,v) = insert (toKeys k) v m++-- | Return of `FromProperties`+data Return a+ = Empty+ | OK a+ | Fail String+ deriving Show++instance Functor Return where+ fmap f (OK a) = OK (f a)+ fmap _ Empty = Empty+ fmap _ (Fail b) = Fail b++instance Applicative Return where+ pure = OK+ (OK f) <*> (OK a) = OK (f a)+ (Fail x) <*> (Fail y) = Fail $ x ++ ";" ++ y+ (Fail x) <*> _ = Fail x+ _ <*> (Fail y) = Fail y+ _ <*> _ = Empty++instance Monad Return where+ (OK a) >>= f = f a+ Empty >>= _ = Empty+ (Fail b) >>= _ = Fail b++fromReturn :: b -> Return b -> b+fromReturn _ (OK a) = a+fromReturn a _ = a++-- | Convert `Properties` to Haskell value.+class FromProperties a where+ fromProperties :: Properties -> Return a++instance FromProperties Property where+ fromProperties (Properties [a] _) = OK a+ fromProperties (Properties [] _) = Empty+ fromProperties _ = Fail "property has multi values"++instance {-# OVERLAPPABLE #-} FromProperties a => FromProperties [a] where+ fromProperties (Properties ps ms) = traverse fromProperties $ fmap singleton ps ++ fmap singletonMap ms++instance FromProperties Scientific where+ fromProperties = fromProperties >=> go+ where+ go (PNum a) = OK a+ go (PStr a) = to readMaybe $ T.unpack a+ go _ = Fail "bool cannot convert to number"++instance FromProperties String where+ fromProperties a = T.unpack <$> fromProperties a++instance FromProperties Text where+ fromProperties = fromProperties >=> go+ where+ go (PStr a) = OK a+ go a = OK $ T.pack $ show a++instance FromProperties Float where+ fromProperties a = toRealFloat <$> fromProperties a++instance FromProperties Double where+ fromProperties a = toRealFloat <$> fromProperties a++instance FromProperties Int where+ fromProperties = toNumeric++instance FromProperties Int8 where+ fromProperties = toNumeric++instance FromProperties Int16 where+ fromProperties = toNumeric++instance FromProperties Int32 where+ fromProperties = toNumeric++instance FromProperties Int64 where+ fromProperties = toNumeric++instance FromProperties Word where+ fromProperties = toNumeric++instance FromProperties Word8 where+ fromProperties = toNumeric++instance FromProperties Word16 where+ fromProperties = toNumeric++instance FromProperties Word32 where+ fromProperties = toNumeric++instance FromProperties Word64 where+ fromProperties = toNumeric++toNumeric :: (Bounded i, Integral i) => Properties -> Return i+toNumeric = fromProperties >=> to toBoundedInteger++to :: (b -> Maybe a) -> b -> Return a+to v b = case v b of+ Just a -> OK a+ Nothing -> Fail "number convert failed"++instance FromProperties Bool where+ fromProperties = fromProperties >=> go+ where+ go (PBool a) = OK a+ go (PStr a) = g2 $ T.toLower a+ go _ = Fail "number cannot convert to bool"+ g2 :: Text -> Return Bool+ g2 "true" = OK True+ g2 "false" = OK False+ g2 _ = Fail "string value cannot convert to bool"++instance FromProperties Char where+ fromProperties = fromProperties >=> go+ where+ go (PStr s)+ | T.null s = Empty+ | otherwise = OK $ T.head s+ go _ = Fail "cannot convert to char"+
+ src/Data/Salak/Yaml.hs view
@@ -0,0 +1,11 @@+module Data.Salak.Yaml where++import Data.Salak.Aeson+import Data.Salak.Types+import Data.Yaml++-- | Load `Properties` from `Yaml` file.+makePropertiesFromYaml :: FilePath -> Properties -> IO Properties+makePropertiesFromYaml file p = do+ v <- decodeFileThrow file+ return $ makePropertiesFromJson v p
− src/Salak.hs
@@ -1,206 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}--- |--- Module: Salak--- Copyright: (c) 2019 Daniel YU--- License: BSD3--- Maintainer: leptonyu@gmail.com--- Stability: experimental--- Portability: portable------ Configuration Loader for Production in Haskell.----module Salak(- -- * How to use this library- -- $use-- -- * Salak- defaultLoadSalak- , loadSalak- , PropConfig(..)- -- * Static Load- , HasSourcePack(..)- , fetch- , require- -- * Dynamic Load- , ReloadableSourcePack- , ReloadableSourcePackT- , ReloadResult(..)- , reloadable- , fetchD- , requireD- -- * Prop Parser- , Prop- , FromProp(..)- , FromEnumProp(..)- , (.?=)- , (.?:)- -- * SourcePack- , SourcePack- , SourcePackT- , loadYaml- , loadCommandLine- , loadEnv- , loadMock- , defaultParseCommandLine- , ParseCommandLine- , Priority- , Value(..)- ) where--import Control.Applicative-import Control.Monad (unless)-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Reader-import Control.Monad.State-import Data.Default-import Data.Text (Text)-import Salak.Dynamic-import Salak.Env-import Salak.Json-import Salak.Prop-import Salak.Types-import System.Directory-import System.FilePath ((</>))---- | Prop load configuration-data PropConfig = PropConfig- { configName :: Maybe String -- ^ Config name- , configDirKey :: Text -- ^ Specify config dir- , searchCurrent :: Bool -- ^ Search current directory, default true- , searchHome :: Bool -- ^ Search home directory, default false.- , commandLine :: ParseCommandLine -- ^ How to parse commandline- }--instance Default PropConfig where- def = PropConfig Nothing "salak.conf" True False defaultParseCommandLine---- | Load salak `SourcePack` and fetch properties.-loadSalak- :: Monad m- => ReaderT SourcePack m a -- ^ Fetch properties monad.- -> SourcePackT m () -- ^ Load properties monad.- -> m a-loadSalak a spm = do- (es, sp) <- runSourcePackT spm- unless (null es) $ fail (head es)- runReaderT a sp---- | Default load salak.--- All these configuration sources has orders, from highest order to lowest order:------ > 1. CommandLine--- > 2. Environment--- > 3. Specified Yaml file(file in `configDirKey`)--- > 4. Yaml file in current directory--- > 5. Yaml file in home directory----defaultLoadSalak :: MonadIO m => PropConfig -> ReaderT SourcePack m a -> m a-defaultLoadSalak PropConfig{..} a = loadSalak a $ do- loadCommandLine commandLine- loadEnv- cf <- fetch configDirKey- maybe (return ()) (go cf) configName- where- go ck n = do- case ck of- Left _ -> return ()- Right d -> loadYaml $ d </> n- c <- liftIO getCurrentDirectory- when searchCurrent $ tryLoadYaml $ c </> n- h <- liftIO getHomeDirectory- when searchHome $ tryLoadYaml $ h </> n--class Monad m => HasSourcePack m where- askSourcePack :: m SourcePack--instance Monad m => HasSourcePack (ReaderT SourcePack m) where- askSourcePack = ask-instance Monad m => HasSourcePack (StateT SourcePack m) where- askSourcePack = get---- | Try fetch properties from `SourcePack`-fetch- :: (HasSourcePack m, FromProp a)- => Text -- ^ Properties key- -> m (Either String a)-fetch key = search key <$> askSourcePack---- | Fetch properties from `SourcePack`, or throw fail-require- :: (HasSourcePack m, FromProp a)- => Text -- ^ Properties key- -> m a-require k = do- x <- fetch k- case x of- Left e -> fail e- Right v -> return v---- | Fetch dynamic properties from `SourcePack`, or throw fail-requireD- :: (MonadIO m, FromProp a)- => Text -- ^ Properties key- -> ReloadableSourcePackT m (IO a)-requireD k = do- x <- fetchD k- case x of- Left e -> fail e- Right v -> return v---- | Try fetch dynamic properties from `SourcePack`-fetchD- :: (MonadIO m, FromProp a)- => Text -- ^ Properties key- -> ReloadableSourcePackT m (Either String (IO a))-fetchD = search'---- | Lift to reloadable environment for dynamic properties.-reloadable :: (MonadIO m, HasSourcePack m) => ReloadableSourcePackT m a -> m a-reloadable f = askSourcePack >>= runReloadable f---- | Optional value.-infixl 5 .?=-(.?=) :: Alternative f => f a -> a -> f a-(.?=) a b = a <|> pure b---- | Default value.-infixl 5 .?:-(.?:) :: (Alternative f, Default b) => f a -> (b -> a) -> f a-(.?:) fa b = fa .?= b def---- $use------ | This library default a standard configuration load process. It can load properties from `CommandLine`, `Environment`,--- `JSON value` and `Yaml` files. They all load to the same format `SourcePack`. Earler property source has higher order--- to load property. For example:------ > CommandLine: --package.a.enabled=true--- > Environment: PACKAGE_A_ENABLED: false------ > lookup "package.a.enabled" properties => Just True------ `CommandLine` has higher order then `Environment`, for the former load properties earler then later.------ Usage:------ > data Config = Config--- > { name :: Text--- > , dir :: Maybe Text--- > , ext :: Int--- > } deriving (Eq, Show)--- >--- > instance FromProp Config where--- > fromProp = Config--- > <$> "user"--- > <*> "pwd"--- > <*> "ext" .?= 1------ > main = do--- > c :: Config <- defaultLoadSalak def $ require ""--- > print c------ > λ> c--- > Config {name = "daniel", dir = Nothing, ext = 1}
− src/Salak/Dynamic.hs
@@ -1,71 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-module Salak.Dynamic where--import Control.Concurrent.MVar-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.State-import qualified Data.IntMap.Strict as MI-import Data.Text (Text)-import Salak.Prop-import Salak.Types--data ReloadResult = ReloadResult- { isError :: Bool- , msg :: [String]- } deriving (Eq, Show)---- | Reloadable SourcePack-data ReloadableSourcePack = ReloadableSourcePack- { sourcePack :: MVar SourcePack- , reloadAll :: (SourcePack -> IO ([IO ()], [String])) -> IO ReloadResult- }--reloadableSourcePack :: MonadIO m => SourcePack -> m ReloadableSourcePack-reloadableSourcePack sp = do- msp <- liftIO $ newMVar sp- return $ ReloadableSourcePack msp (reloadAll' msp)- where- reloadAll' v f = do- sp'@(SourcePack _ _ _ it) <- readMVar v- as <- filter (not . nullSource . snd) <$> mapM go (MI.toList it)- if null as- then return (ReloadResult True [])- else do- let (es, sp'') = extractErr' $ foldl g2 sp' as- (ac, es') <- f sp''- if null es'- then putMVar v sp'' >> sequence_ ac >> return (ReloadResult True es)- else return (ReloadResult False es')- go (i, Reload _ f) = (i,) <$> f i- g2 (SourcePack ss i s it) (x,s') = SourcePack ss i (replace x s' s) it--type ReloadableSourcePackT = StateT ReloadableSourcePack--search' :: (MonadIO m, FromProp a) => Text -> ReloadableSourcePackT m (Either String (IO a))-search' k = do- ReloadableSourcePack{..} <- get- sp <- liftIO $ takeMVar sourcePack- case search k sp of- Left e -> return (Left e)- Right r -> do- v <- liftIO $ newMVar r- put (ReloadableSourcePack sourcePack (reloadAll . go v))- return $ Right $ readMVar v- where- go x f sp = do- (as,es) <- f sp- case search k sp of- Left e -> return (as, e:es)- Right r -> return (putMVar x r:as, es)--reload :: Monad m => ReloadableSourcePackT m (IO ReloadResult)-reload = do- ReloadableSourcePack{..} <- get- return $ reloadAll $ \_ -> return ([], [])--runReloadable :: MonadIO m => ReloadableSourcePackT m a -> SourcePack -> m a-runReloadable r sp = reloadableSourcePack sp >>= evalStateT r---
− src/Salak/Env.hs
@@ -1,34 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Salak.Env where--import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.State-import Data.Maybe-import qualified Data.Text as T-import Salak.Types-import System.Environment--loadEnv :: MonadIO m => SourcePackT m ()-loadEnv = do- args <- liftIO getEnvironment- modify $ load (emptyReload "environment") args go- where- go p (k,v) = (g2 k, VStr p $ T.pack v)- g2 = T.toLower . T.pack . map (\c -> if c == '_' then '.' else c)--type ParseCommandLine = [String] -> IO [(T.Text,Priority -> Value)]--defaultParseCommandLine :: ParseCommandLine-defaultParseCommandLine = return . mapMaybe go- where- go ('-':'-':as) = case break (=='=') as of- (a,'=':b) -> Just (T.pack a, \p -> VStr p $ T.pack b)- _ -> Nothing- go _ = Nothing--loadCommandLine :: MonadIO m => ParseCommandLine -> SourcePackT m ()-loadCommandLine pcl = do- args <- liftIO $ getArgs >>= pcl- modify $ load (emptyReload "commandline") args go- where- go i (k,fv) = (k, fv i)
− src/Salak/Json.hs
@@ -1,38 +0,0 @@-module Salak.Json where--import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.State-import qualified Data.Aeson as A-import qualified Data.HashMap.Strict as HM-import qualified Data.IntMap.Strict as MI-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Text (pack)-import qualified Data.Vector as V-import qualified Data.Yaml as Y-import Salak.Types-import System.Directory--loadJSON :: Reload -> A.Value -> SourcePack -> SourcePack-loadJSON name v sp = loadFile name sp $ go v- where- go (A.Object m) i s = foldl (g2 i) s $ HM.toList m- go (A.Array m) i s = foldl (g3 i) s $ zip [0..] $ V.toList m- go (A.String m) i s = insert' [] (VStr i m) s- go (A.Number m) i s = insert' [] (VNum i m) s- go (A.Bool m) i s = insert' [] (VBool i m) s- go A.Null _ s = s- g2 i (Source es p is ts) (k,v') = let s' = go v' i (fromMaybe emptySource $ M.lookup k ts) in Source es p is $ M.insert k s' ts- g3 i (Source es p is ts) (k,v') = let s' = go v' i (fromMaybe emptySource $ MI.lookup k is) in Source es p (MI.insert k s' is) ts--loadYaml :: MonadIO m => FilePath -> SourcePackT m ()-loadYaml file = do- v <- liftIO $ Y.decodeFileEither file- modify $ \sp -> case v of- Left e -> addErr' (show e) sp- Right a -> loadJSON (emptyReload $ pack file) a sp--tryLoadYaml :: MonadIO m => FilePath -> SourcePackT m ()-tryLoadYaml file = do- b <- liftIO $ doesFileExist file- when b $ loadYaml file
− src/Salak/Prop.hs
@@ -1,240 +0,0 @@-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}-module Salak.Prop where--import Control.Applicative-import Control.Monad.Reader-import Data.Int-import qualified Data.IntMap.Strict as MI-import Data.Menshen-import qualified Data.PQueue.Min as Q-import Data.Scientific-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import Data.Word-import GHC.Exts-import GHC.Generics hiding (Selector)-import qualified GHC.Generics as G-import Salak.Types-import Text.Read (readMaybe)--data PResult a- = O [Selector] a -- ^ Succeed value- | N [Selector] -- ^ Empty value- | F [Selector] String -- ^ Fail value- deriving (Eq, Show, Functor)--instance Applicative PResult where- pure = O []- (O s f) <*> (O _ a) = O s (f a)- (F s e) <*> _ = F s e- _ <*> (F s e) = F s e- (N s) <*> _ = N s- _ <*> (N s) = N s--instance Alternative PResult where- empty = N []- (O s f) <|> _ = O s f- _ <|> x = x--instance Monad PResult where- return = pure- (O _ a) >>= f = f a- (N s ) >>= _ = N s- (F s e) >>= _ = F s e--newtype PropT m a = Prop { unProp :: ReaderT SourcePack m a }- deriving (Functor, Applicative, Monad, MonadTrans, Alternative)--type Prop = PropT PResult--runProp sp a = runReaderT (unProp a) sp--instance MonadReader SourcePack Prop where- ask = Prop ask- local f (Prop a) = Prop (local f a)--instance HasValid Prop where- invalid = err . toI18n--instance FromProp a => IsString (Prop a) where- fromString = readSelect . T.pack--class FromProp a where- fromProp :: Prop a- default fromProp :: (Generic a, GFromProp (Rep a)) => Prop a- fromProp = fmap to gFromProp--class GFromProp f where- gFromProp :: Prop (f a)--instance {-# OVERLAPPABLE #-} (Constructor c, GFromProp a) => GFromProp (M1 C c a) where- gFromProp- | conIsRecord m = fmap M1 gFromProp- | otherwise = fmap M1 $ gEnum $ T.pack (conName m)- where m = undefined :: t c a x--gEnum va = do- o <- gFromProp- readPrimitive $ \ss v -> case v of- VStr _ x -> if x /= va then N ss else O ss o- _ -> N ss--instance {-# OVERLAPPABLE #-} (G.Selector s, GFromProp a) => GFromProp (M1 S s a) where- gFromProp = local go $ M1 <$> gFromProp- where- go sp = select sp (STxt $ T.pack $ selName (undefined :: t s a p))--instance {-# OVERLAPPABLE #-} GFromProp a => GFromProp (M1 D i a) where- gFromProp = M1 <$> gFromProp--instance {-# OVERLAPPABLE #-} (FromProp a) => GFromProp (K1 i a) where- gFromProp = fmap K1 fromProp--instance GFromProp U1 where- gFromProp = pure U1--instance {-# OVERLAPPABLE #-} (GFromProp a, GFromProp b) => GFromProp (a:*:b) where- gFromProp = (:*:) <$> gFromProp <*> gFromProp--instance {-# OVERLAPPABLE #-} (GFromProp a, GFromProp b) => GFromProp (a:+:b) where- gFromProp = fmap L1 gFromProp <|> fmap R1 gFromProp--instance FromProp a => FromProp (Maybe a) where- fromProp = do- sp <- ask- lift $ case runProp sp (fromProp :: Prop a) of- O s a -> O s $ Just a- N s -> O s Nothing- F s e -> F s e--instance {-# OVERLAPPABLE #-} FromProp a => FromProp [a] where- fromProp = do- SourcePack ss i (Source _ _ is _) it <- ask- foldM (go ss i it) [] $ MI.toList is- where- go xx x xt as (ix,s) = do- a <- lift $ runProp (SourcePack (SNum ix:xx) x s xt) fromProp- return (a:as)--instance {-# OVERLAPPABLE #-} FromEnumProp a => FromProp a where- fromProp = readPrimitive $ \ss v -> case v of- VStr _ s -> case fromEnumProp $ T.toLower s of- Left e -> F ss e- Right r -> O ss r- VNum _ _ -> F ss "number cannot be enum"- VBool _ _ -> F ss "bool cannot be enum"---- | ReadPrimitive value-readPrimitive :: ([Selector] -> Value -> PResult a) -> Prop a-readPrimitive f = do- SourcePack ss _ (Source _ q _ _) _ <- ask- case Q.getMin q of- Just v -> lift $ f ss v- _ -> lift $ N ss--class FromEnumProp a where- fromEnumProp :: Text -> Either String a- {-# MINIMAL fromEnumProp #-}--err :: String -> Prop a-err e = do- SourcePack ss _ _ _ <- ask- lift $ F ss e---- | Parse value-readSelect :: FromProp a => Text -> Prop a-readSelect key = case selectors key of- Left e -> err e- Right s -> local (\sp -> foldl select sp s) fromProp--search :: FromProp a => Text -> SourcePack -> Either String a-search key sp = case runProp sp (readSelect key) of- O _ x -> Right x- N s -> Left $ "key " ++ toKey s ++ " not found"- F s e -> Left $ "key " ++ toKey s ++ " : " ++ e--instance FromProp Bool where- fromProp = readPrimitive go- where- go s (VBool _ x) = O s x- go s (VNum _ _) = F s "number cannot be bool"- go s (VStr _ x) = case T.toLower x of- "true" -> O s True- "yes" -> O s True- "false" -> O s False- "no" -> O s False- _ -> F s "string convert bool failed"--instance FromProp Text where- fromProp = readPrimitive go- where- go s (VStr _ x) = O s x- go s (VBool _ _) = F s "boolean cannot be string"- go s (VNum _ _) = F s "number cannot be string"--instance FromProp TL.Text where- fromProp = TL.fromStrict <$> fromProp--instance FromProp String where- fromProp = T.unpack <$> fromProp--instance FromProp Scientific where- fromProp = readPrimitive go- where- go s (VStr _ x) = case readMaybe $ T.unpack x of- Just v -> O s v- _ -> F s "string convert number failed"- go s (VNum _ x) = O s x- go s (VBool _ _) = F s "boolean cannot be number"--instance FromProp Float where- fromProp = toRealFloat <$> fromProp--instance FromProp Double where- fromProp = toRealFloat <$> fromProp--instance FromProp Int where- fromProp = fromProp >>= toNum--instance FromProp Int8 where- fromProp = fromProp >>= toNum--instance FromProp Int16 where- fromProp = fromProp >>= toNum--instance FromProp Int32 where- fromProp = fromProp >>= toNum--instance FromProp Int64 where- fromProp = fromProp >>= toNum--instance FromProp Word where- fromProp = fromProp >>= toNum--instance FromProp Word8 where- fromProp = fromProp >>= toNum--instance FromProp Word16 where- fromProp = fromProp >>= toNum--instance FromProp Word32 where- fromProp = fromProp >>= toNum--instance FromProp Word64 where- fromProp = fromProp >>= toNum--toNum :: (Integral i, Bounded i) => Scientific -> Prop i-toNum s = case toBoundedInteger s of- Just v -> return v- _ -> err "scientific number doesn't fit in the target representation"
− src/Salak/Types.hs
@@ -1,204 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeSynonymInstances #-}-module Salak.Types where--import Control.Applicative ((<|>))-import Control.Monad.State-import Data.Attoparsec.Text-import qualified Data.IntMap.Strict as MI-import Data.List (intercalate)-import qualified Data.Map.Strict as M-import Data.Maybe-import qualified Data.PQueue.Min as Q-import Data.Scientific (Scientific)-import Data.Text (Text)-import qualified Data.Text as T--type Priority = Int--data Value- = VStr Priority !Text- | VNum Priority !Scientific- | VBool Priority !Bool- deriving (Eq, Show, Ord)--type QV = Q.MinQueue Value--getPriority :: Value -> Priority-getPriority (VStr p _) = p-getPriority (VNum p _) = p-getPriority (VBool p _) = p--data Reload = Reload- { sourceName :: Text- , reload :: Priority -> IO Source- }--instance Show Reload where- show (Reload s _) = T.unpack s--emptyReload :: Text -> Reload-emptyReload s = Reload s (\_ -> return emptySource)--type PriorityEnv = MI.IntMap Reload--nullSource :: Source -> Bool-nullSource (Source _ q is ts) = Q.null q && MI.null is && M.null ts--getQ :: Source -> QV-getQ (Source _ q _ _) = q--replaceQ :: String -> Priority -> QV -> QV -> ([String], QV)-replaceQ s i nq q =- let (a,b) = Q.partition ((==i) . getPriority) q- in if a == nq then ([], q) else case Q.getMin nq of- Just v -> ([ (if Q.null a then "Add " else "Mod ") ++ s], Q.insert v b)- _ -> (if Q.null a then [] else ["Del " ++ s], b)--data Source' v = Source [String] v (MI.IntMap (Source' v)) (M.Map Text (Source' v)) deriving (Eq, Functor)--type Source = Source' QV--instance Show Source where- show = unlines . go ""- where- go p (Source _ q is ts) = (if Q.null q then [] else [ p ++ "=" ++ show q ])- ++ concat ((\(k,v) -> go (p ++ "[" ++ show k ++ "]") v) <$> MI.toList is)- ++ concat ((\(k,v) -> go (if null p then T.unpack k else p ++ "." ++ T.unpack k) v) <$> M.toList ts)--emptySource :: Source-emptySource = Source [] Q.empty MI.empty M.empty--instance Foldable Source' where- foldr f b s@(Source _ _ is ts) = foldr go (foldr go (go s b) is) ts- where- go (Source _ q _ _) = f q--foldSource :: (Value -> b -> b) -> b -> Source -> b-foldSource f = foldr (\q b -> maybe b (`f` b) $ Q.getMin q)--sizeSouce :: Source -> Int-sizeSouce = foldSource (const (+1)) 0--extractErr :: Source -> ([String], Source)-extractErr (Source es q is ts) =- let (ise, is') = MI.mapAccum go es is- (tse, ts') = M.mapAccum go ise ts- in (tse, Source [] q is' ts')- where- go e s = let (e', s') = extractErr s in (e ++ e', s')--replace = replace' []--replace' :: [Selector] -> Priority -> Source -> Source -> Source-replace' ss i (Source _ nq nis nts) (Source es q is ts) =- let (ms, q') = replaceQ (toKey ss) i nq q- (isa,isb) = MI.partition nullSource $ MI.mapWithKey (g2.SNum) $ MI.unionWithKey (go.SNum) (f 0 nis) (f 1 is)- (tsa,tsb) = M.partition nullSource $ M.mapWithKey (g2.STxt) $ M.unionWithKey (go.STxt) (f 0 nts) (f 1 ts)- in Source (g $ Source (es ++ ms) Q.empty isa tsa) q' isb tsb- where- f x = ((x::Int,) <$>)- g = fst . extractErr- go st (_, s) (_, s') = (2, replace' (st:ss) i s s')- g2 st (0, s) = replace' (st:ss) i s emptySource- g2 st (1, s) = replace' (st:ss) i emptySource s- g2 _ (_, s) = s--data Selector- = STxt !Text- | SNum !Int- deriving Eq--instance Show Selector where- show (STxt x) = T.unpack x- show (SNum i) = "[" ++ show i ++ "]"--toKey :: [Selector] -> String-toKey = intercalate "." . go . reverse- where- go (a@(STxt _):b@(SNum _):cs) = (show a ++ show b) : go cs- go (a:bs) = show a : go bs- go [] = []--selectors :: Text -> Either String [Selector]-selectors = go . parse exprs . flip T.snoc '\n'- where- go (Done i r) = if i /= "\n" then Left $ "uncomplete parse" ++ T.unpack i else Right r- go a = Left (show a)--exprs :: Parser [Selector]-exprs = concat <$> ( (expr <|> return []) `sepBy` char '.')---- xx--- xx.xx--- xx.xx[0]--- xx.xx[1].xx-expr :: Parser [Selector]-expr = do- name <- T.pack <$> do- a <- choice [letter, digit]- b <- many' (choice [letter, digit, char '-', char '_'])- return (a:b)- (paren decimal >>= \i -> return [STxt name, SNum i]) <|> return [STxt name]- where- paren e = do- _ <- char '['- ex <- e- _ <- char ']'- return ex--addErr :: String -> Source -> Source-addErr e (Source es a b c) = Source (e:es) a b c--insert :: Text -> Value -> Source -> Source-insert k v s = case selectors k of- Left e -> addErr e s- Right k' -> insert' k' v s--insert' :: [Selector] -> Value -> Source -> Source-insert' [] v (Source es q is ts) = Source es (Q.insert v q) is ts-insert' (STxt n:ss) v (Source es q is ts) = Source es q is $ M.alter (Just . insert' ss v . fromMaybe emptySource) n ts-insert' (SNum i:ss) v (Source es q is ts) = Source es q (MI.alter (Just . insert' ss v . fromMaybe emptySource) i is) ts--data SourcePack = SourcePack [Selector] Int Source PriorityEnv deriving Show--emptySourcePack = SourcePack [] 0 emptySource MI.empty--mapSource :: (Source -> Source) -> SourcePack -> SourcePack-mapSource f (SourcePack ss i s it) = SourcePack ss i (f s) it--select :: SourcePack -> Selector -> SourcePack-select (SourcePack ss i (Source _ _ _ ts) it) s@(STxt n) = SourcePack (s:ss) i (fromMaybe emptySource $ M.lookup n ts) it-select (SourcePack ss i (Source _ _ is _) it) s@(SNum n) = SourcePack (s:ss) i (fromMaybe emptySource $ MI.lookup n is) it--addErr' :: String -> SourcePack -> SourcePack-addErr' e = mapSource (addErr e)--extractErr' :: SourcePack -> ([String], SourcePack)-extractErr' (SourcePack ss i s it) = let (es, s') = extractErr s in (es, SourcePack ss i s' it)--loadFile :: Reload -> SourcePack -> (Priority -> Source -> Source) -> SourcePack-loadFile name (SourcePack ss i s env) go = SourcePack ss (i+1) (go i s) $ MI.insert i name env--load- :: (Functor f, Foldable f)- => Reload- -> f a- -> (Priority -> a -> (Text, Value))- -> SourcePack- -> SourcePack-load name fa f sp = loadFile name sp $ \i s -> foldl (go i) s fa- where- go i s a = let (k,v) = f i a in insert k v s--loadMock :: Monad m => [(Text, Text)] -> SourcePackT m ()-loadMock fs = modify $ load (emptyReload "") fs (\i (k,v) -> (k, VStr i v))--type SourcePackT = StateT SourcePack--runSourcePackT :: Monad m => SourcePackT m a -> m ([String], SourcePack)-runSourcePackT ac = extractErr' <$> execStateT ac emptySourcePack-
test/Spec.hs view
@@ -1,18 +1,18 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where -import Data.Either-import Data.List (intercalate)-import Data.Text (Text, pack, unpack)-import GHC.Generics-import Salak-import Salak.Prop-import Salak.Types+import Data.Aeson+import qualified Data.HashMap.Strict as M+import Data.Maybe+import Data.Salak+import Data.Salak.CommandLine+import Data.Salak.Environment+import qualified Data.Salak.Types as P+import Data.Text (Text, intercalate, pack)+import System.Environment import Test.Hspec import Test.QuickCheck @@ -20,89 +20,115 @@ spec :: Spec spec = do- describe "Salak.Types" specProperty--newtype SKey = SKey { unKey :: Text } deriving Show--instance Arbitrary SKey where- arbitrary = do- key <- choose (1,20)- vs <- vectorOf key $ do- k <- choose (1,20)- v <- vectorOf k $ choose ('a','z')- b <- choose (0,10) :: Gen Int- if b > 0 then return v else do- x <- choose (0,10) :: Gen Int- return (v ++ "[" ++ show x ++ "]")- return (SKey $ pack $ intercalate "." vs)--data Conf = Conf- { name :: String- , age :: Int- , male :: Bool- , det :: SubConf- } deriving (Eq, Show, Generic)+ describe "Data.Salak.Types" specProperty+ describe "Data.Salak" specProperties -data SubConf = SubConf- { hello :: String } deriving (Eq, Show, Generic)+shouldFail :: (HasCallStack, Show a, Eq a) => a -> a -> Expectation+shouldFail f a = (f `shouldBe` a) `shouldThrow` anyErrorCall -instance FromProp SubConf where- fromProp = SubConf <$> "hello" .?= "yyy"+data Config = Config+ { name :: Text+ , dir :: Text+ , ext :: Int+ } deriving (Eq, Show) -instance FromProp Conf+instance FromJSON Config where+ parseJSON = withObject "Config" $ \v -> Config+ <$> v .: "name"+ <*> v .: "dir"+ <*> (fromMaybe 1 <$> v .:? "ext") specProperty = do- context "selectors" $ do+ context "empty" $ do it "normal" $ do- selectors "" `shouldBe` Right []- selectors "." `shouldBe` Right []- selectors ".." `shouldBe` Right []- selectors "xx" `shouldBe` Right [STxt "xx"]- selectors "xx[0]" `shouldBe` Right [STxt "xx", SNum 0]- selectors "xx.yy" `shouldBe` Right [STxt "xx", STxt "yy"]- it "QuickCheck" $ do- quickCheck $ \s -> let s' = unKey s in (toKey . reverse <$> selectors s') `shouldBe` Right (unpack s')- context "source" $ do+ let p = empty+ print p+ p `shouldBe` Properties [] []+ context "toKeys" $ do it "normal" $ do- nullSource emptySource `shouldBe` True- sizeSouce emptySource `shouldBe` 0- it "normal - 2" $ do- let s1 = insert "hello" (VStr 0 "world") emptySource- sizeSouce s1 `shouldBe` 1- let s2 = insert "1" (VStr 0 "world") emptySource- sizeSouce s2 `shouldBe` 1- let (es,_) = extractErr s2- length es `shouldBe` 0- it "merge" $ do- let s = insert "hello" (VStr 0 "world") emptySource- s1 = insert "hello" (VStr 0 "xxxxx") emptySource- (e2, s2) = extractErr $ replace 0 emptySource s- s2 `shouldBe` emptySource- e2 `shouldBe` ["Del hello"]- let (e3, s3) = extractErr $ replace 0 s1 s- e3 `shouldBe` ["Mod hello"]- s3 `shouldBe` s1- let (e4, s4) = extractErr $ replace 0 s emptySource- e4 `shouldBe` ["Add hello"]- s4 `shouldBe` s- let (e5, s5) = extractErr $ replace 0 s s- e5 `shouldBe` []- s5 `shouldBe` s- context "Generic" $ do- it "conf" $ do- (e, sp) <- runSourcePackT $ loadMock- [ ("name", "Daniel")- , ("age", "18")- , ("male", "yes")- ]- e `shouldBe` []- let a = search "" sp :: Either String Conf- print a- isRight a `shouldBe` True---+ [] `shouldBe` toKeys ""+ ["a"] `shouldBe` toKeys "a"+ ["a"] `shouldBe` toKeys "a."+ ["a","b"] `shouldBe` toKeys "a.b"+ ["a","b"] `shouldBe` toKeys "a.....b"+ it "quickCheck" $ do+ quickCheck $ \a -> let b = toKeys $ pack a in b == toKeys (intercalate "." b)+ context "insert" $ do+ let p = PStr "Hello"+ k = toKeys "a.b"+ m = insert k p empty+ it "normal" $ do+ insert [] p empty `shouldBe` Properties [p] []+ insert k p empty `shouldBe` Properties [] [M.insert "a" (Properties [] [M.insert "b" (Properties [p] []) M.empty]) M.empty]+ it "Reject replacement" $ do+ insert k "1" m `shouldBe` m+ it "quickCheck" $ do+ quickCheck $ \a' (b :: Integer) -> let a = pack a' in Just b == P.lookup a (insert (toKeys a) (PNum $ fromInteger b) empty)+ quickCheck $ \a' (b :: Bool) -> let a = pack a' in Just b == P.lookup a (insert (toKeys a) (PBool b) empty)+ quickCheck $ \a' (b :: String) -> let a = pack a' in Just b == P.lookup a (insert (toKeys a) (PStr $ pack b) empty)+ context "lookup" $ do+ it "normal" $ do+ let m = insert ["a"] (PNum 1) empty+ n = insert ["a"] (PStr "true") empty+ (P.lookup "a" empty :: Maybe Int) `shouldBe` Nothing+ (P.lookup "a" m :: Maybe Int) `shouldBe` Just 1+ (P.lookup "a" m :: Maybe Bool) `shouldFail` Nothing+ (P.lookup "a" m :: Maybe String) `shouldBe` Just "1.0"+ (P.lookup "a" n :: Maybe Int) `shouldFail` Nothing+ (P.lookup "a" n :: Maybe Bool) `shouldBe` Just True+ (P.lookup "a" n :: Maybe Text) `shouldBe` Just "true"+ context "makeProperties" $ do+ it "normal" $ do+ m <- makePropertiesFromEnvironment empty+ h <- getEnv "HOME"+ (P.lookup "home" m) `shouldBe` Just h+ context "command-line" $ do+ it "normal" $ do+ let args = ["--package.a.enabled=true","--package.b.enabled=false","package.c.enabled=false"]+ m <- makePropertiesFromCommandLine' args defaultParseCommandLine empty+ P.lookup "package.a.enabled" m `shouldBe` Just True+ P.lookup "package.b.enabled" m `shouldBe` Just False+ (P.lookup "package.c.enabled" m :: Maybe Bool )`shouldBe` Nothing+ context "environment" $ do+ it "normal" $ do+ let args = [("PACKAGE_A_ENABLED","true"),("PACKAGE_B_ENABLED","false")]+ m = makePropertiesFromEnvironment' args empty+ P.lookup "package.a.enabled" m `shouldBe` Just True+ P.lookup "package.b.enabled" m `shouldBe` Just False+ (P.lookup "package.c.enabled" m :: Maybe Bool )`shouldBe` Nothing +specProperties = do+ context "defaultPropertiesWithFile" $ do+ let confName = "salak.yml" :: String+ confName' = pack confName+ it "read config" $ do+ unsetEnv "SALAK_CONFIG_NAME"+ p <- defaultPropertiesWithFile confName'+ P.lookup "salak.config.name" p `shouldBe` Just confName+ it "read config - replacement" $ do+ setEnv "SALAK_CONFIG_NAME" confName+ p <- defaultPropertiesWithFile "salak.ok"+ P.lookup "salak.config.name" p `shouldBe` Just confName+ it "read config - not found" $ do+ setEnv "SALAK_CONFIG_NAME" "salak.notfound"+ setEnv "SALAK_CONFIG_DIR" "test"+ defaultPropertiesWithFile confName' `shouldThrow` anyErrorCall+ it "read config - read file parse Config" $ do+ setEnv "SALAK_CONFIG_NAME" confName+ setEnv "SALAK_CONFIG_DIR" "test"+ setEnv "SALAK_CONFIG" confName+ p <- defaultPropertiesWithFile confName'+ let get :: FromProperties a => Text -> Maybe a+ get = flip P.lookup p+ -- print p+ -- let v::Return Value = fromProperties p+ -- P.fromReturn (return ()) $ BC.putStrLn . encodePretty <$> v+ get "salak.config.name" `shouldBe` Just confName+ get "salak.config" `shouldBe` Just confName+ (get "salak.config" :: Maybe Config) `shouldBe` Just (Config confName' "test" 1)+ (get "array" :: Maybe [String]) `shouldBe` Just ["a","b"]+ (get "array" :: Maybe [Int]) `shouldFail` Nothing+ (get "array" :: Maybe String) `shouldFail` Nothing
test/salak.yml view
@@ -1,9 +1,3 @@ array: - a - b-hello:- world--config:- name: hello- dir: /root