diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/salak.cabal b/salak.cabal --- a/salak.cabal +++ b/salak.cabal @@ -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 diff --git a/src/Salak.hs b/src/Salak.hs --- a/src/Salak.hs +++ b/src/Salak.hs @@ -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} -- diff --git a/src/Salak/Internal.hs b/src/Salak/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Salak/Internal.hs @@ -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 + diff --git a/src/Salak/Internal/Key.hs b/src/Salak/Internal/Key.hs new file mode 100644 --- /dev/null +++ b/src/Salak/Internal/Key.hs @@ -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 diff --git a/src/Salak/Internal/Prop.hs b/src/Salak/Internal/Prop.hs new file mode 100644 --- /dev/null +++ b/src/Salak/Internal/Prop.hs @@ -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 + diff --git a/src/Salak/Internal/Source.hs b/src/Salak/Internal/Source.hs new file mode 100644 --- /dev/null +++ b/src/Salak/Internal/Source.hs @@ -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) diff --git a/src/Salak/Internal/Val.hs b/src/Salak/Internal/Val.hs new file mode 100644 --- /dev/null +++ b/src/Salak/Internal/Val.hs @@ -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 + + + + + + diff --git a/src/Salak/Load.hs b/src/Salak/Load.hs deleted file mode 100644 --- a/src/Salak/Load.hs +++ /dev/null @@ -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 - diff --git a/src/Salak/Load/Dynamic.hs b/src/Salak/Load/Dynamic.hs deleted file mode 100644 --- a/src/Salak/Load/Dynamic.hs +++ /dev/null @@ -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 diff --git a/src/Salak/Load/Env.hs b/src/Salak/Load/Env.hs deleted file mode 100644 --- a/src/Salak/Load/Env.hs +++ /dev/null @@ -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) diff --git a/src/Salak/Prop.hs b/src/Salak/Prop.hs deleted file mode 100644 --- a/src/Salak/Prop.hs +++ /dev/null @@ -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 - - - - - diff --git a/src/Salak/Trie.hs b/src/Salak/Trie.hs new file mode 100644 --- /dev/null +++ b/src/Salak/Trie.hs @@ -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) + diff --git a/src/Salak/Types.hs b/src/Salak/Types.hs deleted file mode 100644 --- a/src/Salak/Types.hs +++ /dev/null @@ -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' - - - diff --git a/src/Salak/Types/Selector.hs b/src/Salak/Types/Selector.hs deleted file mode 100644 --- a/src/Salak/Types/Selector.hs +++ /dev/null @@ -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 diff --git a/src/Salak/Types/Source.hs b/src/Salak/Types/Source.hs deleted file mode 100644 --- a/src/Salak/Types/Source.hs +++ /dev/null @@ -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} - - - - diff --git a/src/Salak/Types/Value.hs b/src/Salak/Types/Value.hs deleted file mode 100644 --- a/src/Salak/Types/Value.hs +++ /dev/null @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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