salak 0.3.4 → 0.3.4.1
raw patch · 18 files changed
+627/−271 lines, 18 filesdep +criteriondep +megaparsecdep +salakdep −attoparsecPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: criterion, megaparsec, salak
Dependencies removed: attoparsec
API changes (from Hackage documentation)
- Salak.Internal: VZT :: !TimeZone -> !LocalTime -> Value
- Salak.Internal: runRun :: Monad m => RunSalakT m a -> SourcePack -> m a
- Salak.Trie: getMap :: Trie v -> HashMap Key (Trie v)
- Salak.Trie: getPrimitive :: Trie v -> Maybe v
+ Salak.Internal: loadAndRunSalak :: (MonadThrow m, MonadIO m) => LoadSalakT m () -> RunSalakT m a -> m a
+ Salak.Trie: Trie :: !Maybe v -> !HashMap Key (Trie v) -> Trie v
+ Salak.Trie: [tmap] :: Trie v -> !HashMap Key (Trie v)
+ Salak.Trie: [tvar] :: Trie v -> !Maybe v
- Salak.Internal: type TraceSource = Trie ([String], Vals)
+ Salak.Internal: type TraceSource = Trie TraceVals
- Salak.Trie: modify' :: Eq v => Keys -> (Trie v -> Trie v) -> Trie v -> Trie v
+ Salak.Trie: modify' :: Eq v => (Trie v -> Trie v) -> Keys -> Trie v -> Trie v
Files
- README.md +1/−1
- bench/SalakBench.hs +43/−0
- salak.cabal +45/−10
- src/Salak.hs +6/−6
- src/Salak/Internal.hs +55/−38
- src/Salak/Internal/Key.hs +53/−33
- src/Salak/Internal/Prop.hs +135/−30
- src/Salak/Internal/Source.hs +34/−19
- src/Salak/Internal/Val.hs +57/−45
- src/Salak/Internal/Writable.hs +3/−0
- src/Salak/Trie.hs +48/−28
- test/Salak/Internal/KeySpec.hs +1/−1
- test/Salak/Internal/PropSpec.hs +117/−31
- test/Salak/Internal/SourceSpec.hs +3/−3
- test/Salak/Internal/TrieSpec.hs +0/−24
- test/Salak/TrieSpec.hs +24/−0
- test/SalakSpec.hs +2/−0
- test/Spec.hs +0/−2
README.md view
@@ -18,7 +18,7 @@ ## Parse Functions -`HasSalak` monad provide a unified function `require` to parse properties. Here are some examples.+`MonadSalak` monad provide a unified function `require` to parse properties. Here are some examples. ```Haskell a :: Bool <- require "bool.key"
+ bench/SalakBench.hs view
@@ -0,0 +1,43 @@+module SalakBench(main) where++import Control.Monad.Reader+import Criterion.Main+import Data.Default+import Data.Text (Text)+import Salak+++main = do+ sp <- loadAndRunSalak' (loadMock vals) return+ let run :: forall a. ReaderT SourcePack IO a -> IO a+ run = flip runReaderT sp+ v <- run $ require "int" :: IO (IO Int)+ defaultMain+ [ bgroup "load"+ [ bench "loadMock" $ whnfIO $ loadAndRunSalak (loadMock vals) action+ , bench "loadCMD" $ whnfIO $ loadAndRunSalak (loadCommandLine def) action+ , bench "loadEnv" $ whnfIO $ loadAndRunSalak loadEnv action+ ]+ , bgroup "parse-io"+ [ bench "read-io" $ whnfIO v+ , bench "parse" $ whnfIO (run $ require "int" :: IO (IO Int))+ ]+ , bgroup "parse-int"+ [ bench "int" $ whnfIO (run $ require "int" :: IO Int)+ , bench "int/text" $ whnfIO (run $ require "int" :: IO Text)+ , bench "int/bool" $ whnfIO (run $ require "int" :: IO (Either String Bool))+ ]+ , bgroup "run"+ [ bench "text" $ whnfIO $ (run $ require "a.b.c.d.e.f.g.h.i.j.k.text" :: IO Text)+ , bench "bool" $ whnfIO $ (run $ require "a.b.c.d.e.f.g.h.i.j.k.bool" :: IO Bool)+ ]+ ]++action = return ()++vals =+ [ ("int", "128")+ , ("a.b.c.d.e.f.g.h.i.j.k.text", "xxx")+ , ("a.b.c.d.e.f.g.h.i.j.k.bool", "true")+ , ("empty", "")+ ]
salak.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: salak-version: 0.3.4+version: 0.3.4.1 license: MIT license-file: LICENSE copyright: 2019 Daniel YU@@ -27,11 +27,10 @@ Salak.Internal.Writable default-language: Haskell2010 default-extensions: RecordWildCards TupleSections OverloadedStrings- ScopedTypeVariables FlexibleInstances MultiParamTypeClasses- DeriveGeneric+ NoOverloadedLists ScopedTypeVariables FlexibleInstances+ MultiParamTypeClasses DeriveGeneric FlexibleContexts RankNTypes ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures build-depends:- attoparsec >=0.13.2.2 && <0.14, base >=4.10 && <5, bytestring >=0.10.8.2 && <0.11, containers >=0.6.0.1 && <0.7,@@ -42,6 +41,7 @@ filepath >=1.4.2.1 && <1.5, hashable >=1.2.7.0 && <1.3, heaps >=0.3.6.1 && <0.4,+ megaparsec >=7.0.5 && <7.1, menshen >=0.0.3 && <0.1, mtl >=2.2.2 && <2.3, scientific >=0.3.6.2 && <0.4,@@ -50,16 +50,16 @@ unliftio-core >=0.1.2.0 && <0.2, unordered-containers >=0.2.10.0 && <0.3 -test-suite spec+test-suite salak-spec type: exitcode-stdio-1.0- main-is: Spec.hs+ main-is: SalakSpec.hs build-tool-depends: hspec-discover:hspec-discover -any hs-source-dirs: test src other-modules: Salak.Internal.KeySpec Salak.Internal.PropSpec Salak.Internal.SourceSpec- Salak.Internal.TrieSpec+ Salak.TrieSpec Salak Salak.Internal Salak.Internal.Key@@ -71,12 +71,12 @@ Paths_salak default-language: Haskell2010 default-extensions: RecordWildCards TupleSections OverloadedStrings- ScopedTypeVariables FlexibleInstances MultiParamTypeClasses- DeriveGeneric+ NoOverloadedLists ScopedTypeVariables FlexibleInstances+ MultiParamTypeClasses DeriveGeneric FlexibleContexts RankNTypes ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures+ -main-is SalakSpec.main -rtsopts -threaded -with-rtsopts=-K1K build-depends: QuickCheck >=2.13.2 && <2.14,- attoparsec >=0.13.2.2 && <0.14, base >=4.10 && <5, bytestring >=0.10.8.2 && <0.11, containers >=0.6.0.1 && <0.7,@@ -88,9 +88,44 @@ hashable >=1.2.7.0 && <1.3, heaps >=0.3.6.1 && <0.4, hspec ==2.*,+ megaparsec >=7.0.5 && <7.1, menshen >=0.0.3 && <0.1, mtl >=2.2.2 && <2.3, random ==1.1.*,+ scientific >=0.3.6.2 && <0.4,+ text >=1.2.3.1 && <1.3,+ time >=1.8.0.2 && <1.9,+ unliftio-core >=0.1.2.0 && <0.2,+ unordered-containers >=0.2.10.0 && <0.3++benchmark salak-bench+ type: exitcode-stdio-1.0+ main-is: SalakBench.hs+ hs-source-dirs: bench+ other-modules:+ Paths_salak+ default-language: Haskell2010+ default-extensions: RecordWildCards TupleSections OverloadedStrings+ NoOverloadedLists ScopedTypeVariables FlexibleInstances+ MultiParamTypeClasses DeriveGeneric FlexibleContexts RankNTypes+ ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures+ -main-is SalakBench.main -rtsopts -threaded -with-rtsopts=-K1K+ build-depends:+ base >=4.10 && <5,+ bytestring >=0.10.8.2 && <0.11,+ containers >=0.6.0.1 && <0.7,+ criterion >=1.5.5.0 && <1.6,+ data-default >=0.7.1.1 && <0.8,+ directory >=1.3.3.0 && <1.4,+ dlist >=0.8.0.7 && <0.9,+ exceptions >=0.10.2 && <0.11,+ filepath >=1.4.2.1 && <1.5,+ hashable >=1.2.7.0 && <1.3,+ heaps >=0.3.6.1 && <0.4,+ megaparsec >=7.0.5 && <7.1,+ menshen >=0.0.3 && <0.1,+ mtl >=2.2.2 && <2.3,+ salak -any, scientific >=0.3.6.2 && <0.4, text >=1.2.3.1 && <1.3, time >=1.8.0.2 && <1.9,
src/Salak.hs view
@@ -9,7 +9,7 @@ -- | -- Module: Salak -- Copyright: 2019 Daniel YU--- License: BSD3+-- License: MIT -- Maintainer: leptonyu@gmail.com -- Stability: experimental -- Portability: portable@@ -100,8 +100,8 @@ True False defaultParseCommandLine- putStrLn (\_ -> return ())+ (\_ -> return ()) data FileConfig = FileConfig { configNm :: Maybe String@@ -109,6 +109,7 @@ } instance FromProp m FileConfig where+ {-# INLINE fromProp #-} fromProp = FileConfig <$> "name" .?= Nothing <*> "dir" .?= Nothing@@ -129,6 +130,7 @@ loadByExt :: HasLoad a => a -> FilePath -> LoadSalak () loadByExt xs f = mapM_ go (loaders xs) where+ {-# INLINE go #-} go (ext, ly) = tryLoadFile ly $ f ++ "." ++ ext -- | Default load salak.@@ -154,16 +156,14 @@ , ifS searchHome getHomeDirectory ] (loadConf $ fromMaybe configName configNm) where+ {-# INLINE ifS #-} ifS True gxd = Just <$> liftIO gxd ifS _ _ = return Nothing+ {-# INLINE loadConf #-} loadConf n mf = lift mf >>= mapM_ (liftNT . loadExt . (</> n)) loadSalakWith :: (MonadThrow m, MonadIO m, HasLoad file) => file -> String -> LoadSalakT m () loadSalakWith file name = loadSalak def { configName = name, loadExt = loadByExt file }---- | Standard salak functions, by load and run with `RunSalakT`.-loadAndRunSalak :: (MonadThrow m, MonadIO m) => LoadSalakT m () -> RunSalakT m a -> m a-loadAndRunSalak lstm ma = loadAndRunSalak' lstm $ runRun ma -- | Run salak, load strategy refer to `loadSalak` runSalak :: (MonadCatch m, MonadIO m) => PropConfig -> RunSalakT m a -> m a
src/Salak/Internal.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -14,7 +15,7 @@ -- | -- Module: Salak.Internal -- Copyright: 2019 Daniel YU--- License: BSD3+-- License: MIT -- Maintainer: leptonyu@gmail.com -- Stability: experimental -- Portability: portable@@ -23,13 +24,13 @@ -- module Salak.Internal( loadAndRunSalak'+ , loadAndRunSalak , loadTrie , loadList , LoadSalakT , LoadSalak , RunSalakT , RunSalak- , runRun , MonadSalak(..) , loadMock , loadEnv@@ -63,6 +64,7 @@ import qualified Control.Monad.IO.Unlift as IU import Control.Monad.Reader import qualified Control.Monad.State as MS+import Data.Char (toLower) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM import Data.Maybe@@ -89,15 +91,17 @@ } -- | Configuration Loader Monad, used for load properties from sources. Custom loaders using `loadTrie`-newtype LoadSalakT m a = LoadSalakT (MS.StateT UpdateSource m a)- deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MS.MonadState UpdateSource, MonadThrow, MonadCatch)+newtype LoadSalakT m a = LoadSalakT (MS.StateT UpdateSource m a)+ deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MS.MonadState UpdateSource, MonadThrow, MonadCatch) -- | Simple IO Monad type LoadSalak = LoadSalakT IO +{-# INLINE runLoad #-} runLoad :: Monad m => LoadSalakT m a -> UpdateSource -> m a runLoad (LoadSalakT ma) = MS.evalStateT ma +{-# INLINE liftNT #-} liftNT :: MonadIO m => LoadSalak () -> LoadSalakT m () liftNT a = MS.get >>= liftIO . runLoad a @@ -108,9 +112,7 @@ liftIO $ void $ swapMVar lfunc f logSalak msg = do UpdateSource{..} <- MS.get- liftIO $ do- f <- readMVar lfunc- f msg+ liftIO $ readMVar lfunc >>= ($ msg) instance (MonadThrow m, IU.MonadUnliftIO m) => IU.MonadUnliftIO (LoadSalakT m) where askUnliftIO = do@@ -118,41 +120,38 @@ lift $ IU.withUnliftIO $ \u -> return (IU.UnliftIO (IU.unliftIO u . flip runLoad ut)) -- | Standard `MonadSalak` instance.-newtype RunSalakT m a = RunSalakT (ReaderT SourcePack m a)+newtype RunSalakT m a = RunSalakT { runSalakT :: ReaderT SourcePack m a } deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadReader SourcePack, MonadThrow, MonadCatch) -- | Simple IO Monad type RunSalak = RunSalakT IO -runRun :: Monad m => RunSalakT m a -> SourcePack -> m a-runRun (RunSalakT ma) = runReaderT ma-- instance MonadIO m => MonadSalak (RunSalakT m) where askSourcePack = ask instance (MonadThrow m, IU.MonadUnliftIO m) => IU.MonadUnliftIO (RunSalakT m) where askUnliftIO = do ut <- ask- lift $ IU.withUnliftIO $ \u -> return (IU.UnliftIO (IU.unliftIO u . flip runRun ut))+ lift $ IU.withUnliftIO $ \u -> return (IU.UnliftIO (IU.unliftIO u . flip runReaderT ut . runSalakT)) -- | Basic loader loadTrie :: (MonadThrow m, MonadIO m) => Bool -> String -> (Int -> IO TraceSource) -> LoadSalakT m ()-loadTrie canReload name f = do+loadTrie !canReload !name f = do logSalak $ "Loading " ++ (if canReload then "[reloadable]" else "") ++ name UpdateSource{..} <- MS.get- v <- liftIO $ readMVar ref- ts <- liftIO $ loadSource f refNo (fmap ([],) v)- let (t,_,es) = extract v ts- if null es- then do- liftIO $ modifyMVar_ update $ \u -> go ts u refNo- let nut = UpdateSource ref (refNo + 1) (HM.insert refNo name refMap) lfunc qfunc update- _ <- liftIO $ swapMVar ref t- MS.put nut- else throwM $ PropException $ unlines es+ (MS.put=<<) $ liftIO $ do+ v <- readMVar ref+ ts <- loadSource f refNo (fmap ([],) v)+ let (t,_,es) = extract v ts+ if null es+ then do+ modifyMVar_ update $ go ts refNo+ _ <- swapMVar ref t+ return $ UpdateSource ref (refNo + 1) (HM.insert refNo name refMap) lfunc qfunc update+ else throwM $ PropException $ unlines es where- go ts ud n = return $ do+ {-# INLINE go #-}+ go ts n ud = return $ do (c,d) <- ud c1 <- loadSource (if canReload then f else (\_ -> return ts)) n c return (c1,d)@@ -166,24 +165,33 @@ loadAndRunSalak' :: (MonadThrow m, MonadIO m) => LoadSalakT m () -> (SourcePack -> m a) -> m a loadAndRunSalak' lstm f = load lstm >>= f +-- | Standard salak functions, by load and run with `RunSalakT`.+loadAndRunSalak :: (MonadThrow m, MonadIO m) => LoadSalakT m () -> RunSalakT m a -> m a+loadAndRunSalak lstm = loadAndRunSalak' lstm . runReaderT . runSalakT+ load :: (MonadThrow m, MonadIO m) => LoadSalakT m () -> m SourcePack load lm = do- r <- liftIO $ newMVar T.empty- q <- liftIO $ newMVar $ \s -> Right $ void $ swapMVar r s- u <- liftIO $ newMVar $ return (T.empty, return ())- l <- liftIO $ newMVar $ \_ -> return ()- runLoad (lm >> MS.get) (UpdateSource r 0 HM.empty l q u) >>= toSourcePack+ us <- liftIO $ do+ r <- newMVar T.empty+ q <- newMVar $ \s -> Right $ void $ swapMVar r s+ u <- newMVar $ return (T.empty, return ())+ l <- newMVar $ \_ -> return ()+ return $ UpdateSource r 0 HM.empty l q u+ runLoad (lm >> MS.get) us >>= toSourcePack +{-# INLINE toSourcePack #-} toSourcePack :: MonadIO m => UpdateSource -> m SourcePack-toSourcePack UpdateSource{..} = liftIO (readMVar ref) >>= \s -> return $ SourcePack s s S.empty mempty qfunc lfunc go- where- go = do+toSourcePack UpdateSource{..} = liftIO $ do+ s <- readMVar ref+ return+ $ SourcePack s s S.empty mempty qfunc lfunc+ $ do t <- readMVar ref (ts, ac) <- join $ readMVar update- let (s,cs,es) = extract t ts+ let (t1,cs,es) = extract t ts f <- readMVar qfunc if null es- then case f s of+ then case f t1 of Left e -> return (ReloadResult True $ lines e) Right a -> ac >> a >> return (ReloadResult False $ lines $ show cs) else return (ReloadResult True es)@@ -196,9 +204,16 @@ loadEnv :: (MonadThrow m, MonadIO m) => LoadSalakT m () loadEnv = loadList False "environment" go where- go = concatMap split2 . filter ((/= '_') . head . fst) <$> getEnvironment- split2 (k,v) = [(TT.pack k,v),(convert k,v)]- convert = TT.toLower . TT.pack . map (\c -> if c == '_' then '.' else c)+ {-# INLINE go #-}+ go = fmap split2 . filter ((/= '_') . head . fst) <$> getEnvironment+ {-# INLINE split2 #-}+ split2 (k,v) = (convert k, mkValue' $ TT.pack v)+ {-# INLINE mkValue' #-}+ mkValue' v = case mkValue (VT v) of+ Left _ -> VR [VRT v]+ Right x -> x+ {-# INLINE convert #-}+ convert = TT.pack . map (\c -> if c == '_' then '.' else toLower c) -- | Convert arguments to properties type ParseCommandLine = [String] -> IO [(Text, Text)]@@ -207,6 +222,7 @@ defaultParseCommandLine :: ParseCommandLine defaultParseCommandLine = return . mapMaybe go where+ {-# INLINE go #-} go ('-':'-':as) = case break (=='=') as of (a,'=':b) -> Just (pack a, pack b) _ -> Nothing@@ -217,6 +233,7 @@ loadCommandLine pcl = loadList False "commandLine" (getArgs >>= pcl) -- | Try load file, if file does not exist then do nothing.+{-# INLINE tryLoadFile #-} tryLoadFile :: MonadIO m => (FilePath -> LoadSalakT m ()) -> FilePath -> LoadSalakT m () tryLoadFile f file = do b <- liftIO $ doesFileExist file
src/Salak/Internal/Key.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} module Salak.Internal.Key( Key(..)@@ -12,27 +13,33 @@ , ToKeys(..) , isNum , isStr- , exprs+ , keyExpr+ , Parser ) where -import Control.Applicative ((<|>))-import Data.Attoparsec.Text-import qualified Data.DList as D+import qualified Data.DList as D import Data.Hashable-import Data.List (intercalate)+import Data.List (intercalate) import Data.String-import Data.Text (Text)-import qualified Data.Text as T+import Data.Text (Text)+import qualified Data.Text as T+import Data.Void+import Text.Megaparsec+import Text.Megaparsec.Char+import Text.Megaparsec.Char.Lexer #if __GLASGOW_HASKELL__ < 804-import Data.Semigroup+import Data.Semigroup hiding (option) #endif +type Parser = Parsec Void Text+ data Key = KT !Text | KI !Int deriving Eq instance Ord Key where+ {-# INLINE compare #-} compare (KT a) (KT b) = compare a b compare (KI a) (KI b) = compare a b compare (KI _) _ = LT@@ -40,28 +47,37 @@ newtype Keys = Keys { unKeys :: D.DList Key } deriving (Eq, Ord) +{-# INLINE emptyKey #-} emptyKey :: Keys emptyKey = Keys D.empty +{-# INLINE singletonKey #-} singletonKey :: Key -> Keys singletonKey k = fromKeys [k] +{-# INLINE fromKeys #-} fromKeys :: [Key] -> Keys fromKeys = Keys . D.fromList +{-# INLINE toKeyList #-} toKeyList :: Keys -> [Key] toKeyList = D.toList . unKeys instance Semigroup Keys where+ {-# INLINE (<>) #-} (Keys a) <> (Keys b) = Keys $ a <> b instance Monoid Keys where+ {-# INLINE mempty #-} mempty = emptyKey+ {-# INLINE mappend #-} mappend = (<>) instance Show Keys where+ {-# INLINE show #-} show = intercalate "." . go . toKeyList where+ {-# INLINE go #-} go (a@(KT _):cs) = let (b,c) = break isStr cs in (show a ++ concat (show <$> b)) : go c go (a:cs) = show a : go cs go [] = []@@ -75,60 +91,64 @@ isNum _ = False instance Hashable Key where+ {-# INLINE hash #-} hash (KT a) = hash a hash (KI a) = hash a+ {-# INLINE hashWithSalt #-} hashWithSalt i (KT a) = hashWithSalt i a hashWithSalt i (KI a) = hashWithSalt i a instance Show Key where+ {-# INLINE show #-} show (KT x) = T.unpack x show (KI i) = "[" ++ show i ++ "]" simpleKeys :: Text -> Keys simpleKeys = fromKeys . fmap KT . filter (not.T.null) . T.splitOn "." -exprs :: Parser [Key]-exprs = concat <$> ( (expr <|> return []) `sepBy` char '.')+keyExpr :: Parser [Key]+keyExpr = concat <$> (option [] expr `sepBy` char '.')+ where+ -- xx+ -- xx.xx+ -- xx.xx[0]+ -- xx.xx[1].xx+ {-# INLINE expr #-}+ expr :: Parser [Key]+ expr = (:) <$> sName <*> many sNum -sName :: Parser Key-sName = KT . T.pack <$> do- a <- choice [letter, digit]- b <- many' (choice [letter, digit, char '-', char '_'])- return (a:b)+ {-# INLINE sName #-}+ sName :: Parser Key+ sName = KT . T.pack <$> some (alphaNumChar <|> char '-' <|> char '_') -sNum :: Parser Key-sNum = KI <$> paren decimal- where- paren e = do+ {-# INLINE sNum #-}+ sNum :: Parser Key+ sNum = do _ <- char '['- ex <- e+ ex <- decimal _ <- char ']'- return ex---- xx--- xx.xx--- xx.xx[0]--- xx.xx[1].xx-expr :: Parser [Key]-expr = (:) <$> sName <*> many' sNum+ return $ KI ex class ToKeys a where toKeys :: a -> Either String Keys instance IsString Keys where+ {-# INLINE fromString #-} fromString key = case toKeys key of Left _ -> singletonKey (KT $ T.pack key) Right k -> k instance ToKeys Keys where+ {-# INLINE toKeys #-} toKeys = Right instance ToKeys Text where- toKeys = fmap fromKeys . selectors- where- selectors = go . parse exprs . flip T.snoc '\n'- go (Done i r) = if i /= "\n" then Left $ "uncomplete parse" ++ T.unpack i else Right r- go a = Left (show a)+ -- toKeys = Right . simpleKeys+ {-# INLINE toKeys #-}+ toKeys k = case fmap fromKeys (parse keyExpr "" k) of+ Left e -> Left (errorBundlePretty e)+ Right x -> Right x instance ToKeys String where+ {-# INLINE toKeys #-} toKeys = toKeys . T.pack
src/Salak/Internal/Prop.hs view
@@ -12,6 +12,7 @@ {-# LANGUAGE UndecidableInstances #-} module Salak.Internal.Prop where +import Control.Applicative ((<|>)) import qualified Control.Applicative as A import Control.Concurrent.MVar import Control.Monad@@ -62,17 +63,17 @@ askReload :: m (IO ReloadResult) askReload = reload <$> askSourcePack + {-# INLINE setLogF #-} setLogF :: MonadIO m => (String -> IO ()) -> m () setLogF f = do SourcePack{..} <- askSourcePack liftIO $ void $ swapMVar lref f + {-# INLINE logSalak #-} logSalak :: MonadIO m => String -> m () logSalak msg = do SourcePack{..} <- askSourcePack- liftIO $ do- f <- readMVar lref- f msg+ liftIO $ readMVar lref >>= ($ msg) -- | Parse properties using `FromProp`. For example: --@@ -84,16 +85,22 @@ -- `require` supports parse `IO` values, which actually wrap a 'MVar' variable and can be reseted by reloading configurations. -- Normal value will not be affected by reloading configurations. require :: (MonadThrow m, FromProp m a) => Text -> m a- require ks = askSourcePack >>= \s -> runProp s $ do- case toKeys ks of+ require ks = do+ s <- askSourcePack+ runProp s $ case toKeys ks of Left e -> failKey (unpack ks) (PropException e) Right k -> withKeys k fromProp +instance Monad m => MonadSalak (ReaderT SourcePack m) where+ {-# INLINE askSourcePack #-}+ askSourcePack = ask+ -- | Property parser, used to parse property from `Value` newtype Prop m a = Prop { unProp :: ReaderT SourcePack (ExceptT SomeException m) a } deriving (Functor, Applicative, Monad, MonadReader SourcePack, MonadIO) +{-# INLINE runProp #-} runProp :: MonadThrow m => SourcePack -> Prop m a -> m a runProp sp (Prop p) = do v <- runExceptT (runReaderT p sp)@@ -101,12 +108,15 @@ Left e -> throwM e Right x -> return x +{-# INLINE withProp #-} withProp :: (SourcePack -> SourcePack) -> Prop m a -> Prop m a withProp = unsafeCoerce withReaderT +{-# INLINE withKey #-} withKey :: Key -> Prop m a -> Prop m a withKey = withKeys . singletonKey +{-# INLINE withKeys #-} withKeys :: Keys -> Prop m a -> Prop m a withKeys key = withProp $ \SourcePack{..} ->@@ -120,7 +130,7 @@ instance Exception SalakException -+{-# INLINE failKey #-} failKey :: Monad m => String -> SalakException -> Prop m a failKey ks e = do SourcePack{..} <- ask@@ -128,24 +138,28 @@ $ SalakException (go (show pref) ks) $ toException e where+ {-# INLINE go #-} go "" a = a go a "" = a go a b = a <> "." <> b -- | Automatic convert literal string into an instance of `Prop` @m@ @a@. instance (Monad m, FromProp m a) => IsString (Prop m a) where- fromString ks = do- case toKeys ks of- Left e -> failKey ks (PropException e)- Right k -> withKeys k fromProp+ {-# INLINE fromString #-}+ fromString ks = case toKeys ks of+ Left e -> failKey ks (PropException e)+ Right k -> withKeys k fromProp instance MonadTrans Prop where+ {-# INLINE lift #-} lift = Prop . lift . lift instance Monad m => A.Alternative (Prop m) where+ {-# INLINE empty #-} empty = failKey "" NullException + {-# INLINE (<|>) #-} a <|> b = do v <- try a case v of@@ -153,18 +167,23 @@ Left (_ :: SomeException) -> b instance Monad m => MonadError SomeException (Prop m) where+ {-# INLINE throwError #-} throwError = Prop . lift . throwError . toException+ {-# INLINE catchError #-} catchError (Prop ma) me = Prop $ do c <- ask lift $ catchError (runReaderT ma c) (\e -> runReaderT (unProp $ me e) c) instance Monad m => MonadThrow (Prop m) where+ {-# INLINE throwM #-} throwM = throwError . toException instance Monad m => MonadCatch (Prop m) where+ {-# INLINE catch #-} catch ma me = catchError ma (\e -> maybe (throwM e) me $ fromException e) instance Monad m => MonadFail (Prop m) where+ {-# INLINE fail #-} fail = failKey "" . PropException -- | Type class used to parse properties.@@ -173,9 +192,11 @@ -- | Parse properties from `Value`. fromProp :: Monad m => Prop m a default fromProp :: (Generic a, GFromProp m (Rep a), Monad m) => Prop m a+ {-# INLINE fromProp #-} fromProp = fmap to gFromProp instance FromProp m a => FromProp m (Maybe a) where+ {-# INLINE fromProp #-} fromProp = do v <- try fromProp case v of@@ -188,6 +209,7 @@ Right a -> return (Just a) instance FromProp m a => FromProp m (Either String a) where+ {-# INLINE fromProp #-} fromProp = do v <- try fromProp return $ case v of@@ -195,30 +217,36 @@ Right a -> Right a instance {-# OVERLAPPABLE #-} FromProp m a => FromProp m [a] where+ {-# INLINE fromProp #-} fromProp = do SourcePack{..} <- ask- sequence $ (`withKey` fromProp) <$> sort (filter isNum $ HM.keys $ TR.getMap source)+ sequence $ (`withKey` fromProp) <$> sort (filter isNum $ HM.keys $ TR.tmap source) instance {-# OVERLAPPABLE #-} (IsString s, FromProp m a) => FromProp m [(s, a)] where+ {-# INLINE fromProp #-} fromProp = do SourcePack{..} <- ask- sequence $ go <$> sort (filter isStr $ HM.keys $ TR.getMap source)+ sequence $ go <$> sort (filter isStr $ HM.keys $ TR.tmap source) where go k = (fromString $ show $ singletonKey k,) <$> withKey k fromProp instance (Eq s, Hashable s, IsString s, FromProp m a) => FromProp m (HM.HashMap s a) where+ {-# INLINE fromProp #-} fromProp = HM.fromList <$> fromProp instance (Eq s, Ord s, IsString s, FromProp m a) => FromProp m (M.Map s a) where+ {-# INLINE fromProp #-} fromProp = M.fromList <$> fromProp -- | Supports for parsing `IO` value. instance {-# OVERLAPPABLE #-} (MonadIO m, FromProp (Either SomeException) a, FromProp m a) => FromProp m (IO a) where+ {-# INLINE fromProp #-} fromProp = do sp <- ask a <- fromProp buildIO sp a +{-# INLINE buildIO #-} buildIO :: (MonadIO m, FromProp (Either SomeException) a) => SourcePack -> a -> m (IO a) buildIO sp a = liftIO $ do aref <- newMVar a@@ -259,16 +287,19 @@ -- > fromProp = Config -- > <$> "enabled" .?: enabled -- > <$> "level" .?: level+ {-# INLINE (.?:) #-} infixl 5 .?: (.?:) :: Default b => f a -> (b -> a) -> f a (.?:) fa b = fa .?= b def -- | Support for setting default normal value. instance {-# OVERLAPPABLE #-} A.Alternative f => PropOp f a where+ {-# INLINE (.?=) #-} (.?=) a b = a A.<|> pure b -- | Support for setting default `IO` value. instance (MonadIO m, FromProp (Either SomeException) a) => PropOp (Prop m) (IO a) where+ {-# INLINE (.?=) #-} (.?=) ma a = do sp <- ask v <- try ma@@ -277,13 +308,16 @@ Right o -> return o instance Monad m => HasValid (Prop m) where+ {-# INLINE invalid #-} invalid = Control.Monad.Fail.fail . toI18n --- | Parse primitive value from `Value`-readPrimitive :: Monad m => (Value -> Either String a) -> Prop m a-readPrimitive f = do+{-# INLINE readPrimitive' #-}+readPrimitive' :: Monad m => (Value -> Either String a) -> Prop m (Maybe a)+readPrimitive' f = do SourcePack{..} <- ask- let go (VRT t : as) = if null as then return t else (t <>) <$> go as+ let {-# INLINE go #-}+ go [VRT t] = return t+ go (VRT t : as) = (t <>) <$> go as go (VRR k d : as) = if S.member k kref then Control.Monad.Fail.fail $ "reference cycle of key " <> show k else do@@ -295,22 +329,30 @@ w <- case t of Just x -> return x _ -> if null d then A.empty else go d- if null as then return w else (w <>) <$> go as+ go (VRT w : as) go [] = A.empty+ {-# INLINE g2 #-} g2 (VR r) = VT <$> go r g2 v = return v- case TR.getPrimitive source >>= getVal of- Just v -> do- vy <- g2 v- case f vy of- Left e -> Control.Monad.Fail.fail e- Right a -> return a- _ -> A.empty+ {-# INLINE g3 #-}+ g3 vy+ | nullValue vy = return Nothing+ | otherwise = case f vy of+ Left e -> Control.Monad.Fail.fail e+ Right a -> return (Just a)+ maybe A.empty (g2 >=> g3) $ TR.tvar source >>= getVal +-- | Parse primitive value from `Value`+{-# INLINE readPrimitive #-}+readPrimitive :: Monad m => (Value -> Either String a) -> Prop m a+readPrimitive f = readPrimitive' f >>= maybe A.empty return+ -- | Parse enum value from `Text`+{-# INLINE readEnum #-} readEnum :: Monad m => (Text -> Either String a) -> Prop m a readEnum = readPrimitive . go where+ {-# INLINE go #-} go f (VT t) = f t go _ x = Left $ fst (typeOfV x) ++ " cannot convert to enum" @@ -319,89 +361,116 @@ gFromProp :: Monad m => Prop m (f a) instance {-# OVERLAPPABLE #-} (Constructor c, GFromProp m a) => GFromProp m (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+ {-# INLINE gFromProp #-}+ gFromProp+ | conIsRecord m = fmap M1 gFromProp+ | otherwise = fmap M1 $ gEnum $ T.pack (conName m)+ where m = undefined :: t c a x +{-# INLINE gEnum #-} gEnum :: (GFromProp m f, Monad m) => Text -> Prop m (f a) gEnum va = do o <- gFromProp readEnum $ \x -> if x==va then Right o else Left "enum invalid" instance {-# OVERLAPPABLE #-} (Selector s, GFromProp m a) => GFromProp m(M1 S s a) where+ {-# INLINE gFromProp #-} gFromProp = withKey (KT $ T.pack $ selName (undefined :: t s a p)) $ M1 <$> gFromProp instance {-# OVERLAPPABLE #-} GFromProp m a => GFromProp m (M1 D i a) where+ {-# INLINE gFromProp #-} gFromProp = M1 <$> gFromProp instance {-# OVERLAPPABLE #-} FromProp m a => GFromProp m (K1 i a) where- gFromProp = fmap K1 fromProp+ {-# INLINE gFromProp #-}+ gFromProp = fmap K1 fromProp instance Monad m => GFromProp m U1 where+ {-# INLINE gFromProp #-} gFromProp = pure U1 instance {-# OVERLAPPABLE #-} (GFromProp m a, GFromProp m b) => GFromProp m (a:*:b) where+ {-# INLINE gFromProp #-} gFromProp = (:*:) <$> gFromProp <*> gFromProp instance {-# OVERLAPPABLE #-} (GFromProp m a, GFromProp m b) => GFromProp m (a:+:b) where+ {-# INLINE gFromProp #-} gFromProp = fmap L1 gFromProp A.<|> fmap R1 gFromProp instance FromProp m a => FromProp m (Identity a) where+ {-# INLINE fromProp #-} fromProp = Identity <$> fromProp instance (FromProp m a, FromProp m b) => FromProp m (a,b) where+ {-# INLINE fromProp #-} fromProp = (,) <$> fromProp <*> fromProp instance (FromProp m a, FromProp m b, FromProp m c) => FromProp m(a,b,c) where+ {-# INLINE fromProp #-} fromProp = (,,) <$> fromProp <*> fromProp <*> fromProp instance (FromProp m a, FromProp m b, FromProp m c, FromProp m d) => FromProp m(a,b,c,d) where+ {-# INLINE fromProp #-} fromProp = (,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp instance (FromProp m a, FromProp m b, FromProp m c, FromProp m d, FromProp m e) => FromProp m(a,b,c,d,e) where+ {-# INLINE fromProp #-} fromProp = (,,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp instance (FromProp m a, FromProp m b, FromProp m c, FromProp m d, FromProp m e, FromProp m f) => FromProp m(a,b,c,d,e,f) where+ {-# INLINE fromProp #-} fromProp = (,,,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp instance (FromProp m a, FromProp m b, FromProp m c, FromProp m d, FromProp m e, FromProp m f, FromProp m g) => FromProp m(a,b,c,d,e,f,g) where+ {-# INLINE fromProp #-} fromProp = (,,,,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp instance (FromProp m a, FromProp m b, FromProp m c, FromProp m d, FromProp m e, FromProp m f, FromProp m g, FromProp m h) => FromProp m(a,b,c,d,e,f,g,h) where+ {-# INLINE fromProp #-} fromProp = (,,,,,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp instance (FromProp m a, FromProp m b, FromProp m c, FromProp m d, FromProp m e, FromProp m f, FromProp m g, FromProp m h, FromProp m i) => FromProp m(a,b,c,d,e,f,g,h,i) where+ {-# INLINE fromProp #-} fromProp = (,,,,,,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp instance FromProp m a => FromProp m (Min a) where+ {-# INLINE fromProp #-} fromProp = Min <$> fromProp instance FromProp m a => FromProp m (Max a) where+ {-# INLINE fromProp #-} fromProp = Max <$> fromProp instance FromProp m a => FromProp m (First a) where+ {-# INLINE fromProp #-} fromProp = First <$> fromProp instance FromProp m a => FromProp m (Last a) where+ {-# INLINE fromProp #-} fromProp = Last <$> fromProp instance FromProp m a => FromProp m (Dual a) where+ {-# INLINE fromProp #-} fromProp = Dual <$> fromProp instance FromProp m a => FromProp m (Sum a) where+ {-# INLINE fromProp #-} fromProp = Sum <$> fromProp instance FromProp m a => FromProp m (Product a) where+ {-# INLINE fromProp #-} fromProp = Product <$> fromProp instance FromProp m a => FromProp m (Option a) where+ {-# INLINE fromProp #-} fromProp = Option <$> fromProp instance FromProp m Bool where+ {-# INLINE fromProp #-} fromProp = readPrimitive go where+ {-# INLINE go #-} go (VB x) = Right x go (VT x) = case T.toLower x of "true" -> Right True@@ -412,26 +481,34 @@ go x = Left $ getType x ++ " cannot be bool" instance FromProp m Text where- fromProp = readPrimitive go+ {-# INLINE fromProp #-}+ fromProp = fromMaybe "" <$> readPrimitive' go where+ {-# INLINE go #-} go (VT x) = Right x go x = Right $ T.pack $ snd $ typeOfV x instance FromProp m TL.Text where+ {-# INLINE fromProp #-} fromProp = TL.fromStrict <$> fromProp instance FromProp m B.ByteString where+ {-# INLINE fromProp #-} fromProp = TB.encodeUtf8 <$> fromProp instance FromProp m BL.ByteString where+ {-# INLINE fromProp #-} fromProp = TBL.encodeUtf8 <$> fromProp instance FromProp m String where+ {-# INLINE fromProp #-} fromProp = T.unpack <$> fromProp instance FromProp m Scientific where+ {-# INLINE fromProp #-} fromProp = readPrimitive go where+ {-# INLINE go #-} go (VT x) = case readMaybe $ T.unpack x of Just v -> Right v _ -> Left "string convert number failed"@@ -439,90 +516,118 @@ go x = Left $ getType x ++ " cannot be number" instance FromProp m Float where+ {-# INLINE fromProp #-} fromProp = toRealFloat <$> fromProp instance FromProp m Double where+ {-# INLINE fromProp #-} fromProp = toRealFloat <$> fromProp instance FromProp m Integer where+ {-# INLINE fromProp #-} fromProp = toInteger <$> (fromProp :: Prop m Int) instance FromProp m Int where+ {-# INLINE fromProp #-} fromProp = fromProp >>= toNum instance FromProp m Int8 where+ {-# INLINE fromProp #-} fromProp = fromProp >>= toNum instance FromProp m Int16 where+ {-# INLINE fromProp #-} fromProp = fromProp >>= toNum instance FromProp m Int32 where+ {-# INLINE fromProp #-} fromProp = fromProp >>= toNum instance FromProp m Int64 where+ {-# INLINE fromProp #-} fromProp = fromProp >>= toNum instance FromProp m Word where+ {-# INLINE fromProp #-} fromProp = fromProp >>= toNum instance FromProp m Word8 where+ {-# INLINE fromProp #-} fromProp = fromProp >>= toNum instance FromProp m Word16 where+ {-# INLINE fromProp #-} fromProp = fromProp >>= toNum instance FromProp m Word32 where+ {-# INLINE fromProp #-} fromProp = fromProp >>= toNum instance FromProp m Word64 where+ {-# INLINE fromProp #-} fromProp = fromProp >>= toNum instance FromProp m NominalDiffTime where+ {-# INLINE fromProp #-} fromProp = fromInteger <$> fromProp instance FromProp m DiffTime where+ {-# INLINE fromProp #-} fromProp = fromInteger <$> fromProp instance (HasResolution a, Monad m) => FromProp m (Fixed a) where+ {-# INLINE fromProp #-} fromProp = fromInteger <$> fromProp +{-# INLINE toNum #-} toNum :: (Monad m, Integral i, Bounded i) => Scientific -> Prop m i toNum s = case toBoundedInteger s of Just v -> return v _ -> Control.Monad.Fail.fail "scientific number doesn't fit in the target representation" instance FromProp m CBool where+ {-# INLINE fromProp #-} fromProp = do b <- fromProp return $ if b then 1 else 0 instance FromProp m CShort where+ {-# INLINE fromProp #-} fromProp = CShort <$> fromProp instance FromProp m CUShort where+ {-# INLINE fromProp #-} fromProp = CUShort <$> fromProp instance FromProp m CInt where+ {-# INLINE fromProp #-} fromProp = CInt <$> fromProp instance FromProp m CUInt where+ {-# INLINE fromProp #-} fromProp = CUInt <$> fromProp instance FromProp m CLong where+ {-# INLINE fromProp #-} fromProp = CLong <$> fromProp instance FromProp m CULong where+ {-# INLINE fromProp #-} fromProp = CULong <$> fromProp instance FromProp m CLLong where+ {-# INLINE fromProp #-} fromProp = CLLong <$> fromProp instance FromProp m CULLong where+ {-# INLINE fromProp #-} fromProp = CULLong <$> fromProp instance FromProp m CFloat where+ {-# INLINE fromProp #-} fromProp = CFloat <$> fromProp instance FromProp m CDouble where+ {-# INLINE fromProp #-} fromProp = CDouble <$> fromProp
src/Salak/Internal/Source.hs view
@@ -12,7 +12,8 @@ import qualified Salak.Trie as T type Source = T.Trie Vals-type TraceSource = T.Trie ([String], Vals)+type TraceVals = ([String], Vals)+type TraceSource = T.Trie TraceVals -- | Reload result, show erros or changes. data ReloadResult = ReloadResult@@ -37,6 +38,7 @@ diff :: Source -> Source -> T.Trie ModType diff = T.unionWith' go where+ {-# INLINE go #-} go Nothing Nothing = Nothing go (Just a) Nothing = if nullVals a then Nothing else Just Add go Nothing (Just a) = if nullVals a then Nothing else Just Del@@ -61,27 +63,23 @@ gen :: (Foldable f, ToKeys k, ToValue v) => Int -> f (k,v) -> TraceSource gen i = foldr go T.empty where+ {-# INLINE go #-} go (k,v) x = case toKeys k of- Left e -> T.alter (g3 e) mempty x- Right k' -> T.alter (g2 $ Val i $ toVal v) k' x- g2 v (Just (a,c)) = case modVals v c of- Left e -> Just (e:a, c)- Right d -> Just (a, d)- g2 v _ = case singletonVals v of- Left e -> Just ([e], emptyVals)- Right d -> Just ([], d)- g3 e (Just (a,c)) = Just (e:a,c)- g3 e _ = Just ([e], emptyVals)+ Left e -> T.alter (setErr0 e) mempty x+ Right k' -> T.alter (setVal0 $ Val i $ toVal v) k' x +{-# INLINE fmt #-} fmt :: ModType -> Int -> String -> String -> String fmt m i s n = concat ['#' : show i, ' ' : show m, ' ' : s , ' ' : n] +{-# INLINE fmtMod #-} fmtMod :: Int -> String -> HashMap String ModType -> [String] fmtMod i name cs = fmap (\(k,v)-> fmt v i k name) (HM.toList cs) loadSource :: (Int -> IO TraceSource) -> Int -> TraceSource -> IO TraceSource loadSource f i ts = T.unionWith go ts <$> f i where+ {-# INLINE go #-} go Nothing Nothing = Nothing go (Just v) Nothing = Just v go Nothing (Just v) = Just v@@ -89,12 +87,29 @@ Left e -> Just (e:e1++e2, v2) Right v -> Just (e1++e2,v) +{-# INLINE traceError #-}+traceError :: Maybe TraceVals -> [String]+traceError Nothing = []+traceError (Just (e,_)) = e++{-# INLINE traceVals #-}+traceVals :: Maybe TraceVals -> Vals+traceVals Nothing = emptyVals+traceVals (Just (_,v)) = v++{-# INLINE setErr0 #-}+setErr0 :: String -> Maybe TraceVals -> Maybe TraceVals+setErr0 e (Just (a,c)) = Just (e:a,c)+setErr0 e _ = Just ([e], emptyVals)++{-# INLINE setVal0 #-}+setVal0 :: Val Value -> Maybe TraceVals -> Maybe TraceVals+setVal0 v tv =+ let tv2 = traceVals tv+ in case modVals v tv2 of+ Left e -> Just (e : traceError tv, tv2)+ Right x -> Just (traceError tv, x)++{-# INLINE setVal #-} setVal :: ToValue v => Int -> v -> TraceSource -> TraceSource-setVal i v = T.update go- where- go Nothing = case modVals (Val i $ toVal v) emptyVals of- Left e -> Just ([e], emptyVals)- Right x -> Just ([], x)- go (Just (e,vs)) = case modVals (Val i $ toVal v) vs of- Left e1 -> Just (e1:e, vs)- Right x -> Just (e, x)+setVal i v = T.update (setVal0 $ Val i $ toVal v)
src/Salak/Internal/Val.hs view
@@ -1,12 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} module Salak.Internal.Val where -import Control.Applicative-import Data.Attoparsec.Text+import Control.Applicative ((<|>)) import Data.ByteString (ByteString) import Data.Heap (Heap) import qualified Data.Heap as H@@ -18,8 +16,10 @@ import Data.Text.Encoding (decodeUtf8) import Data.Time import Salak.Internal.Key+import Text.Megaparsec+import Text.Megaparsec.Char #if __GLASGOW_HASKELL__ < 804-import Data.Semigroup((<>))+import Data.Semigroup ((<>)) #endif @@ -33,6 +33,7 @@ type Priority = Int +{-# INLINE priority #-} priority :: Val v -> Int priority (Val i _) = i @@ -45,8 +46,8 @@ show (VRT t) = T.unpack t show (VRR k m) = "${" <> show k <> (if null m then go m else ":" <> go m) <> "}" where- go [] = ""- go (x:as) = show x <> go as+ {-# INLINE go #-}+ go = foldr ((<>) . show) "" data Value = VT !Text@@ -55,67 +56,60 @@ | VLT !LocalTime | VD !Day | VH !TimeOfDay- | VZT !TimeZone !LocalTime | VU !UTCTime | VR ![VRef] deriving Eq +{-# INLINE nullValue #-}+nullValue :: Value -> Bool+nullValue (VT x) = T.null x+nullValue (VR []) = True+nullValue _ = False+ instance Show Value where show v = let (a,b) = typeOfV v in b ++ "::" ++ a +{-# INLINE typeOfV #-} typeOfV :: Value -> (String, String)-typeOfV (VT b) = ("Str", show b)-typeOfV (VI b) = ("Num", show b)-typeOfV (VB b) = ("Bool", show b)-typeOfV (VLT b) = ("LocalTime", show b)-typeOfV (VD b) = ("Day", show b)-typeOfV (VH b) = ("TimeOfDay", show b)-typeOfV (VZT _ b) = ("ZonedTime", show b)-typeOfV (VU b) = ("UTCTime", show b)-typeOfV (VR b) = ("Ref", show b)+typeOfV (VT b) = ("Str", show b)+typeOfV (VI b) = ("Num", show b)+typeOfV (VB b) = ("Bool", show b)+typeOfV (VLT b) = ("LocalTime", show b)+typeOfV (VD b) = ("Day", show b)+typeOfV (VH b) = ("TimeOfDay", show b)+typeOfV (VU b) = ("UTCTime", show b)+typeOfV (VR b) = ("Ref", show b) +{-# INLINE getType #-} getType :: Value -> String getType = fst . typeOfV +{-# INLINE mkValue #-} mkValue :: Value -> Either String Value-mkValue (VT v) = case parseOnly (vref <* endOfInput) v of- Left e -> Left e- Right x -> Right $ case go x of- [VRT _] -> VT v- vs -> VR vs- where- go (VRT a:VRT b:as) = go (VRT (a <> b):as)- go (VRT a:b:as) = VRT a:b:go as- go (a:as) = a : go as- go [] = []+mkValue (VT v) = if T.null v+ then Right (VT v)+ else case parse vref "" v of+ Left e -> Left (errorBundlePretty e)+ Right y -> Right $ case y of+ [VRT x] -> VT x+ vs -> VR vs mkValue v = Right v --- mkValue' :: Value -> Value--- mkValue' v = case mkValue v of--- Left _ -> v--- Right x -> x-+{-# INLINE exprChar #-} exprChar :: Parser Char-exprChar = satisfy (notInClass "\\${}") <|> go+exprChar = noneOf go <|> (char '\\' >> oneOf go) where- go = do- a <- char '\\'- v <- peekChar- case v of- Just '\\' -> char '\\'- Just '$' -> char '$'- Just '{' -> char '{'- Just '}' -> char '}'- Just x -> fail $ "error char sequence \\" <> [x]- _ -> return a+ go :: [Token Text]+ go = "${}\\" vref :: Parser [VRef]-vref = many1' (go <|> (VRT . T.pack <$> many1' exprChar))+vref = some (go <|> (VRT . T.pack <$> some exprChar)) where+ {-# INLINE go #-} go = do _ <- string "${"- k <- exprs- v <- option [] $ (char ':' >> option [VRT ""] vref )+ k <- keyExpr+ v <- option [] $ char ':' >> option [VRT ""] vref _ <- char '}' return (VRR (fromKeys k) v) @@ -129,20 +123,25 @@ instance Eq v => Ord (Val v) where compare (Val a _) (Val b _) = compare a b +{-# INLINE nullVals #-} nullVals :: Vals -> Bool nullVals (Vals v) = H.null v +{-# INLINE minimumVals #-} minimumVals :: Vals -> Val Value minimumVals (Vals h) = H.minimum h +{-# INLINE emptyVals #-} emptyVals :: Vals emptyVals = Vals H.empty +{-# INLINE deleteVals #-} deleteVals :: Int -> Vals -> (Bool, Vals) deleteVals i (Vals v) = let (a,b) = H.partition ((==i) . priority) v in (H.null a, Vals b) +{-# INLINE getVal #-} getVal :: Vals -> Maybe Value getVal (Vals v) | H.null v = Nothing@@ -152,38 +151,50 @@ toVal :: a -> Value instance ToValue Value where+ {-# INLINE toVal #-} toVal = id instance ToValue Text where+ {-# INLINE toVal #-} toVal = VT instance ToValue ByteString where+ {-# INLINE toVal #-} toVal = VT . decodeUtf8 instance ToValue String where+ {-# INLINE toVal #-} toVal = VT . T.pack instance ToValue Scientific where+ {-# INLINE toVal #-} toVal = VI instance ToValue Integer where+ {-# INLINE toVal #-} toVal = VI . fromInteger instance ToValue Int where+ {-# INLINE toVal #-} toVal = VI . fromInteger . toInteger instance ToValue Int64 where+ {-# INLINE toVal #-} toVal = VI . fromInteger . toInteger instance ToValue Double where+ {-# INLINE toVal #-} toVal = VI . realToFrac instance ToValue Bool where+ {-# INLINE toVal #-} toVal = VB instance ToValue UTCTime where+ {-# INLINE toVal #-} toVal = VU +{-# INLINE delVals #-} delVals :: Int -> Vals -> Vals delVals p (Vals v) = Vals $ H.filter ((/=p) . priority) v @@ -192,6 +203,7 @@ Left e -> Left e Right y -> Right $ Vals $ H.insert (Val p y) $ H.filter ((/=p) . priority) v +{-# INLINE singletonVals #-} singletonVals :: Val Value -> Either String Vals singletonVals (Val p x) = case mkValue x of Left e -> Left e
src/Salak/Internal/Writable.hs view
@@ -20,12 +20,14 @@ } -- | Convert a `IO` value to `Writable` value.+{-# INLINE toWritable #-} toWritable :: IO a -> IO (Writable a) toWritable valRef = do setRef <- newMVar Nothing return Writable{..} -- | Get value.+{-# INLINE getWritable #-} getWritable :: Writable a -> IO a getWritable Writable{..} = do v <- readMVar setRef@@ -34,5 +36,6 @@ _ -> valRef -- | Set or remove override value.+{-# INLINE setWritable #-} setWritable :: Maybe a -> Writable a -> IO () setWritable s Writable{..} = void $ swapMVar setRef s
src/Salak/Trie.hs view
@@ -3,7 +3,7 @@ -- | -- Module: Salak.Internal -- Copyright: 2019 Daniel YU--- License: BSD3+-- License: MIT -- Maintainer: leptonyu@gmail.com -- Stability: experimental -- Portability: portable@@ -11,9 +11,7 @@ -- A data structure for manipulating properties. -- module Salak.Trie(- Trie- , getPrimitive- , getMap+ Trie(..) -- * Construction , empty , singleton@@ -57,115 +55,137 @@ import Text.Show (Show (..)) -- | A Trie from keys `Key` to values @v@, which is a recursive map.-data Trie v = Trie !(Maybe v) !(HashMap Key (Trie v)) deriving (Eq, Functor)+data Trie v = Trie+ { tvar :: !(Maybe v)+ , tmap :: !(HashMap Key (Trie v))+ } deriving (Eq, Functor) instance Show v => Show (Trie v) where show t = intercalate "\n" $ map (\(k,v)-> show k ++ ":" ++ show v) $ Salak.Trie.toList t instance Foldable Trie where- foldr f b (Trie v m) = foldr (flip (foldr f)) (go v) m+ {-# INLINE foldr #-}+ foldr f b Trie{..} = foldr (flip (foldr f)) (go tvar) tmap where+ {-# INLINE go #-} go (Just x) = f x b go _ = b instance Traversable Trie where- traverse f (Trie v m) = Trie <$> go v <*> traverse (traverse f) m+ {-# INLINE traverse #-}+ traverse f Trie{..} = Trie <$> go tvar <*> traverse (traverse f) tmap where+ {-# INLINE go #-} go (Just x) = Just <$> f x go _ = pure Nothing -- | /O(1)/. A trie with a single element.+{-# INLINE singleton #-} singleton :: v -> Trie v singleton v = Trie (Just v) HM.empty -- | /O(1)/. The empty trie.+{-# INLINE empty #-} empty :: Trie v empty = Trie Nothing HM.empty --- | Get primitive value of a trie.-getPrimitive :: Trie v -> Maybe v-getPrimitive (Trie v _) = v---- | Get map value of a trie.-getMap :: Trie v -> HashMap Key (Trie v)-getMap (Trie _ m) = m- -- | /O(1)/. Return True if this trie is empty, False otherwise.+{-# INLINE null #-} null :: Trie v -> Bool null (Trie Nothing e) = HM.null e null _ = False -- | /O(log (n+m))/. Return True if the specified key is present in the trie, False otherwise.+{-# INLINE member #-} member :: Eq v => Keys -> Trie v -> Bool member k t = isJust (lookup k t) +{-# INLINE subTrie #-} subTrie :: Key -> Trie v -> Trie v-subTrie key = fromMaybe empty . HM.lookup key . getMap+subTrie key = fromMaybe empty . HM.lookup key . tmap +{-# INLINE subTries #-} subTries :: Keys -> Trie v -> Trie v-subTries ks v = foldl (flip subTrie) v (toKeyList ks)+subTries = flip (foldl' $ flip subTrie) . toKeyList -- | /O(log (n+m))/. Return the primitive value to which the specified key is mapped, -- or Nothing if this trie contains no mapping for the key.+{-# INLINE lookup #-} lookup :: Eq v => Keys -> Trie v -> Maybe v-lookup keys = getPrimitive . subTries keys+lookup keys = tvar . subTries keys -- | /O(log n)/. Associate the specified value with the specified key in this trie. -- If this trie previously contained a mapping for the key, the old value is replaced.+{-# INLINE insert #-} insert :: Eq v => Keys -> v -> Trie v -> Trie v-insert ks v = alter (\_ -> Just v) ks+insert ks v = alter (const $ Just v) ks -- | /O(log m)/. The expression (`modify` k f trie) modifies the sub trie at k.+{-# INLINE modify #-} modify :: Eq v => Key -> (Trie v -> Trie v) -> Trie v -> Trie v-modify k f (Trie v m) = Trie v $ HM.alter (go . f . fromMaybe empty) k m- where- go x = if x == empty then Nothing else Just x+modify k f (Trie v m) = Trie v $ HM.alter (convert . f . fromMaybe empty) k m +{-# INLINE convert #-}+convert :: Eq v => Trie v -> Maybe (Trie v)+convert x = if x == empty then Nothing else Just x+ -- | /O(log (n+m))/. The expression (`modify'` ks f trie) modifies the sub trie at ks.-modify' :: Eq v => Keys -> (Trie v -> Trie v) -> Trie v -> Trie v-modify' ks f = foldr modify f (toKeyList ks)+{-# INLINE modify' #-}+modify' :: Eq v => (Trie v -> Trie v) -> Keys -> Trie v -> Trie v+modify' f = foldr modify f . toKeyList -- | /O(1)/. The expression (update f trie) updates the primitive value in the trie.+{-# INLINE update #-} update :: Eq v => (Maybe v -> Maybe v) -> Trie v -> Trie v-update f = alter f mempty+update = flip alter mempty -- | /O(n)/. The expression (update f ks trie) updates the primitive value of sub trie at ks.+{-# INLINE alter #-} alter :: Eq v => (Maybe v -> Maybe v) -> Keys -> Trie v -> Trie v-alter f keys = modify' keys (\(Trie a b) -> Trie (f a) b)+alter f = modify' (\(Trie a b) -> Trie (f a) b) -- | /O(n*m)/. Return a list of this tries's elements. The list is produced lazily. toList :: Trie v -> [(Keys, v)] toList = go D.empty where+ {-# INLINE go #-} go p (Trie (Just v) m) = (Keys p, v) : g2 p m go p (Trie _ m) = g2 p m+ {-# INLINE g2 #-} g2 p m = concat $ g3 p <$> HM.toList m+ {-# INLINE g3 #-} g3 p (k,t) = go (D.snoc p k) t -- | /O(n*m*log n)/. Construct a trie with the supplied mappings. -- If the list contains duplicate mappings, the later mappings take precedence.+{-# INLINE fromList #-} fromList :: Eq v => [(Keys, v)] -> Trie v fromList = foldr (uncurry insert) empty -- | /O(n)/. Filter this trie by retaining only elements which values satisfy a predicate.+{-# INLINE filter #-} filter :: Eq v => (v -> Bool) -> Trie v -> Trie v filter f (Trie v m) = if ok v then Trie v go else Trie Nothing go where+ {-# INLINE ok #-} ok (Just x) = f x ok _ = False- go = HM.mapMaybe (g2 . filter f) m- g2 x = if x == empty then Nothing else Just x+ {-# INLINE go #-}+ go = HM.mapMaybe (convert . filter f) m -- | /O(n+m)/. The union of two tries. -- If a key occurs in both tries, the provided function (first argument) will be used to compute the result.+{-# INLINE unionWith #-} unionWith :: Eq v => (Maybe v -> Maybe v -> Maybe v) -> Trie v -> Trie v -> Trie v unionWith f (Trie v1 m1) (Trie v2 m2) = Trie (f v1 v2) $ HM.unionWith (unionWith f) m1 m2 -- | /O(n+m)/. The union of two tries. -- All the keys will be calculated by the provided function.+{-# INLINE unionWith' #-} unionWith' :: (Maybe v -> Maybe v -> Maybe v3) -> Trie v -> Trie v -> Trie v3 unionWith' f (Trie v1 m1) (Trie v2 m2) = Trie (f v1 v2) $ foldr go HM.empty $ HM.keys $ HM.union m1 m2 where+ {-# INLINE go #-} go k = let x1 = fromMaybe empty $ HM.lookup k m1 x2 = fromMaybe empty $ HM.lookup k m2
test/Salak/Internal/KeySpec.hs view
@@ -1,4 +1,4 @@-module Salak.Internal.KeySpec where+module Salak.Internal.KeySpec(spec) where import Data.List (intercalate) import Data.Text (Text, pack, unpack)
test/Salak/Internal/PropSpec.hs view
@@ -1,45 +1,113 @@-module Salak.Internal.PropSpec where+module Salak.Internal.PropSpec(spec) where -import Control.Concurrent.MVar import Control.Monad.Writer import Data.Either import Data.Int-import qualified Data.Set as S+import Data.Scientific+import Data.Text (Text)+import Data.Word import Salak import Salak.Internal+import Salak.Internal.Prop import Salak.Internal.Val-import qualified Salak.Trie as T import Test.Hspec -newSource :: Value -> Source-newSource v = case modVals (Val 0 v) emptyVals of- Left _ -> T.empty- Right x -> T.singleton x--newSourcePack :: Value -> IO SourcePack-newSourcePack v = do- let source = newSource v- origin = source- kref = S.empty- pref = mempty- reload = return $ ReloadResult False []- qref <- newMVar $ \_ -> Right (return ())- lref <- newMVar $ \_ -> return ()- return SourcePack{..}- spec :: SpecWith () spec = do- context "VT" $ do- it "text" $ do- sp <- newSourcePack (VT "128")- let run :: forall m a. Monad m => RunSalakT m a -> m a- run = (`runRun` sp)- vInt <- run $ require ""- vInt32 <- run $ require ""- 128 `shouldBe` (vInt :: Int)- 128 `shouldBe` (vInt32 :: Int32)+ context "Prop" $ do+ let vals =+ [ ("int", "128")+ , ("bool-1", "yes")+ , ("bool-2", "no")+ , ("bool-3", "true")+ , ("bool-4", "false")+ , ("bool-L1", "YES")+ , ("bool-L2", "NO")+ , ("bool-L3", "TRUE")+ , ("bool-L4", "FALSE")+ , ("int-", "-1")+ , ("empty", "")+ ]+ run :: ((forall a. FromProp IO a => Text -> IO a) -> RunSalak ()) -> IO ()+ run g = loadAndRunSalak (loadMock vals) $ do+ sp <- askSourcePack+ let f k = case toKeys k of+ Left e -> fail e+ Right x -> runProp sp (withKeys x fromProp)+ g f+ it "bool" $ run $ \r -> do+ b1 <- require "bool-1"+ b2 <- require "bool-2"+ b3 <- require "bool-3"+ b4 <- require "bool-4"+ bL1 <- require "bool-L1"+ bL2 <- require "bool-L2"+ bL3 <- require "bool-L3"+ bL4 <- require "bool-L4"+ lift $ do+ b1 `shouldBe` True+ b2 `shouldBe` False+ b3 `shouldBe` True+ b4 `shouldBe` False+ bL1 `shouldBe` True+ bL2 `shouldBe` False+ bL3 `shouldBe` True+ bL4 `shouldBe` False+ (r "int" :: IO Bool) `shouldThrow` anyException+ it "scientific" $ run $ \_ -> do+ n <- require "int"+ n_ <- require "int-"+ lift $ do+ (n :: Scientific) `shouldBe` 128+ (n_ :: Scientific) `shouldBe` (-1)+ it "int" $ run $ \r -> do+ v <- require "int"+ v16 <- require "int"+ v32 <- require "int"+ v64 <- require "int"+ vm <- require "empty"+ lift $ do+ (v :: Int) `shouldBe` 128+ (v16 :: Int16) `shouldBe` 128+ (v32 :: Int32) `shouldBe` 128+ (v64 :: Int64) `shouldBe` 128+ (vm :: Maybe Int) `shouldBe` Nothing+ (r "int" :: IO Int8) `shouldThrow` anyException+ it "word" $ run $ \_ -> do+ v <- require "int"+ v8 <- require "int"+ v16 <- require "int"+ v32 <- require "int"+ v64 <- require "int"+ lift $ do+ (v :: Word) `shouldBe` 128+ (v8 :: Word8) `shouldBe` 128+ (v16 :: Word16) `shouldBe` 128+ (v32 :: Word32) `shouldBe` 128+ (v64 :: Word64) `shouldBe` 128+ it "maybe" $ run $ \_ -> do+ v <- require "int"+ n <- require "int.not.found"+ ev <- require "int"+ en <- require "int.not.found"+ lift $ do+ (v :: Maybe Int) `shouldBe` Just 128+ (n :: Maybe Int) `shouldBe` Nothing+ (ev :: Either String Int) `shouldBe` Right 128+ (en :: Either String Int) `shouldSatisfy` isLeft+ it "text" $ run $ \_ -> do+ v <- require "empty"+ vm <- require "empty"+ n <- require "not.found"+ lift $ do+ (v :: String) `shouldBe` ""+ (vm :: Maybe String) `shouldBe` Just ""+ (n :: Maybe String) `shouldBe` Nothing context "placeholder" $ do- it "placeholder" $ do+ it "positive" $ do+ mkValue (VT "${}") `shouldBe` Right (VR [VRR "" []])+ mkValue (VT "${:${}}") `shouldBe` Right (VR [VRR "" [VRR "" []]])+ mkValue (VT "${a.b}") `shouldBe` Right (VR [VRR "a.b" []]) mkValue (VT "${xxxx}") `shouldBe` Right (VR [VRR "xxxx" []]) mkValue (VT "${xxxx:}") `shouldBe` Right (VR [VRR "xxxx" [VRT ""]]) mkValue (VT "${xxxx:7}") `shouldBe` Right (VR [VRR "xxxx" [VRT "7"]])@@ -48,27 +116,45 @@ mkValue (VT "--${xxxx:7}") `shouldBe` Right (VR [VRT "--", VRR "xxxx" [VRT "7"]]) mkValue (VT "${xxxx:7}\\}") `shouldBe` Right (VR [VRR "xxxx" [VRT "7"], VRT "}"]) mkValue (VT "128") `shouldBe` Right (VT "128")+ mkValue (VT "\\$") `shouldBe` Right (VT "$")+ mkValue (VT "\\\\") `shouldBe` Right (VT "\\")+ mkValue (VT "\\{") `shouldBe` Right (VT "{")+ mkValue (VT "\\}") `shouldBe` Right (VT "}")+ it "negative" $ do+ mkValue (VT "${${}}") `shouldSatisfy` isLeft mkValue (VT "${128") `shouldSatisfy` isLeft- it "source" $ do+ mkValue (VT "$") `shouldSatisfy` isLeft+ mkValue (VT "{}") `shouldSatisfy` isLeft+ mkValue (VT "}") `shouldSatisfy` isLeft+ it "parse placeholder" $ do let vals = [ ("hello","${hey}") , ("hey","girl") , ("ok", "${xx:girl}") , ("nk", "${xx}")+ , ("world", "${hey}, world") , ("a", "${b}") , ("b", "${a}")+ , ("c", "${:${}}")+ , ("d", "${:}") ] loadAndRunSalak (loadMock vals) $ do v <- require "hello" x <- require "hey"+ t <- require "world" y <- require "a" z <- require "ok" w <- require "nk"+ c <- require "c"+ d <- require "d" lift $ do (x :: String) `shouldBe` "girl" (v :: String) `shouldBe` "girl" (z :: String) `shouldBe` "girl"+ (t :: String) `shouldBe` "girl, world"+ (d :: String) `shouldBe` "" (w :: Either String String) `shouldSatisfy` isLeft (y :: Either String String) `shouldSatisfy` isLeft+ (c :: Either String String) `shouldSatisfy` isLeft
test/Salak/Internal/SourceSpec.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE NoOverloadedLists #-}-module Salak.Internal.SourceSpec where+module Salak.Internal.SourceSpec(spec) where import Control.Monad.Writer import Data.Text (Text, unpack)@@ -30,6 +29,7 @@ loadRandom :: (MonadThrow m, MonadIO m) => Text -> LoadSalakT m () loadRandom key = loadList True (unpack key) go where+ go :: IO [(Text, Int)] go = do a :: Int <- randomIO return [(key, a)]@@ -37,7 +37,7 @@ spec :: SpecWith () spec = do context "source" $ do- it "normal - 2" $ do+ it "normal - 1" $ do let (_,b,c) = extract T.empty $ gen 0 ([("hello", "world")] :: [(Text, Text)]) length c `shouldBe` 0 length (T.toList b) `shouldBe` 1
− test/Salak/Internal/TrieSpec.hs
@@ -1,24 +0,0 @@-module Salak.Internal.TrieSpec where--import qualified Data.HashMap.Strict as HM-import Salak.Internal.Key-import qualified Salak.Trie as T-import Test.Hspec---spec :: SpecWith ()-spec = do- context "Trie" $ do- it "insert" $ do- let Right keys = toKeys ("a.b.c" :: String)- v = T.insert keys (1 :: Int) T.empty- w = T.alter (\_ -> Just 1) keys T.empty- v `shouldBe` w- T.getPrimitive (T.subTries keys v) `shouldBe` Just 1- it "toList" $ do- let Right keys = toKeys ("a.b.c.d" :: String)- w = T.insert keys (2 :: Int) T.empty- [(k,v)] = T.toList w- k `shouldBe` keys- v `shouldBe` 2- HM.member (KT "a") (T.getMap w) `shouldBe` True
+ test/Salak/TrieSpec.hs view
@@ -0,0 +1,24 @@+module Salak.TrieSpec(spec) where++import qualified Data.HashMap.Strict as HM+import Salak.Internal.Key+import qualified Salak.Trie as T+import Test.Hspec+++spec :: SpecWith ()+spec = do+ context "Trie" $ do+ it "insert" $ do+ let Right keys = toKeys ("a.b.c" :: String)+ v = T.insert keys (1 :: Int) T.empty+ w = T.alter (\_ -> Just 1) keys T.empty+ v `shouldBe` w+ T.tvar (T.subTries keys v) `shouldBe` Just 1+ it "toList" $ do+ let Right keys = toKeys ("a.b.c.d" :: String)+ w = T.insert keys (2 :: Int) T.empty+ [(k,v)] = T.toList w+ k `shouldBe` keys+ v `shouldBe` 2+ HM.member (KT "a") (T.tmap w) `shouldBe` True
+ test/SalakSpec.hs view
@@ -0,0 +1,2 @@+-- file test/Spec.hs+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=SalakSpec #-}
− test/Spec.hs
@@ -1,2 +0,0 @@--- file test/Spec.hs-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}