salak 0.2.10 → 0.3
raw patch · 18 files changed
+1375/−1328 lines, 18 filesdep +exceptionsdep +hashabledep +heapsdep −containersdep −pqueue
Dependencies added: exceptions, hashable, heaps, unordered-containers
Dependencies removed: containers, pqueue
Files
- README.md +10/−10
- salak.cabal +23/−23
- src/Salak.hs +70/−134
- src/Salak/Internal.hs +231/−0
- src/Salak/Internal/Key.hs +100/−0
- src/Salak/Internal/Prop.hs +445/−0
- src/Salak/Internal/Source.hs +105/−0
- src/Salak/Internal/Val.hs +133/−0
- src/Salak/Load.hs +0/−37
- src/Salak/Load/Dynamic.hs +0/−99
- src/Salak/Load/Env.hs +0/−38
- src/Salak/Prop.hs +0/−443
- src/Salak/Trie.hs +113/−0
- src/Salak/Types.hs +0/−146
- src/Salak/Types/Selector.hs +0/−62
- src/Salak/Types/Source.hs +0/−91
- src/Salak/Types/Value.hs +0/−105
- test/Spec.hs +145/−140
README.md view
@@ -69,7 +69,7 @@ , ext :: Int } deriving (Eq, Show) -instance FromProp Config where+instance MonadCatch m => FromProp m Config where fromProp = Config <$> "user" ? pattern "[a-z]{5,16}" <*> "pwd"@@ -77,22 +77,22 @@ main = runSalakWith "salak" (YAML :|: TOML) $ do c :: Config <- require "test.config"- lift $ print c+ lift $ print c= ``` GHCi play ```Haskell+λ> :set -XFlexibleInstances -XMultiParamTypeClasses λ> import Salak-λ> import Salak.Yaml-λ> import Salak.Toml-λ> import Data.Menshen-λ> :set -XTypeApplications-λ> instance FromProp Config where fromProp = Config <$> "user" <*> "dir" <*> "ext" .?= 1-λ> f = runSalakWith "salak" (YAML :|: TOML)-λ> f (require "") >>= print @Config-Config {name = "daniel", dir = Just "ls", ext = 2}+λ> import Data.Default+λ> import Data.Text(Text)+λ> data Config = Config { name :: Text, dir :: Maybe Text, ext :: Int} deriving (Eq, Show)+λ> instance MonadCatch m => FromProp m Config where fromProp = Config <$> "user" <*> "dir" <*> "ext" .?= 1+λ> runSalak def (require "") :: IO Config+Config {name = "daniel", dir = Nothing, ext = 1} ``` TODO:+- Recover placeholder - Add git pull support. - Add automatic reloading.
salak.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: salak-version: 0.2.10+version: 0.3 license: BSD3 license-file: LICENSE copyright: (c) 2018 Daniel YU@@ -16,33 +16,33 @@ library exposed-modules: Salak- Salak.Load+ Salak.Trie+ Salak.Internal hs-source-dirs: src other-modules:- Salak.Types- Salak.Types.Value- Salak.Types.Selector- Salak.Types.Source- Salak.Load.Env- Salak.Load.Dynamic- Salak.Prop+ Salak.Internal.Key+ Salak.Internal.Val+ Salak.Internal.Source+ Salak.Internal.Prop default-language: Haskell2010 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, data-default >=0.7.1.1 && <0.8, directory >=1.3.3.0 && <1.4,+ 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, menshen >=0.0.3 && <0.1, mtl >=2.2.2 && <2.3,- pqueue >=1.4.1.2 && <1.5, 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+ unliftio-core >=0.1.2.0 && <0.2,+ unordered-containers >=0.2.10.0 && <0.3 test-suite spec type: exitcode-stdio-1.0@@ -50,14 +50,12 @@ hs-source-dirs: test src other-modules: Salak- Salak.Load- Salak.Load.Dynamic- Salak.Load.Env- Salak.Prop- Salak.Types- Salak.Types.Selector- Salak.Types.Source- Salak.Types.Value+ Salak.Internal+ Salak.Internal.Key+ Salak.Internal.Prop+ Salak.Internal.Source+ Salak.Internal.Val+ Salak.Trie Paths_salak default-language: Haskell2010 ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures@@ -66,16 +64,18 @@ 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, data-default >=0.7.1.1 && <0.8, directory >=1.3.3.0 && <1.4,+ 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, hspec ==2.*, menshen >=0.0.3 && <0.1, mtl >=2.2.2 && <2.3,- pqueue >=1.4.1.2 && <1.5, 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+ unliftio-core >=0.1.2.0 && <0.2,+ unordered-containers >=0.2.10.0 && <0.3
src/Salak.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -19,71 +20,74 @@ -- $use -- * Salak Main Functions- loadAndRunSalak- , runSalak+ runSalak , runSalakWith+ , loadAndRunSalak+ , loadAndRunSalak' , PropConfig(..)- -- * Load Salak+ -- * Run Functions+ , HasSalak(..)+ , MonadSalak(..)+ , RunSalakT+ , RunSalak+ -- * Load Functions+ -- ** Monad for Loader , LoadSalakT- , loadSalak- , loadSalakFile+ , LoadSalak+ -- ** Basic loaders , loadCommandLine , ParseCommandLine , defaultParseCommandLine , loadEnv , loadMock- , loadOnceMock- -- ** Load Extensions+ , loadSalak+ , loadSalakWith+ -- ** File Loaders , ExtLoad , loadByExt , HasLoad(..) , (:|:)(..)- -- * Run Salak- , RunSalakT- , liftNT- -- ** Get Static Properties- , HasSourcePack(..)- , fetch- , require- -- ** Dynamic Get Properties+ -- ** Reload Functions , ReloadResult(..)- , exec- , requireD- -- ** Parse properties- , SourcePack- , Priority- , Value(..)- , Prop+ , askReload+ -- * Properties Parsers+ , PropOp(..) , FromProp(..)- , FromEnumProp(..)+ , Prop , readPrimitive- , PResult(..)- , (.?=)- , (.?:)+ , readEnum+ , SourcePack+ , PropException(..)+ -- * Reexport+ , MonadCatch+ , MonadThrow+ , MonadIO ) where -import Control.Monad (unless)-import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Catch+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Unlift import Control.Monad.Reader-import Control.Monad.State import Data.Default-import Data.Text (Text, cons)-import Salak.Load.Dynamic-import Salak.Load.Env-import Salak.Prop-import Salak.Types-import Salak.Types.Value+import Data.Text (Text)+import Salak.Internal+import Salak.Internal.Prop+import Salak.Internal.Source import System.Directory-import System.FilePath ((</>))+import System.FilePath ((</>)) ++-- | Configuration file name+type FileName = String+ -- | Prop load configuration data PropConfig = PropConfig- { configName :: Maybe String -- ^ Config name+ { configName :: Maybe FileName -- ^ 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- , loadExt :: FilePath -> LoadSalakT IO ()+ , loadExt :: FilePath -> LoadSalak () } instance Default PropConfig where@@ -95,20 +99,8 @@ defaultParseCommandLine (\_ -> return ()) --- | Load and run salak `SourcePack` and fetch properties.-loadAndRunSalak- :: MonadIO m- => LoadSalakT m () -- ^ Load properties monad.- -> RunSalakT m a -- ^ Fetch properties monad.- -> m a-loadAndRunSalak spm a = do- sp <- runLoadT Nothing spm- let es = errs sp- unless (null es) $ fail (head es)- runT a sp- -- | Load file by extension-type ExtLoad = (String, FilePath -> LoadSalakT IO ())+type ExtLoad = (String, FilePath -> LoadSalak ()) class HasLoad a where loaders :: a -> [ExtLoad]@@ -119,12 +111,13 @@ instance (HasLoad a, HasLoad b) => HasLoad (a :|: b) where loaders (a :|: b) = loaders a ++ loaders b -loadByExt :: (HasLoad a, MonadIO m) => a -> FilePath -> LoadSalakT m ()+-- | Load files with specified format, yaml or toml, etc.+loadByExt :: HasLoad a => a -> FilePath -> LoadSalak () loadByExt xs f = mapM_ go (loaders xs) where- go (ext, ly) = tryLoadFile (jump . ly) $ f ++ "." ++ ext+ go (ext, ly) = tryLoadFile ly $ f ++ "." ++ ext --- | Default run salak.+-- | Default load salak. -- All these configuration sources has orders, from highest priority to lowest priority: -- -- > 1. loadCommandLine@@ -135,92 +128,35 @@ -- > 6. load file from home folder if enabled -- > 7. file extension matching, support yaml or toml or any other loader. ---loadSalak :: MonadIO m => PropConfig -> LoadSalakT m ()+loadSalak :: (MonadCatch m, MonadIO m) => PropConfig -> LoadSalakT m () loadSalak PropConfig{..} = do loadCommandLine commandLine loadEnv+ dir <- require configDirKey forM_ configName $ forM_- [ require configDirKey+ [ return dir , ifS searchCurrent getCurrentDirectory , ifS searchHome getHomeDirectory ] . loadConf where ifS True gxd = Just <$> liftIO gxd ifS _ _ = return Nothing- loadConf n mf = mf >>= mapM_ (jump . loadExt . (</> n))---- | Default run salak.--- All these configuration sources has orders, from highest priority to lowest priority:------ > 1. loadCommandLine--- > 2. loadEnvironment--- > 3. loadConfFiles--- > 4. load file from folder `salak.conf.dir` if defined--- > 5. load file from current folder if enabled--- > 6. load file from home folder if enabled--- > 7. file extension matching, support yaml or toml or any other loader.----loadSalakFile :: (HasLoad file, MonadIO m) => String -> file -> LoadSalakT m ()-loadSalakFile name a = loadSalak def { configName = Just name, loadExt = loadByExt a}---- | Default run salak.--- All these configuration sources has orders, from highest priority to lowest priority:------ > 1. loadCommandLine--- > 2. loadEnvironment--- > 3. loadConfFiles--- > 4. load file from folder `salak.conf.dir` if defined--- > 5. load file from current folder if enabled--- > 6. load file from home folder if enabled--- > 7. file extension matching, support yaml or toml or any other loader.----runSalak :: MonadIO m => PropConfig -> RunSalakT m a -> m a-runSalak = loadAndRunSalak . loadSalak---- | Simplified run salak, should specified code name and file format.-runSalakWith :: (HasLoad file, MonadIO m) => String -> file -> RunSalakT m a -> m a-runSalakWith name a = loadAndRunSalak (loadSalakFile name a)---- | Monad that can fetch properties.-class Monad m => HasSourcePack m where- askSourcePack :: m SourcePack- logSP :: Text -> m ()- logSP _ = return ()- readLogs :: m [Text]- readLogs = return []--instance MonadIO m => HasSourcePack (RunSalakT m) where- askSourcePack = askRSP- logSP key = RunSalakT $ modify $ \rsp -> rsp { logs = key : logs rsp}- readLogs = RunSalakT $ do- rsp <- get- let ls = logs rsp- put rsp { logs = [] }- return (reverse ls)+ loadConf n mf = lift mf >>= mapM_ (liftNT . loadExt . (</> n)) -instance Monad m => HasSourcePack (LoadSalakT m) where- askSourcePack = LoadSalakT get+loadSalakWith :: (MonadCatch m, MonadIO m, HasLoad file) => file -> FileName -> LoadSalakT m ()+loadSalakWith file name = loadSalak def { configName = Just name, loadExt = loadByExt file } --- | Try fetch properties from `SourcePack`-fetch- :: (HasSourcePack m, FromProp a)- => Text -- ^ Properties key- -> m (Either String a)-fetch key = logSP key >> search key <$> askSourcePack+-- | 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 $ \sp -> runRunSalak sp ma --- | Fetch properties from `SourcePack`, or throw fail-require- :: (HasSourcePack m, FromProp a)- => Text -- ^ Properties key- -> m a-require k = fetch k >>= either error return+-- | Run salak, load strategy refer to `loadSalak`+runSalak :: (MonadCatch m, MonadIO m) => PropConfig -> RunSalakT m a -> m a+runSalak c = loadAndRunSalak (loadSalak c) --- | Fetch dynamic properties from `SourcePack`, or throw fail-requireD- :: (MonadIO m, FromProp a)- => Text -- ^ Properties key- -> RunSalakT m (IO a)-requireD k = logSP ('@' `cons` k) >> search' k >>= either error return+-- | Run salak, load strategy refer to `loadSalakWith`+runSalakWith :: (MonadCatch m, MonadIO m, HasLoad file) => FileName -> file -> RunSalakT m a -> m a+runSalakWith name file = loadAndRunSalak (loadSalakWith file name) -- $use --@@ -266,7 +202,7 @@ -- > , ext :: Int -- > } deriving (Eq, Show) -- >--- > instance FromProp Config where+-- > instance MonadCatch m => FromProp m Config where -- > fromProp = Config -- > <$> "user" ? pattern "[a-z]{5,16}" -- > <*> "pwd"@@ -278,12 +214,12 @@ -- -- GHCi play --+-- > λ> :set -XFlexibleInstances -XMultiParamTypeClasses -- > λ> import Salak--- > λ> import Salak.YAML--- > λ> import Salak.TOML--- > λ> :set -XTypeApplications--- > λ> instance FromProp Config where fromProp = Config <$> "user" <*> "dir" <*> "ext" .?= 1--- > λ> f = runSalakWith "salak" (YAML :|: TOML)--- > λ> f (require "") >>= print @Config--- > Config {name = "daniel", dir = Just "ls", ext = 2}+-- > λ> import Data.Default+-- > λ> import Data.Text(Text)+-- > λ> data Config = Config { name :: Text, dir :: Maybe Text, ext :: Int} deriving (Eq, Show)+-- > λ> instance MonadCatch m => FromProp m Config where fromProp = Config <$> "user" <*> "dir" <*> "ext" .?= 1+-- > λ> runSalak def (require "") :: IO Config+-- > Config {name = "daniel", dir = Nothing, ext = 1} --
+ src/Salak/Internal.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoOverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Salak.Internal(+ loadAndRunSalak'+ , loadTrie+ , loadList+ , LoadSalakT+ , LoadSalak+ , RunSalakT+ , RunSalak+ , runRunSalak+ , HasSalak(..)+ , MonadSalak(..)+ , loadMock+ , loadEnv+ , loadCommandLine+ , ParseCommandLine+ , defaultParseCommandLine+ , tryLoadFile+ , Source+ , TraceSource+ , Keys(..)+ , Key(..)+ , simpleKeys+ , ToKeys(..)+ , setVal+ , Val(..)+ , Value(..)+ , ToValue(..)+ , liftNT+ , SourcePack(..)+ , MonadIO+ ) where+++import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Control.Monad.IO.Unlift as IU+import Control.Monad.Reader+import qualified Control.Monad.State as MS+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import Data.Maybe+import Data.Text (Text, pack)+import qualified Data.Text as TT+import Salak.Internal.Key+import Salak.Internal.Prop+import Salak.Internal.Source+import Salak.Internal.Val+import qualified Salak.Trie as T+import System.Directory+import System.Environment++data UpdateSource = UpdateSource+ { ref :: MVar Source+ , refNo :: Int+ , refMap :: HashMap Int String+ , qfunc :: MVar QFunc+ , update :: MVar (IO ( TraceSource -- Updated Tries+ , IO ())) -- Confirm action+ }++-- | Configuration Loader Monad, used for load properties from sources. Custom loaders using `loadTrie`+newtype LoadSalakT m a = LoadSalakT { unLoad :: MS.StateT UpdateSource m a } deriving (Functor, Applicative, Monad, MS.MonadTrans)++-- | Simple IO Monad+type LoadSalak = LoadSalakT IO++liftNT :: MonadIO m => LoadSalak () -> LoadSalakT m ()+liftNT (LoadSalakT a) = do+ ud <- MS.get+ MS.liftIO $ MS.evalStateT a ud++instance MonadIO m => MonadSalak (LoadSalakT m) where+ askSalak = MS.get >>= toSourcePack++instance MonadThrow m => MonadThrow (LoadSalakT m) where+ throwM = LoadSalakT . throwM++instance MonadCatch m => MonadCatch (LoadSalakT m) where+ catch m f = do+ us <- MS.get+ lift $ MS.evalStateT (unLoad m) us `catch` (\e -> MS.evalStateT (unLoad $ f e) us)++instance Monad m => MS.MonadState UpdateSource (LoadSalakT m) where+ state f = LoadSalakT $ MS.state f++instance MonadIO m => MonadIO (LoadSalakT m) where+ liftIO = LoadSalakT . liftIO++instance IU.MonadUnliftIO m => IU.MonadUnliftIO (LoadSalakT m) where+ askUnliftIO = LoadSalakT $ do+ ut <- MS.get+ f <- MS.lift IU.askUnliftIO+ return $ IU.UnliftIO $ IU.unliftIO f . (`MS.evalStateT` ut) . unLoad++-- | Standard `HasSalak` instance.+newtype RunSalakT m a = RunSalakT { unRun :: ReaderT SourcePack m a } deriving (Functor, Applicative, Monad, MonadTrans)++-- | Simple IO Monad+type RunSalak = RunSalakT IO++instance Monad m => MonadSalak (RunSalakT m) where+ askSalak = RunSalakT ask++instance Monad m => MonadReader SourcePack (RunSalakT m) where+ ask = RunSalakT ask+ local f m = RunSalakT $ local f $ unRun m++instance MonadThrow m => MonadThrow (RunSalakT m) where+ throwM = RunSalakT . throwM++instance MonadCatch m => MonadCatch (RunSalakT m) where+ catch m f = do+ us <- ask+ lift $ runReaderT (unRun m) us `catch` (\e -> runReaderT (unRun $ f e) us)++instance MonadIO m => MonadIO (RunSalakT m) where+ liftIO = RunSalakT . liftIO++instance IU.MonadUnliftIO m => IU.MonadUnliftIO (RunSalakT m) where+ askUnliftIO = RunSalakT $ do+ ut <- ask+ f <- lift IU.askUnliftIO+ return $ IU.UnliftIO $ IU.unliftIO f . (`runReaderT` ut) . unRun++instance {-# OVERLAPPABLE #-} (m' ~ t (RunSalakT m), MonadTrans t, Monad m, Monad m') => MonadSalak m' where+ askSalak = lift askSalak++runRunSalak :: SourcePack -> RunSalakT m a -> m a+runRunSalak sp (RunSalakT m) = runReaderT m sp++-- | Basic loader+loadTrie :: MonadIO m => Bool -> String -> (Int -> IO TraceSource) -> LoadSalakT m ()+loadTrie canReload name f = do+ 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) qfunc update+ _ <- liftIO $ swapMVar ref t+ MS.put nut+ else error $ show es+ where+ go ts ud n = return $ do+ (c,d) <- ud+ c1 <- loadSource (if canReload then f else (\_ -> return ts)) n c+ return (c1,d)++-- | Simple loader+loadList :: (MonadIO m, Foldable f, ToKeys k, ToValue v) => Bool -> String -> IO (f (k,v)) -> LoadSalakT m ()+loadList canReload name iof = loadTrie canReload name (\i -> gen i <$> iof)++-- | Standard salak functions, by load and with a `SourcePack` instance.+-- Users should use `SourcePack` to create custom `MonadSalak` instances, then you get will an instance of `HasSalak`.+loadAndRunSalak' :: (MonadThrow m, MonadIO m) => LoadSalakT m () -> (SourcePack -> m a) -> m a+loadAndRunSalak' lstm f = load lstm >>= f++load :: MonadIO m => LoadSalakT m () -> m SourcePack+load (LoadSalakT lm) = do+ r <- liftIO $ newMVar T.empty+ q <- liftIO $ newMVar $ \s -> Right $ void $ swapMVar r s+ u <- liftIO $ newMVar $ return (T.empty, return ())+ MS.execStateT lm (UpdateSource r 0 HM.empty q u) >>= toSourcePack++toSourcePack :: MonadIO m => UpdateSource -> m SourcePack+toSourcePack UpdateSource{..} = liftIO (readMVar ref) >>= \s -> return $ SourcePack s [] qfunc go+ where+ go = do+ t <- readMVar ref+ (ts, ac) <- join $ readMVar update+ let (s,cs,es) = extract t ts+ f <- readMVar qfunc+ if null es+ then case f s of+ Left e -> return (ReloadResult True $ lines e)+ Right a -> ac >> a >> return (ReloadResult False $ lines $ show cs)+ else return (ReloadResult True es)++-- | Load mock variables into `Source`+loadMock :: MonadIO m => [(Text, Text)] -> LoadSalakT m ()+loadMock fa = loadList False "mock" (return fa)++-- | Load environment variables into `Source`+loadEnv :: 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)++-- | Convert arguments to properties+type ParseCommandLine = [String] -> IO [(Text, Text)]++-- | Default way to parse command line arguments+defaultParseCommandLine :: ParseCommandLine+defaultParseCommandLine = return . mapMaybe go+ where+ go ('-':'-':as) = case break (=='=') as of+ (a,'=':b) -> Just (pack a, pack b)+ _ -> Nothing+ go _ = Nothing++-- | Default way to parse command line arguments+loadCommandLine :: MonadIO m => ParseCommandLine -> LoadSalakT m ()+loadCommandLine pcl = loadList False "commandLine" (getArgs >>= pcl)++-- | Try load file, if file does not exist then do nothing.+tryLoadFile :: MonadIO m => (FilePath -> LoadSalakT m ()) -> FilePath -> LoadSalakT m ()+tryLoadFile f file = do+ b <- liftIO $ doesFileExist file+ when b $ do+ liftIO $ putStrLn $ "Load " ++ file+ f file+
+ src/Salak/Internal/Key.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+module Salak.Internal.Key(+ Key(..)+ , Keys(..)+ , simpleKeys+ , ToKeys(..)+ , isNum+ ) where++import Control.Applicative ((<|>))+import Data.Attoparsec.Text+import Data.Coerce (coerce)+import Data.Hashable+import Data.List (intercalate)+import Data.Text (Text)+import qualified Data.Text as T++data Key+ = KT !Text+ | KI !Int+ deriving Eq++instance Ord Key where+ compare (KT a) (KT b) = compare a b+ compare (KI a) (KI b) = compare a b+ compare (KI _) _ = LT+ compare _ _ = GT++newtype Keys = Keys { unKeys :: [Key] } deriving Eq++instance Show Keys where+ show ks = toKey (coerce ks)+ where+ toKey = intercalate "." . 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 [] = []++isStr :: Key -> Bool+isStr (KT _) = True+isStr _ = False++isNum :: Key -> Bool+isNum (KI _) = True+isNum _ = False++instance Hashable Key where+ hash (KT a) = hash a+ hash (KI a) = hash a+ hashWithSalt i (KT a) = hashWithSalt i a+ hashWithSalt i (KI a) = hashWithSalt i a++instance Show Key where+ show (KT x) = T.unpack x+ show (KI i) = "[" ++ show i ++ "]"++simpleKeys :: Text -> [Key]+simpleKeys as = fmap KT $ filter (not.T.null) $ T.splitOn "." as++exprs :: Parser [Key]+exprs = concat <$> ( (expr <|> return []) `sepBy` char '.')++sName :: Parser Key+sName = KT . T.pack <$> do+ a <- choice [letter, digit]+ b <- many' (choice [letter, digit, char '-', char '_'])+ return (a:b)++sNum :: Parser Key+sNum = KI <$> paren decimal+ where+ paren e = do+ _ <- char '['+ ex <- e+ _ <- char ']'+ return ex++-- xx+-- xx.xx+-- xx.xx[0]+-- xx.xx[1].xx+expr :: Parser [Key]+expr = (:) <$> sName <*> many' sNum++class ToKeys a where+ toKeys :: a -> Either String Keys++instance ToKeys Keys where+ toKeys = Right++instance ToKeys Text where+ toKeys = fmap Keys . 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)++instance ToKeys String where+ toKeys = toKeys . T.pack
+ src/Salak/Internal/Prop.hs view
@@ -0,0 +1,445 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Salak.Internal.Prop where++import qualified Control.Applicative as A+import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.Catch+import Control.Monad.Except+import Control.Monad.Identity (Identity (..))+import Control.Monad.Reader+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Default+import Data.Fixed+import qualified Data.HashMap.Strict as HM+import Data.Int+import Data.List (sortBy)+import Data.Menshen+import Data.Scientific+import Data.Semigroup+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TB+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TBL+import Data.Time+import Data.Word+import Foreign.C+import GHC.Exts+import GHC.Generics+import Salak.Internal.Key+import Salak.Internal.Source+import Salak.Internal.Val+import qualified Salak.Trie as TR+import Text.Read (readMaybe)++class Monad m => FromProp m a where+ fromProp :: Prop m a+ default fromProp :: (Generic a, GFromProp m (Rep a)) => Prop m a+ fromProp = fmap to gFromProp++newtype Prop m a+ = Prop { unProp :: ReaderT SourcePack m a }+ deriving (Functor, Applicative, Monad, MonadReader SourcePack, MonadTrans)++instance MonadCatch m => A.Alternative (Prop m) where+ empty = notFound+ a <|> b = do+ v <- try a+ case v of+ Right x -> return x+ Left (_ :: SomeException) -> b++-- | Core type class of salak, which provide function to parse properties.+class HasSalak m where+ -- | Parse properties using `FromProp`. For example:+ --+ -- > a :: Bool <- require "bool.key"+ -- > b :: Maybe Int <- require "int.optional.key"+ -- > c :: Either String Int <- require "int.error.key"+ -- > d :: IO Int <- require "int.reloadable.key"+ require :: FromProp m a => Text -> m a++instance (MonadThrow m, MonadSalak m) => HasSalak m where+ require ks = do+ sp@SourcePack{..} <- askSalak+ case search ks source of+ Left e -> throwM $ PropException e+ Right (k,t) -> runProp sp { source = t, pref = pref ++ unKeys k} fromProp++instance Monad m => MonadSalak (Prop m) where+ askSalak = Prop ask++instance MonadIO m => MonadIO (Prop m) where+ liftIO = Prop . liftIO++instance MonadThrow m => MonadThrow (Prop m) where+ throwM = Prop . throwM++instance MonadCatch m => MonadCatch (Prop m) where+ catch (Prop a) f = Prop $ do+ sp <- ask+ lift $ runReaderT a sp `catch` (\e -> runReaderT (unProp $ f e) sp)++runProp :: Monad m => SourcePack -> Prop m a -> m a+runProp sp (Prop p) = runReaderT p sp++instance (MonadCatch m, FromProp m a) => FromProp m (Maybe a) where+ fromProp = do+ v <- try fromProp+ case v of+ Left e -> case fromException e of+ Just NullException -> return Nothing+ _ -> throwM e+ Right a -> return (Just a)++instance (MonadCatch m, FromProp m a) => FromProp m (Either String a) where+ fromProp = do+ sp@SourcePack{..} <- askSalak+ lift $ convertExp (Left $ show (Keys pref) ++ " is null") <$> try (runProp sp fromProp)++instance {-# OVERLAPPABLE #-} FromProp m a => FromProp m [a] where+ fromProp = do+ sp@SourcePack{..} <- askSalak+ let TR.Trie _ m = source+ lift $ foldM (go sp) [] $ sortBy g2 $ filter (isNum.fst) $ HM.toList m+ where+ go s vs (k,t) = (:vs) <$> runProp s { pref = pref s ++ [k], source = t} fromProp+ g2 (a,_) (b,_) = compare b a++instance {-# OVERLAPPABLE #-} (Show a, MonadThrow m, MonadIO m, FromProp (Either SomeException) a) => FromProp m (IO a) where+ fromProp = Prop $ do+ sp <- ask+ either throwM (buildIO sp) $ runProp sp (fromProp :: Prop (Either SomeException) a)+++buildIO :: (Show a, MonadIO m, FromProp (Either SomeException) a) => SourcePack -> a -> m (IO a)+buildIO sp a = liftIO $ do+ aref <- newMVar a+ modifyMVar_ (qref sp) $ \f -> return $ \s -> do+ b <- convertExp (Right a) $ runProp sp {source = search2 s (pref sp), pref = pref sp} fromProp+ io <- f s+ return (swapMVar aref b >> io)+ return (readMVar aref)++convertExp :: Either String a -> Either SomeException a -> Either String a+convertExp a = either readExp Right+ where+ readExp e = case fromException e of+ Just (PropException x) -> Left x+ Just NullException -> a+ _ -> Left $ show e++data PropException+ = PropException String -- ^ Parse failed+ | NullException -- ^ Not found+ deriving Show++instance Exception PropException++instance (MonadThrow m, FromProp m a) => IsString (Prop m a) where+ fromString ks = do+ sp@SourcePack{..} <- askSalak+ lift $ case search ks source of+ Left e -> throwM $ PropException e+ Right (k,t) -> runProp sp { source = t, pref = pref ++ unKeys k} fromProp++notFound :: MonadThrow m => Prop m a+notFound = do+ SourcePack{..} <- askSalak+ throwM NullException++err :: MonadThrow m => String -> Prop m a+err e = do+ SourcePack{..} <- askSalak+ throwM $ PropException $ show (Keys pref) ++ ":" ++ e++-- | Prop operators.+--+-- Suppose we have following definition:+--+-- > data Config = Config+-- > { enabled :: Bool+-- > , level :: IO LogLevel+-- > }+class PropOp f a where+ -- | Parse or default value+ --+ -- > instance MonadThrow m => FromProp m Config where+ -- > fromProp = Config+ -- > <$> "enabled" .?= True+ -- > <*> "level" .?= (return LevelInfo)+ --+ -- IO value will work right.+ infixl 5 .?=+ (.?=) :: f a -> a -> f a+ -- | Parse or auto extract from a `Default` value+ --+ -- > instance Default Config where+ -- > def = Config True (return LevelInfo)+ -- > instance MonadThrow m => FromProp m Config where+ -- > fromProp = Config+ -- > <$> "enabled" .?: enabled+ -- > <$> "level" .?: level+ infixl 5 .?:+ (.?:) :: Default b => f a -> (b -> a) -> f a+ (.?:) fa b = fa .?= b def++-- | Support normal value+instance {-# OVERLAPPABLE #-} A.Alternative f => PropOp f a where+ (.?=) a b = a A.<|> pure b++-- | Support IO value+instance (Show a, MonadCatch m, MonadIO m, FromProp (Either SomeException) a) => PropOp (Prop m) (IO a) where+ (.?=) ma a = do+ sp <- askSalak+ v <- try ma+ case v of+ Left (_ :: SomeException) -> liftIO a >>= buildIO sp+ Right o -> return o++instance MonadThrow m => HasValid (Prop m) where+ invalid = err . toI18n++-- | Parse primitive value from `Value`+readPrimitive :: MonadThrow m => (Value -> Either String a) -> Prop m a+readPrimitive f = do+ SourcePack{..} <- askSalak+ let TR.Trie v _ = source+ case f <$> (v >>= getVal) of+ Just (Left e) -> err e+ Just (Right a) -> return a+ _ -> notFound++-- | Parse enum value from `Text`+readEnum :: MonadThrow m => (Text -> Either String a) -> Prop m a+readEnum = readPrimitive . go+ where+ go f (VT t) = f t+ go _ x = Left $ fst (typeOfV x) ++ " cannot convert to enum"++class Monad m => GFromProp m f where+ gFromProp :: Prop m (f a)++instance {-# OVERLAPPABLE #-} (MonadThrow m, 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++gEnum :: (MonadThrow m, GFromProp m f) => 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+ gFromProp = Prop $ do+ let k = KT $ T.pack $ selName (undefined :: t s a p)+ withReaderT (\s -> s { pref = pref s ++ [k], source = search1 (source s) k }) $ unProp $ M1 <$> gFromProp++instance {-# OVERLAPPABLE #-} GFromProp m a => GFromProp m (M1 D i a) where+ gFromProp = M1 <$> gFromProp++instance {-# OVERLAPPABLE #-} (FromProp m a) => GFromProp m (K1 i a) where+ gFromProp = fmap K1 fromProp++instance Monad m => GFromProp m U1 where+ gFromProp = pure U1++instance {-# OVERLAPPABLE #-} (GFromProp m a, GFromProp m b) => GFromProp m (a:*:b) where+ gFromProp = (:*:) <$> gFromProp <*> gFromProp++instance {-# OVERLAPPABLE #-} (MonadCatch m, GFromProp m a, GFromProp m b) => GFromProp m (a:+:b) where+ gFromProp = fmap L1 gFromProp A.<|> fmap R1 gFromProp++instance (Monad m, FromProp m a) => FromProp m (Identity a) where+ fromProp = Identity <$> fromProp++instance (Monad m, FromProp m a, FromProp m b) => FromProp m (a,b) where+ fromProp = (,) <$> fromProp <*> fromProp++instance (Monad m, FromProp m a, FromProp m b, FromProp m c) => FromProp m(a,b,c) where+ fromProp = (,,) <$> fromProp <*> fromProp <*> fromProp++instance (Monad m, FromProp m a, FromProp m b, FromProp m c, FromProp m d) => FromProp m(a,b,c,d) where+ fromProp = (,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp++instance (Monad m, FromProp m a, FromProp m b, FromProp m c, FromProp m d, FromProp m e) => FromProp m(a,b,c,d,e) where+ fromProp = (,,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp++instance (Monad m, 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+ fromProp = (,,,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp++instance (Monad m, 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+ fromProp = (,,,,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp++instance (Monad m, 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+ fromProp = (,,,,,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp++instance (Monad m, 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+ fromProp = (,,,,,,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp+++instance (Monad m, FromProp m a) => FromProp m (Min a) where+ fromProp = Min <$> fromProp++instance (Monad m, FromProp m a) => FromProp m (Max a) where+ fromProp = Max <$> fromProp++instance (Monad m, FromProp m a) => FromProp m (First a) where+ fromProp = First <$> fromProp++instance (Monad m, FromProp m a) => FromProp m (Last a) where+ fromProp = Last <$> fromProp++instance (Monad m, FromProp m a) => FromProp m (Dual a) where+ fromProp = Dual <$> fromProp++instance (Monad m, FromProp m a) => FromProp m (Sum a) where+ fromProp = Sum <$> fromProp++instance (Monad m, FromProp m a) => FromProp m (Product a) where+ fromProp = Product <$> fromProp++instance (MonadCatch m, FromProp m a) => FromProp m (Option a) where+ fromProp = Option <$> fromProp++instance MonadThrow m => FromProp m Bool where+ fromProp = readPrimitive go+ where+ go (VB x) = Right x+ go (VT x) = case T.toLower x of+ "true" -> Right True+ "yes" -> Right True+ "false" -> Right False+ "no" -> Right False+ _ -> Left "string convert bool failed"+ go x = Left $ getType x ++ " cannot be bool"++instance MonadThrow m => FromProp m Text where+ fromProp = readPrimitive go+ where+ go (VT x) = Right x+ go x = Right $ T.pack $ snd $ typeOfV x++instance MonadThrow m => FromProp m TL.Text where+ fromProp = TL.fromStrict <$> fromProp++instance MonadThrow m => FromProp m B.ByteString where+ fromProp = TB.encodeUtf8 <$> fromProp++instance MonadThrow m => FromProp m BL.ByteString where+ fromProp = TBL.encodeUtf8 <$> fromProp++instance MonadThrow m => FromProp m String where+ fromProp = T.unpack <$> fromProp++instance MonadThrow m => FromProp m Scientific where+ fromProp = readPrimitive go+ where+ go (VT x) = case readMaybe $ T.unpack x of+ Just v -> Right v+ _ -> Left "string convert number failed"+ go (VI x) = Right x+ go x = Left $ getType x ++ " cannot be number"++instance MonadThrow m => FromProp m Float where+ fromProp = toRealFloat <$> fromProp++instance MonadThrow m => FromProp m Double where+ fromProp = toRealFloat <$> fromProp++instance MonadThrow m => FromProp m Integer where+ fromProp = toInteger <$> (fromProp :: Prop m Int)++instance MonadThrow m => FromProp m Int where+ fromProp = fromProp >>= toNum++instance MonadThrow m => FromProp m Int8 where+ fromProp = fromProp >>= toNum++instance MonadThrow m => FromProp m Int16 where+ fromProp = fromProp >>= toNum++instance MonadThrow m => FromProp m Int32 where+ fromProp = fromProp >>= toNum++instance MonadThrow m => FromProp m Int64 where+ fromProp = fromProp >>= toNum++instance MonadThrow m => FromProp m Word where+ fromProp = fromProp >>= toNum++instance MonadThrow m => FromProp m Word8 where+ fromProp = fromProp >>= toNum++instance MonadThrow m => FromProp m Word16 where+ fromProp = fromProp >>= toNum++instance MonadThrow m => FromProp m Word32 where+ fromProp = fromProp >>= toNum++instance MonadThrow m => FromProp m Word64 where+ fromProp = fromProp >>= toNum++instance MonadThrow m => FromProp m NominalDiffTime where+ fromProp = fromInteger <$> fromProp++instance MonadThrow m => FromProp m DiffTime where+ fromProp = fromInteger <$> fromProp++instance (HasResolution a, MonadThrow m) => FromProp m (Fixed a) where+ fromProp = fromInteger <$> fromProp++toNum :: (MonadThrow m, Integral i, Bounded i) => Scientific -> Prop m i+toNum s = case toBoundedInteger s of+ Just v -> return v+ _ -> err "scientific number doesn't fit in the target representation"++instance MonadThrow m => FromProp m CBool where+ fromProp = do+ b <- fromProp+ return $ if b then 1 else 0++instance MonadThrow m => FromProp m CShort where+ fromProp = CShort <$> fromProp++instance MonadThrow m => FromProp m CUShort where+ fromProp = CUShort <$> fromProp++instance MonadThrow m => FromProp m CInt where+ fromProp = CInt <$> fromProp++instance MonadThrow m => FromProp m CUInt where+ fromProp = CUInt <$> fromProp++instance MonadThrow m => FromProp m CLong where+ fromProp = CLong <$> fromProp++instance MonadThrow m => FromProp m CULong where+ fromProp = CULong <$> fromProp++instance MonadThrow m => FromProp m CLLong where+ fromProp = CLLong <$> fromProp++instance MonadThrow m => FromProp m CULLong where+ fromProp = CULLong <$> fromProp++instance MonadThrow m => FromProp m CFloat where+ fromProp = CFloat <$> fromProp++instance MonadThrow m => FromProp m CDouble where+ fromProp = CDouble <$> fromProp+
+ src/Salak/Internal/Source.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoOverloadedLists #-}+module Salak.Internal.Source where++import Control.Concurrent.MVar+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import qualified Data.Heap as H+import Data.Maybe+import Salak.Internal.Key+import Salak.Internal.Val+import qualified Salak.Trie as T++type Source = T.Trie Vals+type TraceSource = T.Trie ([String], Vals)++-- | Reload result, show erros or changes.+data ReloadResult = ReloadResult+ { hasError :: Bool -- ^ If reload process has errors.+ , msgs :: [String] -- ^ If hasError then this show error messages, else this show change logs.+ } deriving Show++type QFunc = Source -> Either String (IO ())++data SourcePack = SourcePack+ { source :: Source+ , pref :: [Key]+ , qref :: MVar QFunc+ , reload :: IO ReloadResult+ }++-- | Monad has the ability to get a `SourcePack` instance.+class Monad m => MonadSalak m where+ askSalak :: m SourcePack++-- | Get reload action which used for reload profiles+askReload :: MonadSalak m => m (IO ReloadResult)+askReload = reload <$> askSalak++diff :: Source -> Source -> T.Trie ModType+diff = T.merge go+ where+ go Nothing Nothing = Nothing+ go (Just (Vals a)) Nothing = if H.null a then Nothing else Just Add+ go Nothing (Just (Vals a)) = if H.null a then Nothing else Just Del+ go (Just (Vals a)) (Just (Vals b))+ | H.null a && H.null b = Nothing+ | H.null a = Just Del+ | H.null b = Just Add+ | otherwise =+ let Val i x = H.minimum a+ Val j y = H.minimum b+ in if i==j && x==y then Nothing else Just Mod++extract :: Source -> TraceSource -> (Source, T.Trie ModType, [String])+extract o t =+ ( t1+ , diff t1 o+ , concatMap (\(k,v)-> fmap (k++) v) list)+ where+ t1 = fmap snd t+ list = fmap (\(k,v)->(show k,v)) $ T.toList $ fmap fst t++gen :: (Foldable f, ToKeys k, ToValue v) => Int -> f (k,v) -> TraceSource+gen i = foldr go T.empty+ where+ go (k,v) x = case toKeys k of+ Left e -> T.alter (g3 e) (Keys []) x+ Right k' -> T.alter (g2 $ Val i $ toVal v) k' x+ g2 v (Just (a,Vals c)) = Just (a, Vals $ H.insert v c)+ g2 v _ = Just ([], Vals $ H.singleton v)+ g3 e (Just (a,c)) = Just (e:a,c)+ g3 e _ = Just ([e], Vals H.empty)++search :: (ToKeys k) => k -> Source -> Either String (Keys, Source)+search k t = fmap (go . unKeys) (toKeys k)+ where+ go ks = (Keys ks, foldl search1 t ks)++search2 :: Source -> [Key] -> Source+search2 = foldl search1++search1 :: Source -> Key -> Source+search1 (T.Trie _ m) key = fromMaybe T.empty $ HM.lookup key m++fmt :: ModType -> Int -> String -> String -> String+fmt m i s n = concat ['#' : show i, ' ' : show m, ' ' : s , ' ' : n]++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+ go Nothing Nothing = Nothing+ go (Just v) Nothing = Just v+ go Nothing (Just v) = Just v+ go (Just (e1,v1)) (Just (e2,v2)) = Just (e1++e2, modVals' v2 v1)++setVal :: ToValue v => Int -> v -> TraceSource -> TraceSource+setVal i v (T.Trie x m) = T.Trie (go x) m+ where+ go Nothing = Just ([], modVals (Val i $ toVal v) emptyVals)+ go (Just (e,vs)) = Just (e, modVals (Val i $ toVal v) vs)
+ src/Salak/Internal/Val.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Salak.Internal.Val where++import Data.ByteString (ByteString)+import Data.Heap (Heap)+import qualified Data.Heap as H+import Data.Int+import Data.List (intercalate)+import Data.Scientific+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import Data.Time+++data Val v = Val !Int !v deriving (Eq, Show)+data ModType+ = Add+ | Mod+ | Del+ | Noop deriving (Eq, Show)++type Priority = Int++priority :: Val v -> Int+priority (Val i _) = i++data Value+ = VT !Text+ | VI !Scientific+ | VB !Bool+ | VLT !LocalTime+ | VD !Day+ | VH !TimeOfDay+ | VZT !TimeZone !LocalTime+ | VU !UTCTime+ deriving Eq++instance Show Value where+ show v = let (a,b) = typeOfV v in b ++ "::" ++ a++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)++getType :: Value -> String+getType = fst . typeOfV++newtype Vals = Vals { unVals :: Heap (Val Value) } deriving Eq++instance Show Vals where+ show (Vals v) = intercalate "," $ go <$> H.toUnsortedList v+ where+ go (Val i x) = '#' : show i ++ ('.' : show x)++instance Eq v => Ord (Val v) where+ compare (Val a _) (Val b _) = compare a b++nullVals :: Vals -> Bool+nullVals (Vals v) = H.null v++emptyVals :: Vals+emptyVals = Vals H.empty++deleteVals :: Int -> Vals -> (Bool, Vals)+deleteVals i (Vals v) =+ let (a,b) = H.partition ((==i) . priority) v+ in (H.null a, Vals b)++getVal :: Vals -> Maybe Value+getVal (Vals v)+ | H.null v = Nothing+ | otherwise = let Val _ x = H.minimum v in Just x++class ToValue a where+ toVal :: a -> Value++instance ToValue Value where+ toVal = id++instance ToValue Text where+ toVal = VT++instance ToValue ByteString where+ toVal = VT . decodeUtf8++instance ToValue String where+ toVal = VT . T.pack++instance ToValue Scientific where+ toVal = VI++instance ToValue Integer where+ toVal = VI . fromInteger++instance ToValue Int where+ toVal = VI . fromInteger . toInteger++instance ToValue Int64 where+ toVal = VI . fromInteger . toInteger++instance ToValue Double where+ toVal = VI . realToFrac++instance ToValue Bool where+ toVal = VB++instance ToValue UTCTime where+ toVal = VU++delVals :: Int -> Vals -> Vals+delVals p (Vals v) = Vals $ H.filter ((/=p) . priority) v++modVals :: Val Value -> Vals -> Vals+modVals val@(Val p _) (Vals v) = Vals $ H.insert val $ H.filter ((/=p) . priority) v+++modVals' :: Vals -> Vals -> Vals+modVals' (Vals v) vals = if H.null v then vals else modVals (H.minimum v) vals++++++
− src/Salak/Load.hs
@@ -1,37 +0,0 @@--- |--- Module: Salak--- Copyright: (c) 2019 Daniel YU--- License: BSD3--- Maintainer: leptonyu@gmail.com--- Stability: experimental--- Portability: portable------ This module is designed for implementating configuration file loading.--- Please don't use if you are not implemanting a new configuration file.----module Salak.Load(- -- * SourcePack- Source- , SourcePack- , addErr- , newVStr- -- * Selector- , Selector(..)- , simpleSelectors- -- * Source- , emptySource- , nullSource- , insertSource- , updateSources- , updateSource- -- * Load- , tryLoadFile- , load- , loadOnce- ) where--import Salak.Types-import Salak.Types.Selector-import Salak.Types.Source-import Salak.Types.Value-
− src/Salak/Load/Dynamic.hs
@@ -1,99 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-module Salak.Load.Dynamic where--import Control.Concurrent.MVar-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.IO.Unlift-import Control.Monad.State-import Control.Monad.Writer-import qualified Data.IntMap.Strict as MI-import Data.Text (Text)-import Salak.Prop-import Salak.Types-import Salak.Types.Source--data ReloadResult = ReloadResult- { isError :: Bool -- ^ msg stands for properties changing record if true, otherwise msg means reload error.- , msg :: [String] -- ^ message log- } deriving (Eq, Show)---- | Reloadable SourcePack-data ReloadableSourcePack = ReloadableSourcePack- { sourcePack :: MVar SourcePack- , logs :: [Text]- , 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' <- readMVar v- as <- sequence $ MI.foldlWithKey' runReload [] (reEnv sp')- let loadErr = concat $ fst . snd <$> as- runWith e a = if null e then a else return $ ReloadResult True e- runWith loadErr $ do- let sp'' = foldl g2 sp' {errs = []} as- modLog = errs sp''- (ac, msErr) <- f sp''- runWith msErr $ swapMVar v sp'' >> sequence_ ac >> return (ReloadResult False modLog)- g2 :: SourcePack -> (Int, ([String], Source)) -> SourcePack- g2 p (i, (_, s)) = let (s', e) = runWriter $ replace i s (source p) in p { source = s', errs = errs p <> e}---- | RunSalak Monad Transfer-newtype RunSalakT m a = RunSalakT { unRun :: StateT ReloadableSourcePack m a }- deriving (Functor, Applicative, Monad, MonadTrans)--instance MonadIO m => MonadIO (RunSalakT m) where- liftIO = lift . liftIO--instance MonadUnliftIO m => MonadUnliftIO (RunSalakT m) where- askUnliftIO = RunSalakT $ do- rsp <- get- f <- lift askUnliftIO- return $ UnliftIO $ unliftIO f . (`evalStateT` rsp) . unRun--liftNT :: Monad n => (forall x. m x -> n x) -> RunSalakT m a -> RunSalakT n a-liftNT f (RunSalakT ma) = RunSalakT $ do- rsp <- get- (a, s) <- lift $ f (runStateT ma rsp)- put s- return a--askRSP :: MonadIO m => RunSalakT m SourcePack-askRSP = RunSalakT $ do- ReloadableSourcePack{..} <- get- liftIO $ readMVar sourcePack--search' :: (MonadIO m, FromProp a) => Text -> RunSalakT m (Either String (IO a))-search' k = RunSalakT $ do- sp <- unRun askRSP- case search k sp of- Left e -> return (Left e)- Right r -> do- v <- liftIO $ newMVar r- modify $ \rsp -> rsp { reloadAll = reloadAll rsp . 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 (void (swapMVar x r):as, es)--reloadAction :: Monad m => RunSalakT m (IO ReloadResult)-reloadAction = RunSalakT $ do- ReloadableSourcePack{..} <- get- return $ reloadAll $ \_ -> return ([], [])--runT :: MonadIO m => RunSalakT m a -> SourcePack -> m a-runT (RunSalakT a) sp = reloadableSourcePack sp >>= evalStateT a---- | Run action in `RunSalakT`, `IO` `ReloadResult` is reloadable action.-exec :: MonadIO m => (IO ReloadResult -> IO a) -> RunSalakT m a-exec fa = reloadAction >>= lift . liftIO . fa
− src/Salak/Load/Env.hs
@@ -1,38 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Salak.Load.Env where--import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Maybe-import qualified Data.Text as T-import Salak.Types-import Salak.Types.Value-import System.Environment---- | Load environment variables into `SourcePack`-loadEnv :: MonadIO m => LoadSalakT m ()-loadEnv = do- args <- liftIO getEnvironment- loadOnce "environment" args go- where- go p (k,v) = return (g2 k, newVStr (T.pack v) p)- g2 = T.toLower . T.pack . map (\c -> if c == '_' then '.' else c)---- | Convert arguments to properties-type ParseCommandLine = [String] -> IO [(T.Text,Priority -> Value)]---- | Default way to parse command line arguments-defaultParseCommandLine :: ParseCommandLine-defaultParseCommandLine = return . mapMaybe go- where- go ('-':'-':as) = case break (=='=') as of- (a,'=':b) -> Just (T.pack a, newVStr (T.pack b))- _ -> Nothing- go _ = Nothing---- | Load command line arguments into `SourcePack`-loadCommandLine :: MonadIO m => ParseCommandLine -> LoadSalakT m ()-loadCommandLine pcl = do- args <- liftIO $ getArgs >>= pcl- loadOnce "commandline" args go- where- go i (k,fv) = return (k, fv i)
− src/Salak/Prop.hs
@@ -1,443 +0,0 @@-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-module Salak.Prop where--import Control.Applicative-import Control.Monad.Identity-import Control.Monad.Reader-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import Data.Default-import Data.Int-import qualified Data.Map.Strict as M-import Data.Menshen-import Data.Scientific-import Data.Semigroup-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as TB-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TBL-import Data.Time-import Data.Word-import Foreign.C-import GHC.Exts-import GHC.Generics hiding (Selector)-import qualified GHC.Generics as G-import Salak.Types-import Salak.Types.Selector-import Salak.Types.Source-import Salak.Types.Value-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--data PropSource = PropSource- { originSP :: SourcePack- , currSP :: SourcePack- , cacheRef :: M.Map [Selector] Bool- }--newtype PropT m a = Prop { unProp :: ReaderT PropSource m a }- deriving (Functor, Applicative, Monad, MonadTrans, Alternative)---- | 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---- | Monad used to parse properties to destination type.-type Prop = PropT PResult--runProp :: PropSource -> PropT m a -> m a-runProp sp a = runReaderT (unProp a) sp--askSub :: (SourcePack -> SourcePack) -> Prop PropSource-askSub f = do- ps <- Prop ask- return ps { currSP = f (currSP ps) }--askOrigin :: Prop SourcePack-askOrigin = originSP <$> Prop ask--instance MonadReader SourcePack Prop where- ask = currSP <$> Prop ask- local f (Prop a) = Prop (local (\sp -> sp { currSP = f (currSP sp) }) 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 :: GFromProp f => Text -> PropT PResult (f a)-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 (SStr $ 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- fps <- askSub id- lift $ case runProp fps (fromProp :: Prop a) of- O s a -> O s $ Just a- N s -> O s Nothing- F s e -> F s e--instance FromProp a => FromProp (Either String a) where- fromProp = do- fps <- askSub id- lift $ case runProp fps (fromProp :: Prop a) of- O s a -> O s $ Right a- N s -> O s $ Left "null"- F s e -> O s $ Left e--instance FromProp a => FromProp (Identity a) where- fromProp = Identity <$> fromProp--instance (FromProp a, FromProp b) => FromProp (a,b) where- fromProp = (,) <$> fromProp <*> fromProp--instance (FromProp a, FromProp b, FromProp c) => FromProp (a,b,c) where- fromProp = (,,) <$> fromProp <*> fromProp <*> fromProp--instance (FromProp a, FromProp b, FromProp c, FromProp d) => FromProp (a,b,c,d) where- fromProp = (,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp--instance (FromProp a, FromProp b, FromProp c, FromProp d, FromProp e) => FromProp (a,b,c,d,e) where- fromProp = (,,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp--instance (FromProp a, FromProp b, FromProp c, FromProp d, FromProp e, FromProp f) => FromProp (a,b,c,d,e,f) where- fromProp = (,,,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp--instance (FromProp a, FromProp b, FromProp c, FromProp d, FromProp e, FromProp f, FromProp g) => FromProp (a,b,c,d,e,f,g) where- fromProp = (,,,,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp--instance (FromProp a, FromProp b, FromProp c, FromProp d, FromProp e, FromProp f, FromProp g, FromProp h) => FromProp (a,b,c,d,e,f,g,h) where- fromProp = (,,,,,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp--instance (FromProp a, FromProp b, FromProp c, FromProp d, FromProp e, FromProp f, FromProp g, FromProp h, FromProp i) => FromProp (a,b,c,d,e,f,g,h,i) where- fromProp = (,,,,,,,,) <$> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp <*> fromProp--instance {-# OVERLAPPABLE #-} FromProp a => FromProp [a] where- fromProp = do- sp@SourcePack{..} <- ask- as <- foldM (go sp) [] $ M.toList (mapValue source)- return (reverse as)- where- go sp' as (ix,s) = do- so <- askSub $ const sp' { prefix = ix : prefix sp', source = s}- a <- lift $ runProp so fromProp- return (a:as)--instance FromProp a => FromProp (Min a) where- fromProp = Min <$> fromProp--instance FromProp a => FromProp (Max a) where- fromProp = Max <$> fromProp--instance FromProp a => FromProp (First a) where- fromProp = First <$> fromProp--instance FromProp a => FromProp (Last a) where- fromProp = Last <$> fromProp--instance FromProp a => FromProp (Dual a) where- fromProp = Dual <$> fromProp--instance FromProp a => FromProp (Sum a) where- fromProp = Sum <$> fromProp--instance FromProp a => FromProp (Product a) where- fromProp = Product <$> fromProp--instance FromProp a => FromProp (Option a) where- fromProp = Option <$> fromProp--instance {-# OVERLAPPABLE #-} FromEnumProp a => FromProp a where- fromProp = readPrimitive $ \ss v -> case v of- VStr _ s -> either (F ss) (O ss) $ fromEnumProp $ T.toLower s- x -> F ss $ getType x ++ " cannot be enum"--evalV :: [Selector] -> Value -> Prop Value-evalV x (VRef i rs) = do- sp <- askOrigin- ps <- askSub (const sp)- if M.member x (cacheRef ps)- then lift $ F x "self reference"- else lift $ VStr i <$> foldM (go ps { cacheRef = M.insert x True $ cacheRef ps} ) "" rs- where- go _ a (RVal b) = return (T.append a b)- go ps a (RRef f) = case convert $ runProp ps (selectP f) of- Right b -> return (T.append a b)- Left e -> F f e-evalV _ v = return v---- | ReadPrimitive value-readPrimitive :: ([Selector] -> Value -> PResult a) -> Prop a-readPrimitive f = do- SourcePack{..} <- ask- case getQ (value source) of- Just v -> evalV prefix v >>= lift . f prefix- _ -> lift $ N prefix--class FromEnumProp a where- fromEnumProp :: Text -> Either String a- {-# MINIMAL fromEnumProp #-}--err :: String -> Prop a-err e = do- sp <- ask- lift $ F (prefix sp) e---- | Parse value-readSelect :: FromProp a => Text -> Prop a-readSelect key = case selectors key of- Left e -> err e- Right s -> selectP s--selectP :: FromProp a => [Selector] -> Prop a-selectP s = local (\sp -> foldl select sp s) fromProp--search :: FromProp a => Text -> SourcePack -> Either String a-search key sp = convert $ runProp (PropSource sp sp M.empty) (readSelect key)--convert :: PResult a -> Either String a-convert (O _ x) = Right x-convert (N s ) = Left $ "key " ++ toKey s ++ " not found"-convert (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 (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"- go s x = F s $ getType x ++ " cannot be bool"--instance FromProp Text where- fromProp = readPrimitive go- where- go s (VStr _ x) = O s x- go s x = O s $ T.pack (getV x)--instance FromProp TL.Text where- fromProp = TL.fromStrict <$> fromProp--instance FromProp B.ByteString where- fromProp = TB.encodeUtf8 <$> fromProp--instance FromProp BL.ByteString where- fromProp = TBL.encodeUtf8 <$> 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 x = F s $ getType x ++ " cannot be number"--instance FromProp Float where- fromProp = toRealFloat <$> fromProp--instance FromProp Double where- fromProp = toRealFloat <$> fromProp--instance FromProp Integer where- fromProp = toInteger <$> (fromProp :: Prop Int)--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--instance FromProp NominalDiffTime where- fromProp = fromInteger <$> fromProp--instance FromProp DiffTime where- fromProp = timeOfDayToTime <$> fromProp--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"--instance FromProp UTCTime where- fromProp = readPrimitive go- where- go s (VZTime _ a b) = O s (zonedTimeToUTC $ ZonedTime b a)- go s x = F s $ getType x ++ " cannot be UTCTime"--instance FromProp ZonedTime where- fromProp = readPrimitive go- where- go s (VZTime _ a b) = O s (ZonedTime b a)- go s x = F s $ getType x ++ " cannot be ZonedTime"--instance FromProp LocalTime where- fromProp = readPrimitive go- where- go s (VLTime _ b) = O s b- go s (VZTime _ _ b) = O s b- go s x = F s $ getType x ++ " cannot be LocalTime"--instance FromProp Day where- fromProp = readPrimitive go- where- go s (VDay _ b) = O s b- go s (VLTime _ b) = O s (localDay b)- go s x = F s $ getType x ++ " cannot be Day"--instance FromProp TimeOfDay where- fromProp = readPrimitive readTimeOfDay--readTimeOfDay :: [Selector] -> Value -> PResult TimeOfDay-readTimeOfDay s (VHour _ b) = O s b-readTimeOfDay s (VLTime _ b) = O s (localTimeOfDay b)-readTimeOfDay s x = F s $ getType x ++ " cannot be TimeOfDay"--instance FromProp CBool where- fromProp = do- b <- fromProp- return $ if b then 1 else 0--instance FromProp CShort where- fromProp = CShort <$> fromProp--instance FromProp CUShort where- fromProp = CUShort <$> fromProp--instance FromProp CInt where- fromProp = CInt <$> fromProp--instance FromProp CUInt where- fromProp = CUInt <$> fromProp--instance FromProp CLong where- fromProp = CLong <$> fromProp--instance FromProp CULong where- fromProp = CULong <$> fromProp--instance FromProp CLLong where- fromProp = CLLong <$> fromProp--instance FromProp CULLong where- fromProp = CULLong <$> fromProp--instance FromProp CFloat where- fromProp = CFloat <$> fromProp--instance FromProp CDouble where- fromProp = CDouble <$> fromProp-----
+ src/Salak/Trie.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Salak.Trie where++import Control.Monad (Monad (..))+import Data.Bool+import Data.Eq+import Data.Foldable (Foldable (..))+import Data.Function+import Data.Functor+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import Data.List (concat, intercalate, map, reverse, (++))+import Data.Maybe+import Data.Tuple (uncurry)+import Salak.Internal.Key+import Text.Show (Show (..))++data Trie v = Trie !(Maybe v) !(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++empty :: Trie v+empty = Trie Nothing HM.empty++null :: Eq v => Trie v -> Bool+null = (== empty)++instance Foldable Trie where+ foldr f b (Trie v m) = foldr (flip (foldr f)) (go v) m+ where+ go (Just x) = f x b+ go _ = b++member :: Eq v => Keys -> Trie v -> Bool+member k t = isJust (lookup k t)++lookup :: Eq v => Keys -> Trie v -> Maybe v+lookup (Keys keys) = go keys+ where+ go [] (Trie v _) = v+ go (k:ks) (Trie _ m) = case HM.lookup k m of+ Just t -> go ks t+ _ -> Nothing++insert :: Eq v => Keys -> v -> Trie v -> Trie v+insert ks v = alter (\_ -> Just v) ks++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' :: Eq v => Keys -> (Trie v -> Trie v) -> Trie v -> Trie v+modify' (Keys ks) f = foldr modify f ks++modifyF :: (Monad m, Eq v) => Key -> (Trie v -> m (Trie v)) -> Trie v -> m (Trie v)+modifyF k f (Trie v m) = Trie v <$> HM.alterF go k m+ where+ go (Just w) = (\x -> if x == empty then Nothing else Just x) <$> f w+ go _ = return Nothing++alter :: Eq v => (Maybe v -> Maybe v) -> Keys -> Trie v -> Trie v+alter f (Keys keys) = go keys+ where+ go [] (Trie v m) = Trie (f v) m+ go (k:ks) (Trie v m) = Trie v $ HM.alter (g2 ks) k m+ g2 ks t = let t1 = go ks (fromMaybe empty t) in if t1 == empty then Nothing else Just t1++alterF :: (Functor f, Eq v) => (Maybe v -> f(Maybe v)) -> Keys -> Trie v -> f (Trie v)+alterF f (Keys keys) = go keys+ where+ go [] (Trie v m) = (`Trie` m) <$> f v+ go (k:ks) (Trie v m) = Trie v <$> HM.alterF (g2 ks) k m+ g2 ks t = g3 <$> go ks (fromMaybe empty t)+ g3 t = if t == empty then Nothing else Just t++toList :: Trie v -> [(Keys, v)]+toList = go []+ where+ go p (Trie (Just v) m) = (Keys $ reverse p, v) : g2 p m+ go p (Trie _ m) = g2 p m+ g2 p m = concat $ g3 p <$> HM.toList m+ g3 p (k,t) = go (k:p) t++fromList :: Eq v => [(Keys, v)] -> Trie v+fromList = foldr (uncurry insert) empty++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+ ok (Just x) = f x+ ok _ = False+ go = HM.mapMaybe (g2 . filter f) m+ g2 x = if x == empty then Nothing else Just x++partition :: Eq v => (v -> Bool) -> Trie v -> (Trie v, Trie v)+partition f t = (filter f t, filter (not.f) t)++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+++merge :: (Maybe v -> Maybe v -> Maybe v3) -> Trie v -> Trie v -> Trie v3+merge f (Trie v1 m1) (Trie v2 m2) = Trie (f v1 v2) $ foldr go HM.empty $ HM.keys $ HM.union m1 m2+ where+ go k =+ let x1 = fromMaybe empty $ HM.lookup k m1+ x2 = fromMaybe empty $ HM.lookup k m2+ in HM.insert k (merge f x1 x2)+
− src/Salak/Types.hs
@@ -1,146 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-module Salak.Types(- SourcePack(..)- , emptySourcePack- , mapSource- , select- , addErr- , tryLoadFile- , load- , loadOnce- , loadMock- , loadOnceMock- , runLoadT- , LoadSalakT(..)- , jump- , runReload- ) where--import Control.Monad.State-import Control.Monad.Writer-import qualified Data.IntMap.Strict as MI-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import Salak.Types.Selector-import Salak.Types.Source-import Salak.Types.Value-import System.Directory--data Reload = Reload- { sourceName :: Text- , canReload :: Bool- , reloadS :: Priority -> IO ([String], Source)- }--runReload :: [IO (Priority, ([String], Source))] -> Priority -> Reload -> [IO (Priority, ([String], Source))]-runReload b i Reload{..} = if canReload then ((i,) <$> reloadS i) : b else b--instance Show Reload where- show (Reload s _ _) = T.unpack s--defReload :: Bool -> String -> LoadSalakT IO () -> Reload-defReload cr s spt = Reload (T.pack s) cr (\i -> go <$> runLoadT (Just i) spt)- where- go SourcePack{..} = (errs, source)--emptyReload :: String -> Reload-emptyReload s = defReload False s (return ())---- | Source package, used to store all properties.-data SourcePack = SourcePack- { prefix :: [Selector]- , packId :: Int- , source :: Source- , reEnv :: MI.IntMap Reload- , errs :: [String]- } deriving Show--emptySourcePack :: SourcePack-emptySourcePack = SourcePack [] 0 emptySource mempty []--mapSource :: (Source -> Source) -> SourcePack -> SourcePack-mapSource f sp = sp { source = f (source sp)}--select :: SourcePack -> Selector -> SourcePack-select sp n = sp { source = selectSource n (source sp), prefix = n : prefix sp}--addErr :: Monad m => String -> LoadSalakT m ()-addErr e = LoadSalakT $ get >>= (\sp -> return sp {errs = e : errs sp}) >>= put--loadInternal- :: Monad m- => Reload- -> (Priority -> Source -> WriterT [String] m Source)- -> LoadSalakT m ()-loadInternal file go = LoadSalakT $ do- SourcePack{..} <- get- (s', e) <- lift $ runWriterT $ go packId source- put $ SourcePack prefix (packId+1) s' (MI.insert packId file reEnv) (errs ++ e)---- ^ Load properties, supports reload when triggered.-load- :: MonadIO m- => String -- ^ Loading name- -> (Priority -> Source -> WriterT [String] IO Source) -- ^ Convert properties- -> LoadSalakT m ()-load file go = loadInternal (defReload True file $ load file go) (\i -> x . go i)- where- x a = do- (s, w) <- liftIO $ runWriterT a- tell w- return s--tryLoadFile :: MonadIO m => (FilePath -> LoadSalakT m ()) -> FilePath -> LoadSalakT m ()-tryLoadFile f file = do- b <- liftIO $ doesFileExist file- when b $ do- liftIO $ putStrLn $ "Load " <> file- f file---- | Load properties only once-loadOnce- :: (Foldable f, Monad m)- => String -- ^ Loading name- -> f a -- ^ Properties- -> (Priority -> a -> m (Text, Value)) -- ^ Convert properties to Value- -> LoadSalakT m ()-loadOnce name fa f = loadInternal (emptyReload name) $ \i s -> foldM (go i) s fa- where- go i s a = do- (k, v) <- lift $ f i a- insert k v s---- | Put key value pairs into `SourcePack`-loadOnceMock :: Monad m => [(Text, Text)] -> LoadSalakT m ()-loadOnceMock fs = loadOnce "Mock" fs (\i (k,v) -> return (k, newVStr v i))--loadMock :: MonadIO m => [(Text, IO Text)] -> LoadSalakT m ()-loadMock fs = load "Mock" $ \i s -> foldM (go i) s fs- where- go :: Priority -> Source -> (Text, IO Text) -> WriterT [String] IO Source- go i s (k, iov) = do- v <- lift iov- insert k (VStr i v) s--runLoadT :: Monad m => Maybe Priority -> LoadSalakT m a -> m SourcePack-runLoadT i (LoadSalakT ac) = execStateT ac emptySourcePack { packId = fromMaybe 0 i }---- | Load Salak Monad Transfer-newtype LoadSalakT m a = LoadSalakT { unLoad :: StateT SourcePack m a } deriving (Functor, Applicative, Monad, MonadTrans)--instance MonadIO m => MonadIO (LoadSalakT m) where- liftIO = lift . liftIO--jump :: MonadIO m => LoadSalakT IO a -> LoadSalakT m a-jump (LoadSalakT a) = LoadSalakT $ do- (a', sp) <- get >>= liftIO . runStateT a- put sp- return a'---
− src/Salak/Types/Selector.hs
@@ -1,62 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Salak.Types.Selector where--import Control.Applicative ((<|>))-import Data.Attoparsec.Text-import Data.List (intercalate)-import Data.Text (Text)-import qualified Data.Text as T--data Selector- = SStr !Text- | SNum !Int- deriving (Eq, Ord)--isStr :: Selector -> Bool-isStr (SStr _) = True-isStr _ = False--instance Show Selector where- show (SStr x) = T.unpack x- show (SNum i) = "[" ++ show i ++ "]"--toKey :: [Selector] -> String-toKey = intercalate "." . go . reverse- where- go (a@(SStr _):cs) = let (b,c) = break isStr cs in (show a ++ concat (show <$> b)) : go c- go (a:cs) = show a : go cs- go [] = []--simpleSelectors :: Text -> [Selector]-simpleSelectors as = fmap SStr $ filter (not.T.null) $ T.splitOn "." as--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 '.')--sName :: Parser Selector-sName = SStr . T.pack <$> do- a <- choice [letter, digit]- b <- many' (choice [letter, digit, char '-', char '_'])- return (a:b)--sNum :: Parser Selector-sNum = SNum <$> paren decimal- where- paren e = do- _ <- char '['- ex <- e- _ <- char ']'- return ex---- xx--- xx.xx--- xx.xx[0]--- xx.xx[1].xx-expr :: Parser [Selector]-expr = (:) <$> sName <*> many' sNum
− src/Salak/Types/Source.hs
@@ -1,91 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-module Salak.Types.Source where--import Control.Monad.Writer-import qualified Data.Map.Strict as M-import Data.Maybe-import qualified Data.Text as T-import Salak.Types.Selector-import Salak.Types.Value--data SourceT v = Source- { value :: v- , mapValue :: M.Map Selector (SourceT v)- } deriving (Eq, Functor)--instance Foldable SourceT where- foldr g b Source{..} = M.foldl (foldr g) (g value b) mapValue--type Source = SourceT QV--showKey :: String -> Selector -> String-showKey p (SStr k)- | null p = T.unpack k- | otherwise = p <> "." <> T.unpack k-showKey p (SNum k) = p <> "[" <> show k <> "]"--instance Show Source where- show = unlines . go ""- where- go p Source{..} = concat $ M.foldrWithKey (\k v b -> go (showKey p k) v : b) [ g2 p value] mapValue- g2 x v = if nullQ v then [] else [x <> "=" <> show v]--emptySource :: Source-emptySource = Source mempty mempty--foldSource :: (Value -> b -> b) -> b -> Source -> b-foldSource f = foldr (\q b -> maybe b (`f` b) $ getQ q)--sizeSource :: Source -> Int-sizeSource = foldSource (const (+1)) 0--nullSource :: Source -> Bool-nullSource = foldSource (\_ _ -> False) True--selectSource :: Selector -> Source -> Source-selectSource n Source{..} = fromMaybe emptySource $ M.lookup n mapValue--updateSource :: Monad m => Selector -> (Source -> m Source) -> Source -> m Source-updateSource n f ss = do- ss' <- f $ selectSource n ss- return $ ss { mapValue = M.insert n ss' (mapValue ss) }--updateSources :: Monad m => [Selector] -> (Source -> m Source) -> Source -> m Source-updateSources = flip (foldr updateSource)--replace :: Priority -> Source -> Source -> Writer [String] Source-replace = replace' []--replace' :: [Selector] -> Priority -> Source -> Source -> Writer [String] Source-replace' ss i ns os = do- q' <- replaceQ (toKey ss) i (value ns) (value os)- m' <- mapM snd $ M.mapWithKey g2 $ M.unionWithKey go (f 0 $ mapValue ns) (f 1 $ mapValue os)- return (Source q' $ M.filter (not.nullSource) m')- where- f j m = (j :: Int,) . return <$> m- go k (_, a) (_, b) = (2, a >>= \a' -> b >>= \b' -> replace' (k:ss) i a' b')- g2 k (0, a) = (0, a >>= \a' -> replace' (k:ss) i a' emptySource)- g2 k (1, a) = (1, a >>= \a' -> replace' (k:ss) i emptySource a')- g2 _ (_, a) = (2 :: Int, a)--insert :: Monad m => T.Text -> Value -> Source -> WriterT [String] m Source-insert k v s = case selectors k of- Left e -> tell [e] >> return s- Right k' -> return (insert' k' v s)--insert' :: [Selector] -> Value -> Source -> Source-insert' ns v = foldr go (insertSource v) ns- where- go n f s = s { mapValue = M.alter (Just . f . fromMaybe emptySource) n $ mapValue s}--insertSource :: Value -> Source -> Source-insertSource v s = s { value = insertQ v $ value s}----
− src/Salak/Types/Value.hs
@@ -1,105 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Salak.Types.Value where--import Control.Monad.Writer-import Data.Attoparsec.Text-import qualified Data.PQueue.Min as Q-import Data.Scientific (Scientific)-import Data.Text (Text)-import qualified Data.Text as T-import Data.Time-import Salak.Types.Selector--type Priority = Int--data RefText- = RRef [Selector]- | RVal !Text- deriving (Eq, Show)--data Value- = VStr !Priority !Text- | VRef !Priority ![RefText]- | VNum !Priority !Scientific- | VBool !Priority !Bool- | VZTime !Priority !TimeZone !LocalTime- | VLTime !Priority !LocalTime- | VDay !Priority !Day- | VHour !Priority !TimeOfDay- deriving Eq--instance Ord Value where- compare a b = compare (getPriority a) (getPriority b)--instance Show Value where- show v = let (a,b,c) = typeOfV v in c <> ":" <> b <> "#" <> show a--newVStr :: Text -> Priority -> Value-newVStr v i = g4 $ g3 $ go v- where- go v' =- let (a,b) = T.break (=='$') v'- in if T.null b- then [RVal a]- else RVal a : g2 b (parse ref b)- g2 _ (Done x r) = r : go x- g2 b _ = [RVal b]- g3 (RVal a:RVal b:cs) = g3 $ RVal (a <> b) :cs- g3 (RVal a:bs) = if T.null a then g3 bs else RVal a: g3 bs- g3 (RRef a:bs) = RRef a : g3 bs- g3 [] = []- g4 [RVal a] = VStr i a- g4 x = VRef i x--ref :: Parser RefText-ref = RRef <$> do- _ <- char '$'- _ <- char '{'- r <- exprs- _ <- char '}'- return r--typeOfV :: Value -> (Priority, String, String)-typeOfV (VStr a b) = (a, "Str", show b)-typeOfV (VRef a b) = (a, "Ref", show b)-typeOfV (VNum a b) = (a, "Num", show b)-typeOfV (VBool a b) = (a, "Bool", show b)-typeOfV (VZTime a b c) = (a, "ZonedTime", show (ZonedTime c b))-typeOfV (VLTime a b) = (a, "LocalTime", show b)-typeOfV (VDay a b) = (a, "Day", show b)-typeOfV (VHour a b) = (a, "TimeOfDay", show b)--getPriority :: Value -> Priority-getPriority x = let (a,_,_) = typeOfV x in a--getType :: Value -> String-getType x = let (_,b,_) = typeOfV x in b--getV :: Value -> String-getV x = let (_,_,b) = typeOfV x in b--type QV = Q.MinQueue Value--getQ :: QV -> Maybe Value-getQ = Q.getMin--nullQ :: QV -> Bool-nullQ = Q.null--insertQ :: Value -> QV -> QV-insertQ = Q.insert--replaceQ :: Monad m => String -> Priority -> QV -> QV -> WriterT [String] m QV-replaceQ s i nq q = do- let nq' = Q.filter ((==i) . getPriority) nq- (a,b) = Q.partition ((==i) . getPriority) q- go v = tell $ (\vi -> "#" <> show i <> " " <> vi) <$> v- if a == nq'- then return q- else case getQ nq' of- Just v -> do- go [(if Q.null a then "Add " else "Mod ") ++ s]- return $ Q.insert v b- _ -> do- unless (Q.null a) $ go ["Del " ++ s]- return b
test/Spec.hs view
@@ -1,26 +1,24 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} module Main where +import Control.Monad.Catch import Control.Monad.Writer-import Data.Either-import Data.List (intercalate)-import Data.Menshen-import Data.Text (Text, pack, unpack)+import Data.List (intercalate)+import Data.Text (Text, pack, unpack) import GHC.Generics import Salak-import Salak.Load.Dynamic-import Salak.Prop-import Salak.Types-import Salak.Types.Selector-import Salak.Types.Source-import Salak.Types.Value-import System.Random (randomIO)+import Salak.Internal+import Salak.Internal.Source+import qualified Salak.Trie as T+import System.Random (randomIO) import Test.Hspec import Test.QuickCheck @@ -45,142 +43,149 @@ return (v ++ "[" ++ show x ++ "]") return (SKey $ pack $ intercalate "." vs) -data Conf = Conf- { name :: String- , age :: Int- , male :: Bool- , det :: SubConf- } deriving (Eq, Show, Generic)+data Hello = Hello+ { hello :: IO Int+ } deriving Generic -data SubConf = SubConf- { hello :: String } deriving (Eq, Show, Generic)+instance (MonadThrow m, MonadIO m) => FromProp m Hello -instance FromProp SubConf where- fromProp = SubConf <$> "hello" .?= "yyy" ? pattern "[a-z]{3,16}"+data Config = Config+ { level :: IO Int+ , world :: Maybe Bool+ } -instance FromProp Conf+instance (MonadIO m, MonadCatch m) => FromProp m Config where+ fromProp = Config <$> "level" .?= (return 1) <*> "world" +loadRandom :: MonadIO m => Text -> LoadSalakT m ()+loadRandom key = loadList True (unpack key) go+ where+ go = do+ a :: Int <- randomIO+ return [(key, a)]+ specProperty :: SpecWith () specProperty = do context "selectors" $ do it "normal" $ do- selectors "" `shouldBe` Right []- selectors "." `shouldBe` Right []- selectors ".." `shouldBe` Right []- selectors "xx" `shouldBe` Right [SStr "xx"]- selectors "xx[0]" `shouldBe` Right [SStr "xx", SNum 0]- selectors "xx.yy" `shouldBe` Right [SStr "xx", SStr "yy"]- selectors "xx[0][1]" `shouldBe` Right [SStr "xx", SNum 0, SNum 1]- toKey (reverse $ SStr "x" : (SNum <$> [0..9])) `shouldBe` "x[0][1][2][3][4][5][6][7][8][9]"+ toKeys ("" :: Text) `shouldBe` Right (Keys $ [])+ toKeys ("." :: Text) `shouldBe` Right (Keys $ [])+ toKeys (".." :: Text) `shouldBe` Right (Keys $ [])+ toKeys ("xx" :: Text) `shouldBe` Right (Keys $ [KT "xx"])+ toKeys ("xx[0]" :: Text) `shouldBe` Right (Keys $ [KT "xx", KI 0])+ toKeys ("xx.yy" :: Text) `shouldBe` Right (Keys $ [KT "xx", KT "yy"])+ toKeys ("xx[0][1]" :: Text) `shouldBe` Right (Keys $ [KT "xx", KI 0, KI 1])+ show (Keys $ KT "x" : (KI <$> [0..9])) `shouldBe` "x[0][1][2][3][4][5][6][7][8][9]" it "QuickCheck" $ do- quickCheck $ \s -> let s' = unKey s in (toKey . reverse <$> selectors s') `shouldBe` Right (unpack s')- context "value" $ do- it "basic" $ do- newVStr "xxxx" 0 `shouldBe` VStr 0 "xxxx"- newVStr "{x.y}" 0 `shouldBe` VStr 0 "{x.y}"- newVStr "${x*}" 0 `shouldBe` VStr 0 "${x*}"- newVStr "${x}" 0 `shouldBe` VRef 0 [RRef [SStr "x"]]- newVStr "${x.y}" 0 `shouldBe` VRef 0 [RRef [SStr "x", SStr "y"]]- newVStr "${x${y}}" 0 `shouldBe` VStr 0 "${x${y}}"- newVStr "a${x}b" 0 `shouldBe` VRef 0 [RVal "a", RRef [SStr "x"], RVal "b"]- newVStr "a${x}b${" 0 `shouldBe` VRef 0 [RVal "a", RRef [SStr "x"], RVal "b${"]- newVStr "a${x}b${c}" 0 `shouldBe` VRef 0 [RVal "a", RRef [SStr "x"], RVal "b", RRef [SStr "c"]]+ quickCheck $ \s -> let s' = unKey s in (show <$> toKeys s') `shouldBe` Right (unpack s')+ -- context "value" $ do+ -- it "basic" $ do+ -- newVT "xxxx" 0 `shouldBe` VT 0 "xxxx"+ -- newVT "{x.y}" 0 `shouldBe` VT 0 "{x.y}"+ -- newVT "${x*}" 0 `shouldBe` VT 0 "${x*}"+ -- newVT "${x}" 0 `shouldBe` VRef 0 [RRef [KT "x"]]+ -- newVT "${x.y}" 0 `shouldBe` VRef 0 [RRef [KT "x", KT "y"]]+ -- newVT "${x${y}}" 0 `shouldBe` VT 0 "${x${y}}"+ -- newVT "a${x}b" 0 `shouldBe` VRef 0 [RVal "a", RRef [KT "x"], RVal "b"]+ -- newVT "a${x}b${" 0 `shouldBe` VRef 0 [RVal "a", RRef [KT "x"], RVal "b${"]+ -- newVT "a${x}b${c}" 0 `shouldBe` VRef 0 [RVal "a", RRef [KT "x"], RVal "b", RRef [KT "c"]] context "source" $ do- it "normal" $ do- sizeSource emptySource `shouldBe` 0 it "normal - 2" $ do- let (s1,e1) = runWriter $ insert "hello" (VStr 0 "world") emptySource- sizeSource s1 `shouldBe` 1- length e1 `shouldBe` 0- it "normal - 3" $ do- let (s2,e2) = runWriter $ insert "1" (VStr 0 "world") emptySource- sizeSource s2 `shouldBe` 1- length e2 `shouldBe` 0- it "normal - 4" $ do- let (s3,e3) = runWriter $ insert "a.b" (VStr 0 "world") emptySource- print s3- sizeSource s3 `shouldBe` 1- length e3 `shouldBe` 0- context "source - merge" $ do- let s = fst $ runWriter $ insert "hello" (VStr 0 "world") emptySource- so = fst $ runWriter $ insert "hello" (VStr 1 "yyyyy") emptySource- s1 = fst $ runWriter $ insert "hello" (VStr 0 "xxxxx") emptySource- it "merge - del" $ do- let (s2,e2) = runWriter $ replace 0 emptySource s- s2 `shouldBe` emptySource- e2 `shouldBe` ["#0 Del hello"]- let (s3,e3) = runWriter $ replace 1 emptySource s- s3 `shouldBe` s- e3 `shouldBe` []- it "merge - mod" $ do- let (s3,e3) = runWriter $ replace 0 s1 s- e3 `shouldBe` ["#0 Mod hello"]- s3 `shouldBe` s1- let (s2,e2) = runWriter $ replace 1 s1 s- e2 `shouldBe` []- s2 `shouldBe` s- let (_,e4) = runWriter $ replace 1 so s- e4 `shouldBe` ["#1 Add hello"]- it "merge - add" $ do- let (s4,e4) = runWriter $ replace 0 s emptySource- e4 `shouldBe` ["#0 Add hello"]- s4 `shouldBe` s- let (s2,e2) = runWriter $ replace 1 s emptySource- s2 `shouldBe` emptySource- e2 `shouldBe` []- let (s3,e3) = runWriter $ replace 1 so emptySource- e3 `shouldBe` ["#1 Add hello"]- s3 `shouldBe` so- it "merge - unchange" $ do- let (s5,e5) = runWriter $ replace 0 s s- e5 `shouldBe` []- s5 `shouldBe` s- context "Generic" $ do- it "conf" $ do- sp <- runLoadT Nothing $ loadOnceMock- [ ("name", "Daniel")- , ("age", "18")- , ("male", "yes")- ]- errs sp `shouldBe` []- let a = search "" sp :: Either String Conf- print a- isRight a `shouldBe` True- it "placeholder" $ do- let xs = [ ("name", "daniel")- , ("user", "${name}")- , ("a","${b}")- , ("b","${a}")- , ("x", "${y}")- , ("y", "${z}")- , ("z", "Hey! you")- ]- loadAndRunSalak (loadOnceMock xs) $ do- a <- require "name"- b <- require "user"- x <- require "x"- z <- require "z"- lift $ do- a `shouldBe` (b :: Text)- x `shouldBe` (z :: Text)- let x = loadAndRunSalak (loadOnceMock xs) (require "a") :: IO Text- x `shouldThrow` anyErrorCall+ let (a,b,c) = extract T.empty $ gen 0 ([("hello", "world")] :: [(Text, Text)])+ length c `shouldBe` 0+ length (T.toList b) `shouldBe` 1+ -- it "normal - 3" $ do+ -- let (s2,e2) = runWriter $ insert "1" (VT 0 "world") emptySource+ -- sizeSource s2 `shouldBe` 1+ -- length e2 `shouldBe` 0+ -- it "normal - 4" $ do+ -- let (s3,e3) = runWriter $ insert "a.b" (VT 0 "world") emptySource+ -- print s3+ -- sizeSource s3 `shouldBe` 1+ -- length e3 `shouldBe` 0+ -- context "source - merge" $ do+ -- let s = fst $ runWriter $ insert "hello" (VT 0 "world") emptySource+ -- so = fst $ runWriter $ insert "hello" (VT 1 "yyyyy") emptySource+ -- s1 = fst $ runWriter $ insert "hello" (VT 0 "xxxxx") emptySource+ -- it "merge - del" $ do+ -- let (s2,e2) = runWriter $ replace 0 emptySource s+ -- s2 `shouldBe` emptySource+ -- e2 `shouldBe` ["#0 Del hello"]+ -- let (s3,e3) = runWriter $ replace 1 emptySource s+ -- s3 `shouldBe` s+ -- e3 `shouldBe` []+ -- it "merge - mod" $ do+ -- let (s3,e3) = runWriter $ replace 0 s1 s+ -- e3 `shouldBe` ["#0 Mod hello"]+ -- s3 `shouldBe` s1+ -- let (s2,e2) = runWriter $ replace 1 s1 s+ -- e2 `shouldBe` []+ -- s2 `shouldBe` s+ -- let (_,e4) = runWriter $ replace 1 so s+ -- e4 `shouldBe` ["#1 Add hello"]+ -- it "merge - add" $ do+ -- let (s4,e4) = runWriter $ replace 0 s emptySource+ -- e4 `shouldBe` ["#0 Add hello"]+ -- s4 `shouldBe` s+ -- let (s2,e2) = runWriter $ replace 1 s emptySource+ -- s2 `shouldBe` emptySource+ -- e2 `shouldBe` []+ -- let (s3,e3) = runWriter $ replace 1 so emptySource+ -- e3 `shouldBe` ["#1 Add hello"]+ -- s3 `shouldBe` so+ -- it "merge - unchange" $ do+ -- let (s5,e5) = runWriter $ replace 0 s s+ -- e5 `shouldBe` []+ -- s5 `shouldBe` s+ -- context "Generic" $ do+ -- it "conf" $ do+ -- sp <- runLoadT Nothing $ loadOnceMock+ -- [ ("name", "Daniel")+ -- , ("age", "18")+ -- , ("male", "yes")+ -- ]+ -- errs sp `shouldBe` []+ -- let a = search "" sp :: Either String Conf+ -- print a+ -- isRight a `shouldBe` True+ -- it "placeholder" $ do+ -- let xs = [ ("name", "daniel")+ -- , ("user", "${name}")+ -- , ("a","${b}")+ -- , ("b","${a}")+ -- , ("x", "${y}")+ -- , ("y", "${z}")+ -- , ("z", "Hey! you")+ -- ]+ -- loadAndRunSalak (loadOnceMock xs) $ do+ -- a <- require "name"+ -- b <- require "user"+ -- x <- require "x"+ -- z <- require "z"+ -- lift $ do+ -- a `shouldBe` (b :: Text)+ -- x `shouldBe` (z :: Text)+ -- let x = loadAndRunSalak (loadOnceMock xs) (require "a") :: IO Text+ -- x `shouldThrow` anyErrorCall context "Reload test" $ do it "reload" $ do- (x :: IO Int,r) <- loadAndRunSalak (loadMock [("hello", pack . show <$> (randomIO :: IO Int))]) $ do- v <- requireD "hello"- a <- reloadAction- return (v,a)- a <- x- ReloadResult{..} <- r- isError `shouldBe` False- mapM_ print msg- b <- x- a `shouldNotBe` b----+ loadAndRunSalak (loadRandom "hello") $ do+ Hello{..} <- require ""+ Config{..} <- require ""+ x <- liftIO hello+ liftIO $ print x+ liftIO $ print world+ q1 <- liftIO level+ r <- askReload+ lift $ quickCheck $ \(_ :: Int) -> do+ ReloadResult{..} <- liftIO r+ when hasError $ print msgs+ hasError `shouldBe` False+ msgs `shouldBe` ["hello:Mod"]+ y <- hello+ x `shouldNotBe` y+ q2 <- level+ q1 `shouldBe` q2