salak 0.2.3 → 0.2.4
raw patch · 10 files changed
+825/−118 lines, 10 filesdep +attoparsecdep +containersdep +data-default
Dependencies added: attoparsec, containers, data-default, pqueue
Files
- README.md +41/−1
- salak.cabal +21/−1
- src/Data/Salak/Types.hs +1/−0
- src/Salak.hs +128/−0
- src/Salak/Dynamic.hs +63/−0
- src/Salak/Env.hs +34/−0
- src/Salak/Json.hs +32/−0
- src/Salak/Prop.hs +217/−0
- src/Salak/Types.hs +204/−0
- test/Spec.hs +84/−116
README.md view
@@ -1,7 +1,47 @@ # salak -[](https://hackage.haskell.org/package/salak)+[](https://hackage.haskell.org/package/salak)+[](http://stackage.org/lts/package/salak)+[](http://stackage.org/nightly/package/salak) [](https://travis-ci.org/leptonyu/salak) Configuration Loader for Production 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}+```
salak.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: salak-version: 0.2.3+version: 0.2.4 license: BSD3 license-file: LICENSE copyright: (c) 2018 Daniel YU@@ -18,9 +18,15 @@ library exposed-modules:+ Salak Data.Salak hs-source-dirs: src other-modules:+ Salak.Types+ Salak.Env+ Salak.Json+ Salak.Prop+ Salak.Dynamic Data.Salak.Types Data.Salak.Environment Data.Salak.CommandLine@@ -32,11 +38,15 @@ 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, stm <2.6, text <1.3,@@ -58,18 +68,28 @@ Data.Salak.Operation Data.Salak.Types Data.Salak.Yaml+ 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.13, 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, stm <2.6, text <1.3,
src/Data/Salak/Types.hs view
@@ -123,6 +123,7 @@ -- | Return of `FromProperties` type Return = Either ErrResult+ data ErrResult = EmptyKey Text | Fail String deriving Show instance HasValid Return where
+ src/Salak.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE FlexibleInstances #-}+{-# 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++ -- * Source+ Selector+ , SourcePack+ , SourcePackT+ , Reload(..)+ , load+ , loadJSON+ , loadYaml+ , loadEnv+ -- * Salak+ , defaultLoadSalak+ , loadSalak+ , PropConfig(..)+ , HasSourcePack(..)+ , fetch+ , require+ -- * Utilities+ , ReloadableSourcePack+ , runReloadable+ , Prop+ , FromProp(..)+ , PResult(..)+ , readPrimitive+ , readSelect+ , err+ ) where++import Control.Monad (unless)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Reader+import Data.Default+import Data.Text (Text)+import Salak.Dynamic+import Salak.Env+import Salak.Json+import Salak.Prop+import Salak.Types++data PropConfig = PropConfig+ { configFileKey :: Maybe String+ , commandLine :: ParseCommandLine+ }++instance Default PropConfig where+ def = PropConfig Nothing defaultParseCommandLine++loadSalak :: Monad m => ReaderT SourcePack m a -> SourcePackT m () -> m a+loadSalak a spm = do+ (es, sp) <- runSourcePackT spm+ unless (null es) $ do+ fail (head es)+ runReaderT a sp++defaultLoadSalak :: MonadIO m => PropConfig -> ReaderT SourcePack m a -> m a+defaultLoadSalak PropConfig{..} a = loadSalak a $ do+ loadCommandLine commandLine+ loadEnv+ go configFileKey+ where+ go (Just file) = loadYaml file+ go _ = return ()++class Monad m => HasSourcePack m where+ askSourcePack :: m SourcePack++fetch :: (HasSourcePack m, FromProp a) => Text -> m (Either String a)+fetch key = askSourcePack >>= return . search key++require :: (HasSourcePack m, FromProp a) => Text -> m a+require k = do+ x <- fetch k+ case x of+ Left e -> fail e+ Right v -> return v++instance Monad m => HasSourcePack (ReaderT SourcePack m) where+ askSourcePack = ask++-- $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 view
@@ -0,0 +1,63 @@+{-# 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 ReloadableSourcePack = ReloadableSourcePack+ { sourcePack :: MVar SourcePack+ , reloadAll :: (SourcePack -> IO ([IO ()], [String])) -> IO (Bool, [String])+ }++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 (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 (True, es)+ else return (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)++runReloadable :: MonadIO m => SourcePack -> ReloadableSourcePackT m a -> m (a, IO (Bool, [String]))+runReloadable sp r = do+ rsp <- reloadableSourcePack sp+ (a, ReloadableSourcePack{..}) <- runStateT r rsp+ return (a, reloadAll (\_ -> return ([],[])))+++
+ src/Salak/Env.hs view
@@ -0,0 +1,34 @@+{-# 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 view
@@ -0,0 +1,32 @@+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++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 $ zipWith (,) [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
+ src/Salak/Prop.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Salak.Prop where++import Control.Applicative+import Control.Monad.Reader+import Data.Int+import qualified Data.IntMap.Strict as MI+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+ | N [Selector]+ | F [Selector] String+ 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++type Prop a = ReaderT SourcePack PResult a++infixl 5 .?=+(.?=) :: Prop a -> a -> Prop a+(.?=) a b = a <|> pure b++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 runReaderT (fromProp :: Prop a) sp 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 $ runReaderT fromProp (SourcePack (SNum ix:xx) x s xt)+ return (a:as)++-- | 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++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 runReaderT (readSelect key) sp 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 view
@@ -0,0 +1,204 @@+{-# 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 -> fromMaybe b $ (\a -> f a b) <$> Q.getMin q)++sizeSouce :: Source -> Int+sizeSouce = foldSource (\_ -> (+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 a b c = replace' [] a b c++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,141 +1,109 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where -import qualified Data.HashMap.Strict as M-import Data.Salak-import Data.Salak.CommandLine-import Data.Salak.Environment-import Data.Salak.Operation ()-import Data.Text (Text, intercalate, pack)-import System.Environment+import Data.Either+import Data.List (intercalate)+import Data.Text (Text, pack, unpack)+import GHC.Generics+import Salak.Prop+import Salak.Types import Test.Hspec import Test.QuickCheck + main = hspec spec spec :: Spec spec = do- describe "Data.Salak.Types" specProperty- describe "Data.Salak" specProperties- describe "Data.Salak.Dynamic" specDynamic+ describe "Salak.Types" specProperty -shouldFail :: (Show a, Eq a) => a -> a -> Expectation-shouldFail f a = (f `shouldBe` a) `shouldThrow` anyErrorCall+newtype SKey = SKey { unKey :: Text } deriving Show -data Config = Config- { name :: Text- , dir :: Text- , ext :: Int- } deriving (Eq, 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) -instance FromProperties Config where- fromProperties v = Config- <$> v .?> "name"- <*> v .?> "dir"- <*> v .?> "ext" .?= 1+data Conf = Conf+ { name :: String+ , age :: Int+ , male :: Bool+ , det :: SubConf+ } deriving (Eq, Show, Generic) +data SubConf = SubConf+ { hello :: String } deriving (Eq, Show, Generic)++instance FromProp SubConf where+ fromProp = SubConf <$> "hello" .?= "yyy"++instance FromProp Conf+ specProperty = do- context "empty" $ do- it "normal" $ do- let p = empty- print p- p `shouldBe` Properties [] []- context "toKeys" $ do- it "normal" $ do- [] `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 :: Int) -> let a = pack a' in Just b == (insert (toKeys a) (PNum $ fromIntegral b) empty) .>> a- quickCheck $ \a' (b :: Bool) -> let a = pack a' in Just b == (insert (toKeys a) (PBool b) empty) .>> a- quickCheck $ \a' (b :: String) -> let a = pack a' in Just b == (insert (toKeys a) (PStr $ pack b) empty) .>> a- context "lookup" $ do- it "normal" $ do- let m = insert ["a"] (PNum 1) empty- n = insert ["a"] (PStr "true") empty- (empty .>> "a" :: Maybe Int) `shouldBe` Nothing- (m .>> "a" :: Maybe Int) `shouldBe` Just 1- (m .>> "a" :: Maybe Bool) `shouldFail` Nothing- (m .>> "a" :: Maybe String) `shouldBe` Just "1.0"- (n .>> "a" :: Maybe Int) `shouldFail` Nothing- (n .>> "a" :: Maybe Bool) `shouldBe` Just True- (n .>> "a" :: Maybe Text) `shouldBe` Just "true"- context "makeProperties" $ do- it "normal" $ do- m <- makePropertiesFromEnvironment empty- h <- getEnv "HOME"- (m .>> "home") `shouldBe` Just h- context "command-line" $ do+ context "selectors" $ do it "normal" $ do- let args = ["--package.a.enabled=true","--package.b.enabled=false","package.c.enabled=false"]- m <- makePropertiesFromCommandLine' args defaultParseCommandLine empty- (m .>> "package.a.enabled") `shouldBe` Just True- (m .>> "package.b.enabled") `shouldBe` Just False- (m .>> "package.c.enabled" :: Maybe Bool )`shouldBe` Nothing- context "environment" $ 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 it "normal" $ do- let args = [("PACKAGE_A_ENABLED","true"),("PACKAGE_B_ENABLED","false")]- m = makePropertiesFromEnvironment' args empty- (m .>> "package.a.enabled") `shouldBe` Just True- (m .>> "package.b.enabled") `shouldBe` Just False- (m .>> "package.c.enabled" :: Maybe Bool )`shouldBe` Nothing+ 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")+ -- , ("det.hello", "world")+ ]+ e `shouldBe` []+ let a = search "" sp :: Either String Conf+ print a+ isRight a `shouldBe` True -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 .>> "salak.config.name" `shouldBe` Just confName- it "read config - replacement" $ do- setEnv "SALAK_CONFIG_NAME" confName- p <- defaultPropertiesWithFile "salak.ok"- p .>> "salak.config.name" `shouldBe` Just confName- it "read config - not found" $ do- setEnv "SALAK_CONFIG_NAME" "salak.notfound"- setEnv "SALAK_CONFIG_DIR" "test"- defaultPropertiesWithFile confName `shouldThrow` anyException- 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- (p .>> "salak.config.name") `shouldBe` Just confName- (p .>> "salak.config") `shouldBe` Just confName- (p .>> "salak.config" :: Maybe Config) `shouldBe` Just (Config confName' "test" 1)- (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++