salak 0.3 → 0.3.1
raw patch · 8 files changed
+328/−269 lines, 8 files
Files
- README.md +22/−20
- salak.cabal +2/−2
- src/Salak.hs +33/−59
- src/Salak/Internal.hs +40/−61
- src/Salak/Internal/Prop.hs +133/−97
- src/Salak/Internal/Source.hs +3/−11
- src/Salak/Trie.hs +92/−15
- test/Spec.hs +3/−4
README.md view
@@ -12,10 +12,23 @@ ## salak-toml [](https://hackage.haskell.org/package/salak-toml) -This library define a universal procedure to load configurations and parse properties, also supports reload configuration files.+## Introduction+This library defines a universal procedure to load configurations and parse properties, also supports reload configuration files. -We can load configurations from command line, environment, configuration files such as yaml or toml etc, and we may want to have our own strategies to load configurations from multi sources and overwrite properties by orders of these sources.+## Parse Functions +`HasSalak` monad provide a unified function `require` to parse properties. Here are some examples.++```Haskell+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" -- This property can be changed by reloading configurations.+```++## Load Strategy+We can load configurations from command lines, environment, configuration files such as yaml or toml etc., and we may want to have our own strategies to load configurations from multiply sources and overwrite properties by orders of these sources.+ `PropConfig` defines a common loading strategy: > 1. loadCommandLine > 2. loadEnvironment@@ -25,26 +38,15 @@ > 6. load file from home folder if enabled > 7. file extension matching, support yaml or toml or any other loader. -Load earlier has higher orders, orders cannot be changed.--`ReaderT SourcePack m` defines how to read properties:-```Haskell-require "abc.prop"-```--`ReloadableSourcePackT m` defines how to read reloadable properties:-```Haskell-requireD "abc.dynamic.prop"-```+Load earlier has higher priorities. Priorities cannot be changed. -For commandline and environment, +For command lines and environment, ``` CommandLine: --package.a.enabled=true Environment: PACKAGE_A_ENABLED: false ``` -Usage:-+## Usage Environment: ```@@ -69,7 +71,7 @@ , ext :: Int } deriving (Eq, Show) -instance MonadCatch m => FromProp m Config where+instance Monad m => FromProp m Config where fromProp = Config <$> "user" ? pattern "[a-z]{5,16}" <*> "pwd"@@ -77,17 +79,17 @@ main = runSalakWith "salak" (YAML :|: TOML) $ do c :: Config <- require "test.config"- lift $ print c=+ lift $ print c ``` GHCi play ```Haskell-λ> :set -XFlexibleInstances -XMultiParamTypeClasses +λ> :set -XFlexibleInstances -XMultiParamTypeClasses -XOverloadedStrings λ> import Salak λ> 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+λ> instance Monad m => FromProp m Config where fromProp = Config <$> "user" <*> "dir" <*> "ext" .?= 1 λ> runSalak def (require "") :: IO Config Config {name = "daniel", dir = Nothing, ext = 1} ```
salak.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 name: salak-version: 0.3+version: 0.3.1 license: BSD3 license-file: LICENSE copyright: (c) 2018 Daniel YU maintainer: Daniel YU <leptonyu@gmail.com> author: Daniel YU homepage: https://github.com/leptonyu/salak#readme-synopsis: Configuration Loader+synopsis: Configuration (re)Loader and Parser. category: Library, Configuration build-type: Simple extra-source-files:
src/Salak.hs view
@@ -7,13 +7,13 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module: Salak--- Copyright: (c) 2019 Daniel YU+-- Copyright: 2019 Daniel YU -- License: BSD3 -- Maintainer: leptonyu@gmail.com -- Stability: experimental -- Portability: portable ----- Configuration Loader for Production in Haskell.+-- Configuration (re)Loader and Parser. -- module Salak( -- * How to use this library@@ -25,11 +25,18 @@ , loadAndRunSalak , loadAndRunSalak' , PropConfig(..)- -- * Run Functions- , HasSalak(..)+ -- * Parsing Properties Function , MonadSalak(..) , RunSalakT , RunSalak+ -- ** Operators+ , PropOp(..)+ , FromProp(..)+ , Prop+ , readPrimitive+ , readEnum+ , SourcePack+ , SalakException(..) -- * Load Functions -- ** Monad for Loader , LoadSalakT@@ -49,15 +56,6 @@ , (:|:)(..) -- ** Reload Functions , ReloadResult(..)- , askReload- -- * Properties Parsers- , PropOp(..)- , FromProp(..)- , Prop- , readPrimitive- , readEnum- , SourcePack- , PropException(..) -- * Reexport , MonadCatch , MonadThrow@@ -128,7 +126,7 @@ -- > 6. load file from home folder if enabled -- > 7. file extension matching, support yaml or toml or any other loader. ---loadSalak :: (MonadCatch m, MonadIO m) => PropConfig -> LoadSalakT m ()+loadSalak :: (MonadThrow m, MonadIO m) => PropConfig -> LoadSalakT m () loadSalak PropConfig{..} = do loadCommandLine commandLine loadEnv@@ -143,12 +141,12 @@ ifS _ _ = return Nothing loadConf n mf = lift mf >>= mapM_ (liftNT . loadExt . (</> n)) -loadSalakWith :: (MonadCatch m, MonadIO m, HasLoad file) => file -> FileName -> LoadSalakT m ()+loadSalakWith :: (MonadThrow m, MonadIO m, HasLoad file) => file -> FileName -> LoadSalakT m () loadSalakWith file name = loadSalak def { configName = Just 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 $ \sp -> runRunSalak sp ma+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@@ -160,10 +158,11 @@ -- $use ----- | This library define a universal procedure to load configurations and parse properties, also supports reload configuration files.+-- | This library defines a universal procedure to load configurations and parse properties, also supports reload configurations. -- ----- We can load configurations from command line, environment, configuration files such as yaml or toml etc, and we may want to have our own strategies to load configurations from multi sources and overwrite properties by orders of these sources.+-- We can load configurations from command lines, environment, configuration files such as yaml or toml etc.,+-- and we may want to have our own strategies to load configurations from multiply sources and overwrite properties by orders of these sources. -- -- `PropConfig` defines a common loading strategy: --@@ -175,51 +174,26 @@ -- > 6. load file from home folder if enabled -- > 7. file extension matching, support yaml or toml or any other loader. ----- Load earlier has higher priority, priorities cannot be changed.--------- Usage:--------- Environment:------ > export TEST_CONFIG_NAME=daniel------ Current Directory: salak.yaml------ > test.config:--- > name: noop--- > dir: ls+-- Load earlier has higher priority. Priorities cannot be changed. ----- Current Directory: salak.toml+-- After loading configurations, we can use `require` to parse properties. For example: ----- > [test.config]--- > ext=2+-- > 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" ----- > data Config = Config--- > { name :: Text--- > , dir :: Maybe Text--- > , ext :: Int--- > } deriving (Eq, Show)--- >--- > instance MonadCatch m => FromProp m Config where--- > fromProp = Config--- > <$> "user" ? pattern "[a-z]{5,16}"--- > <*> "pwd"--- > <*> "ext" .?= 1--- >--- > main = runSalakWith "salak" (YAML :|: TOML) $ do--- > c :: Config <- require "test.config"--- > lift $ print c+-- Salak supports parse `IO` values, which actually wrap a 'Control.Concurrent.MVar.MVar' variable and can be reseted by reloading configurations.+-- Normal value will not be affected by reloading configurations. -- -- GHCi play ----- > λ> :set -XFlexibleInstances -XMultiParamTypeClasses--- > λ> import Salak--- > λ> 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}+-- >>> :set -XFlexibleInstances -XMultiParamTypeClasses -XOverloadedStrings+-- >>> import Salak+-- >>> import Data.Default+-- >>> import Data.Text(Text)+-- >>> data Config = Config { name :: Text, dir :: Maybe Text, ext :: Int} deriving (Eq, Show)+-- >>> instance Monad 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
@@ -11,6 +11,16 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+-- |+-- Module: Salak.Internal+-- Copyright: 2019 Daniel YU+-- License: BSD3+-- Maintainer: leptonyu@gmail.com+-- Stability: experimental+-- Portability: portable+--+-- This module is used for implementing loaders.+-- module Salak.Internal( loadAndRunSalak' , loadTrie@@ -19,8 +29,7 @@ , LoadSalak , RunSalakT , RunSalak- , runRunSalak- , HasSalak(..)+ , runRun , MonadSalak(..) , loadMock , loadEnv@@ -47,6 +56,7 @@ import Control.Concurrent.MVar import Control.Monad import Control.Monad.Catch+import Control.Monad.Except import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Control.Monad.IO.Unlift as IU import Control.Monad.Reader@@ -74,77 +84,46 @@ } -- | 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)+newtype LoadSalakT m a = LoadSalakT (MS.StateT UpdateSource m a)+ deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MS.MonadState UpdateSource, MonadThrow, MonadCatch) -- | Simple IO Monad type LoadSalak = LoadSalakT IO +runLoad :: Monad m => LoadSalakT m a -> UpdateSource -> m a+runLoad (LoadSalakT ma) us = MS.evalStateT ma us+ liftNT :: MonadIO m => LoadSalak () -> LoadSalakT m ()-liftNT (LoadSalakT a) = do- ud <- MS.get- MS.liftIO $ MS.evalStateT a ud+liftNT a = MS.get >>= liftIO . runLoad a 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+instance (MonadThrow m, IU.MonadUnliftIO m) => IU.MonadUnliftIO (LoadSalakT m) where+ askUnliftIO = do ut <- MS.get- f <- MS.lift IU.askUnliftIO- return $ IU.UnliftIO $ IU.unliftIO f . (`MS.evalStateT` ut) . unLoad+ lift $ IU.withUnliftIO $ \u -> return (IU.UnliftIO (IU.unliftIO u . flip runLoad ut)) --- | Standard `HasSalak` instance.-newtype RunSalakT m a = RunSalakT { unRun :: ReaderT SourcePack m a } deriving (Functor, Applicative, Monad, MonadTrans)+-- | Standard `MonadSalak` instance.+newtype RunSalakT m a = 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) us = runReaderT ma us+ 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+instance (MonadThrow m, IU.MonadUnliftIO m) => IU.MonadUnliftIO (RunSalakT m) where+ askUnliftIO = 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+ lift $ IU.withUnliftIO $ \u -> return (IU.UnliftIO (IU.unliftIO u . flip runRun ut)) -- | Basic loader-loadTrie :: MonadIO m => Bool -> String -> (Int -> IO TraceSource) -> LoadSalakT m ()+loadTrie :: (MonadThrow m, MonadIO m) => Bool -> String -> (Int -> IO TraceSource) -> LoadSalakT m () loadTrie canReload name f = do UpdateSource{..} <- MS.get v <- liftIO $ readMVar ref@@ -156,7 +135,7 @@ let nut = UpdateSource ref (refNo + 1) (HM.insert refNo name refMap) qfunc update _ <- liftIO $ swapMVar ref t MS.put nut- else error $ show es+ else throwM $ PropException $ unlines es where go ts ud n = return $ do (c,d) <- ud@@ -164,20 +143,20 @@ return (c1,d) -- | Simple loader-loadList :: (MonadIO m, Foldable f, ToKeys k, ToValue v) => Bool -> String -> IO (f (k,v)) -> LoadSalakT m ()+loadList :: (MonadThrow m, 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`.+-- Users should use `SourcePack` to create custom `MonadSalak` instances, then you get will an instance of `MonadSalak`. 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+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 ())- MS.execStateT lm (UpdateSource r 0 HM.empty q u) >>= toSourcePack+ runLoad (lm >> MS.get) (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@@ -194,11 +173,11 @@ else return (ReloadResult True es) -- | Load mock variables into `Source`-loadMock :: MonadIO m => [(Text, Text)] -> LoadSalakT m ()+loadMock :: (MonadThrow m, MonadIO m) => [(Text, Text)] -> LoadSalakT m () loadMock fa = loadList False "mock" (return fa) -- | Load environment variables into `Source`-loadEnv :: MonadIO m => LoadSalakT m ()+loadEnv :: (MonadThrow m, MonadIO m) => LoadSalakT m () loadEnv = loadList False "environment" go where go = concatMap split2 . filter ((/= '_') . head . fst) <$> getEnvironment@@ -218,7 +197,7 @@ go _ = Nothing -- | Default way to parse command line arguments-loadCommandLine :: MonadIO m => ParseCommandLine -> LoadSalakT m ()+loadCommandLine :: (MonadThrow m, MonadIO m) => ParseCommandLine -> LoadSalakT m () loadCommandLine pcl = loadList False "commandLine" (getArgs >>= pcl) -- | Try load file, if file does not exist then do nothing.
src/Salak/Internal/Prop.hs view
@@ -26,6 +26,7 @@ import qualified Data.HashMap.Strict as HM import Data.Int import Data.List (sortBy)+import Data.Maybe import Data.Menshen import Data.Scientific import Data.Semigroup@@ -51,10 +52,13 @@ fromProp = fmap to gFromProp newtype Prop m a- = Prop { unProp :: ReaderT SourcePack m a }- deriving (Functor, Applicative, Monad, MonadReader SourcePack, MonadTrans)+ = Prop { unProp :: ReaderT SourcePack (ExceptT SomeException m) a }+ deriving (Functor, Applicative, Monad, MonadReader SourcePack, MonadIO) -instance MonadCatch m => A.Alternative (Prop m) where+instance MonadTrans Prop where+ lift = Prop . lift . lift++instance Monad m => A.Alternative (Prop m) where empty = notFound a <|> b = do v <- try a@@ -63,40 +67,67 @@ Left (_ :: SomeException) -> b -- | Core type class of salak, which provide function to parse properties.-class HasSalak m where+class Monad m => MonadSalak m where+ -- | Monad has the ability to get a `SourcePack` instance.+ askSalak :: m SourcePack++ -- | Get reload action which used for reload profiles+ askReload :: MonadSalak m => m (IO ReloadResult)+ askReload = reload <$> askSalak+ -- | 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` 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 = 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+ Right (k,t) -> runProp1 sp { source = t, pref = pref ++ unKeys k} fromProp +instance {-# OVERLAPPABLE #-} (m ~ t m', Monad m', Monad m, MonadTrans t, MonadSalak m') => MonadSalak m where+ askSalak = lift askSalak+ 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 Monad m => MonadThrow (Prop m) where+ throwM = Prop . lift . throwError . toException -instance MonadCatch m => MonadCatch (Prop m) where- catch (Prop a) f = Prop $ do+instance Monad m => MonadCatch (Prop m) where+ catch (Prop a) f = do sp <- ask- lift $ runReaderT a sp `catch` (\e -> runReaderT (unProp $ f e) sp)+ v <- lift $ runExceptT (runReaderT a sp)+ case v of+ Left e -> case fromException e of+ Just ee -> f ee+ _ -> throwM e+ Right x -> return x -runProp :: Monad m => SourcePack -> Prop m a -> m a-runProp sp (Prop p) = runReaderT p sp+runProp2 :: Monad m => SourcePack -> Prop m a -> m (Either SomeException a)+runProp2 sp (Prop p) = runExceptT (runReaderT p sp) -instance (MonadCatch m, FromProp m a) => FromProp m (Maybe a) where+runProp1 :: MonadThrow m => SourcePack -> Prop m a -> m a+runProp1 sp p = do+ v <- runProp2 sp p+ case v of+ Left e -> throwM e+ Right x -> return x++runProp :: Monad m => SourcePack -> Prop m a -> Prop m a+runProp sp p = do+ v <- lift $ runProp2 sp p+ case v of+ Left e -> throwM e+ Right x -> return x++instance FromProp m a => FromProp m (Maybe a) where fromProp = do v <- try fromProp case v of@@ -105,70 +136,73 @@ _ -> throwM e Right a -> return (Just a) -instance (MonadCatch m, FromProp m a) => FromProp m (Either String a) where+instance 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)+ SourcePack{..} <- ask+ v <- try fromProp+ return $ case v of+ Left e -> case fromException e of+ Just (PropException x) -> Left x+ Just NullException -> Left $ show (Keys pref) ++ " is null"+ _ -> Left $ show e+ Right a -> Right a 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+ foldM (go sp) [] $ sortBy g2 $ filter (isNum.fst) $ HM.toList $ TR.getMap source 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)-+-- | Supports for parsing `IO` value.+instance {-# OVERLAPPABLE #-} (MonadIO m, MonadIO n, FromProp (Either SomeException) a, FromProp m a) => FromProp m (n a) where+ fromProp = do+ sp <- ask+ a <- fromProp+ lift $ liftIO <$> buildIO sp a -buildIO :: (Show a, MonadIO m, FromProp (Either SomeException) a) => SourcePack -> a -> m (IO a)+buildIO :: (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)+ modifyMVar_ (qref sp) $ \f -> return $ \s ->+ let b = runProp1 sp {source = search2 s (pref sp), pref = pref sp} fromProp+ in case b of+ Left e -> Left $ show e+ Right v -> do+ vb <- v+ io <- f s+ return (swapMVar aref (fromMaybe a vb) >> 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+data SalakException = PropException String -- ^ Parse failed | NullException -- ^ Not found deriving Show -instance Exception PropException+instance Exception SalakException -instance (MonadThrow m, FromProp m a) => IsString (Prop m a) where+-- | Automatic convert literal string into an instance of `Prop` @m@ @a@.+instance FromProp m a => IsString (Prop m a) where fromString ks = do sp@SourcePack{..} <- askSalak- lift $ case search ks source of+ 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 :: Monad m => Prop m a notFound = do SourcePack{..} <- askSalak throwM NullException -err :: MonadThrow m => String -> Prop m a+err :: Monad m => String -> Prop m a err e = do SourcePack{..} <- askSalak throwM $ PropException $ show (Keys pref) ++ ":" ++ e -- | Prop operators. ----- Suppose we have following definition:+-- Suppose we have the following definition: -- -- > data Config = Config -- > { enabled :: Bool@@ -185,7 +219,7 @@ -- IO value will work right. infixl 5 .?= (.?=) :: f a -> a -> f a- -- | Parse or auto extract from a `Default` value+ -- | Parse or auto extract default value from a `Default` value -- -- > instance Default Config where -- > def = Config True (return LevelInfo)@@ -197,12 +231,12 @@ (.?:) :: Default b => f a -> (b -> a) -> f a (.?:) fa b = fa .?= b def --- | Support normal value+-- | Support for setting default 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+-- | Support for setting default `IO` value.+instance (MonadIO m, FromProp (Either SomeException) a) => PropOp (Prop m) (IO a) where (.?=) ma a = do sp <- askSalak v <- try ma@@ -210,21 +244,23 @@ Left (_ :: SomeException) -> liftIO a >>= buildIO sp Right o -> return o -instance MonadThrow m => HasValid (Prop m) where+instance Monad m => HasValid (Prop m) where invalid = err . toI18n -- | Parse primitive value from `Value`-readPrimitive :: MonadThrow m => (Value -> Either String a) -> Prop m a+readPrimitive :: Monad m => (Value -> Either String a) -> Prop m a readPrimitive f = do SourcePack{..} <- askSalak- let TR.Trie v _ = source- case f <$> (v >>= getVal) of+ vx <- g $ TR.getPrimitive source >>= getVal+ case f <$> vx of Just (Left e) -> err e Just (Right a) -> return a _ -> notFound+ where+ g = return -- | Parse enum value from `Text`-readEnum :: MonadThrow m => (Text -> Either String a) -> Prop m a+readEnum :: Monad m => (Text -> Either String a) -> Prop m a readEnum = readPrimitive . go where go f (VT t) = f t@@ -233,13 +269,13 @@ 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+instance {-# OVERLAPPABLE #-} (Monad 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 :: (Monad 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"@@ -261,7 +297,7 @@ 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+instance {-# OVERLAPPABLE #-} (Monad 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@@ -313,10 +349,10 @@ 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+instance (Monad m, FromProp m a) => FromProp m (Option a) where fromProp = Option <$> fromProp -instance MonadThrow m => FromProp m Bool where+instance Monad m => FromProp m Bool where fromProp = readPrimitive go where go (VB x) = Right x@@ -328,25 +364,25 @@ _ -> Left "string convert bool failed" go x = Left $ getType x ++ " cannot be bool" -instance MonadThrow m => FromProp m Text where+instance Monad 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+instance Monad m => FromProp m TL.Text where fromProp = TL.fromStrict <$> fromProp -instance MonadThrow m => FromProp m B.ByteString where+instance Monad m => FromProp m B.ByteString where fromProp = TB.encodeUtf8 <$> fromProp -instance MonadThrow m => FromProp m BL.ByteString where+instance Monad m => FromProp m BL.ByteString where fromProp = TBL.encodeUtf8 <$> fromProp -instance MonadThrow m => FromProp m String where+instance Monad m => FromProp m String where fromProp = T.unpack <$> fromProp -instance MonadThrow m => FromProp m Scientific where+instance Monad m => FromProp m Scientific where fromProp = readPrimitive go where go (VT x) = case readMaybe $ T.unpack x of@@ -355,91 +391,91 @@ go (VI x) = Right x go x = Left $ getType x ++ " cannot be number" -instance MonadThrow m => FromProp m Float where+instance Monad m => FromProp m Float where fromProp = toRealFloat <$> fromProp -instance MonadThrow m => FromProp m Double where+instance Monad m => FromProp m Double where fromProp = toRealFloat <$> fromProp -instance MonadThrow m => FromProp m Integer where+instance Monad m => FromProp m Integer where fromProp = toInteger <$> (fromProp :: Prop m Int) -instance MonadThrow m => FromProp m Int where+instance Monad m => FromProp m Int where fromProp = fromProp >>= toNum -instance MonadThrow m => FromProp m Int8 where+instance Monad m => FromProp m Int8 where fromProp = fromProp >>= toNum -instance MonadThrow m => FromProp m Int16 where+instance Monad m => FromProp m Int16 where fromProp = fromProp >>= toNum -instance MonadThrow m => FromProp m Int32 where+instance Monad m => FromProp m Int32 where fromProp = fromProp >>= toNum -instance MonadThrow m => FromProp m Int64 where+instance Monad m => FromProp m Int64 where fromProp = fromProp >>= toNum -instance MonadThrow m => FromProp m Word where+instance Monad m => FromProp m Word where fromProp = fromProp >>= toNum -instance MonadThrow m => FromProp m Word8 where+instance Monad m => FromProp m Word8 where fromProp = fromProp >>= toNum -instance MonadThrow m => FromProp m Word16 where+instance Monad m => FromProp m Word16 where fromProp = fromProp >>= toNum -instance MonadThrow m => FromProp m Word32 where+instance Monad m => FromProp m Word32 where fromProp = fromProp >>= toNum -instance MonadThrow m => FromProp m Word64 where+instance Monad m => FromProp m Word64 where fromProp = fromProp >>= toNum -instance MonadThrow m => FromProp m NominalDiffTime where+instance Monad m => FromProp m NominalDiffTime where fromProp = fromInteger <$> fromProp -instance MonadThrow m => FromProp m DiffTime where+instance Monad m => FromProp m DiffTime where fromProp = fromInteger <$> fromProp -instance (HasResolution a, MonadThrow m) => FromProp m (Fixed a) where+instance (HasResolution a, Monad m) => FromProp m (Fixed a) where fromProp = fromInteger <$> fromProp -toNum :: (MonadThrow m, Integral i, Bounded i) => Scientific -> Prop m i+toNum :: (Monad 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+instance Monad m => FromProp m CBool where fromProp = do b <- fromProp return $ if b then 1 else 0 -instance MonadThrow m => FromProp m CShort where+instance Monad m => FromProp m CShort where fromProp = CShort <$> fromProp -instance MonadThrow m => FromProp m CUShort where+instance Monad m => FromProp m CUShort where fromProp = CUShort <$> fromProp -instance MonadThrow m => FromProp m CInt where+instance Monad m => FromProp m CInt where fromProp = CInt <$> fromProp -instance MonadThrow m => FromProp m CUInt where+instance Monad m => FromProp m CUInt where fromProp = CUInt <$> fromProp -instance MonadThrow m => FromProp m CLong where+instance Monad m => FromProp m CLong where fromProp = CLong <$> fromProp -instance MonadThrow m => FromProp m CULong where+instance Monad m => FromProp m CULong where fromProp = CULong <$> fromProp -instance MonadThrow m => FromProp m CLLong where+instance Monad m => FromProp m CLLong where fromProp = CLLong <$> fromProp -instance MonadThrow m => FromProp m CULLong where+instance Monad m => FromProp m CULLong where fromProp = CULLong <$> fromProp -instance MonadThrow m => FromProp m CFloat where+instance Monad m => FromProp m CFloat where fromProp = CFloat <$> fromProp -instance MonadThrow m => FromProp m CDouble where+instance Monad m => FromProp m CDouble where fromProp = CDouble <$> fromProp
src/Salak/Internal/Source.hs view
@@ -30,16 +30,8 @@ , 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+diff = T.unionWith' go where go Nothing Nothing = Nothing go (Just (Vals a)) Nothing = if H.null a then Nothing else Just Add@@ -82,7 +74,7 @@ search2 = foldl search1 search1 :: Source -> Key -> Source-search1 (T.Trie _ m) key = fromMaybe T.empty $ HM.lookup key m+search1 m key = fromMaybe T.empty $ HM.lookup key $ T.getMap m fmt :: ModType -> Int -> String -> String -> String fmt m i s n = concat ['#' : show i, ' ' : show m, ' ' : s , ' ' : n]@@ -99,7 +91,7 @@ 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+setVal i v = T.update go where go Nothing = Just ([], modVals (Val i $ toVal v) emptyVals) go (Just (e,vs)) = Just (e, modVals (Val i $ toVal v) vs)
src/Salak/Trie.hs view
@@ -1,7 +1,44 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE NoImplicitPrelude #-}-module Salak.Trie where+-- |+-- Module: Salak.Internal+-- Copyright: 2019 Daniel YU+-- License: BSD3+-- Maintainer: leptonyu@gmail.com+-- Stability: experimental+-- Portability: portable+--+-- A data structure for manipulating properties.+--+module Salak.Trie(+ Trie+ , getPrimitive+ , getMap+ -- * Construction+ , empty+ , singleton+ -- * Basic interface+ , Salak.Trie.null+ , member+ , lookup+ , insert+ , modify+ , modifyF+ , modify'+ , update+ , alter+ , alterF+ -- * Lists+ , Salak.Trie.toList+ , fromList+ -- * Filter+ , filter+ -- * Combine+ , unionWith+ , unionWith'+ ) where +import Control.Applicative (pure, (<*>)) import Control.Monad (Monad (..)) import Data.Bool import Data.Eq@@ -12,30 +49,56 @@ import qualified Data.HashMap.Strict as HM import Data.List (concat, intercalate, map, reverse, (++)) import Data.Maybe+import Data.Traversable import Data.Tuple (uncurry) import Salak.Internal.Key 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) 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 +instance Traversable Trie where+ traverse f (Trie v m) = Trie <$> go v <*> traverse (traverse f) m+ where+ go (Just x) = Just <$> f x+ go _ = pure Nothing++-- | /O(1)/. A trie with a single element.+singleton :: v -> Trie v+singleton v = Trie (Just v) HM.empty++-- | /O(1)/. The empty trie.+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.+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. member :: Eq v => Keys -> Trie v -> Bool member k t = isJust (lookup k t) +-- | /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. lookup :: Eq v => Keys -> Trie v -> Maybe v lookup (Keys keys) = go keys where@@ -44,24 +107,33 @@ Just t -> go ks t _ -> Nothing +-- | /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. insert :: Eq v => Keys -> v -> Trie v -> Trie v insert ks v = alter (\_ -> Just v) ks +-- | /O(log m)/. The expression (`modify` k f trie) modifies the sub trie at k. 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 -+-- | /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' (Keys ks) f = foldr modify f ks +-- | /O(log m)/. The expression (`modifyF` k f trie) modifies the sub trie at k. 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 +-- | /O(1)/. The expression (update f trie) updates the primitive value in the trie.+update :: Eq v => (Maybe v -> Maybe v) -> Trie v -> Trie v+update f = alter f (Keys [])++-- | /O(n)/. The expression (update f ks trie) updates the primitive value of sub trie at ks. alter :: Eq v => (Maybe v -> Maybe v) -> Keys -> Trie v -> Trie v alter f (Keys keys) = go keys where@@ -69,6 +141,7 @@ 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 +-- | /O(n)/. The expression (update f ks trie) updates the primitive value of sub trie at ks. alterF :: (Functor f, Eq v) => (Maybe v -> f(Maybe v)) -> Keys -> Trie v -> f (Trie v) alterF f (Keys keys) = go keys where@@ -77,6 +150,7 @@ g2 ks t = g3 <$> go ks (fromMaybe empty t) g3 t = if t == empty then Nothing else Just t +-- | /O(n*m)/. Return a list of this tries's elements. The list is produced lazily. toList :: Trie v -> [(Keys, v)] toList = go [] where@@ -85,9 +159,12 @@ g2 p m = concat $ g3 p <$> HM.toList m g3 p (k,t) = go (k:p) t +-- | /O(n*m*log n)/. Construct a trie with the supplied mappings.+-- If the list contains duplicate mappings, the later mappings take precedence. 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. 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@@ -96,18 +173,18 @@ 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)-+-- | /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. 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+-- | /O(n+m)/. The union of two tries.+-- All the keys will be calculated by the provided function.+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 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)+ in HM.insert k (unionWith' f x1 x2)
test/Spec.hs view
@@ -9,7 +9,6 @@ module Main where -import Control.Monad.Catch import Control.Monad.Writer import Data.List (intercalate) import Data.Text (Text, pack, unpack)@@ -47,17 +46,17 @@ { hello :: IO Int } deriving Generic -instance (MonadThrow m, MonadIO m) => FromProp m Hello+instance MonadIO m => FromProp m Hello data Config = Config { level :: IO Int , world :: Maybe Bool } -instance (MonadIO m, MonadCatch m) => FromProp m Config where+instance MonadIO m => FromProp m Config where fromProp = Config <$> "level" .?= (return 1) <*> "world" -loadRandom :: MonadIO m => Text -> LoadSalakT m ()+loadRandom :: (MonadThrow m, MonadIO m) => Text -> LoadSalakT m () loadRandom key = loadList True (unpack key) go where go = do