diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -75,7 +75,7 @@ <*> "pwd" <*> "ext" .?= 1 -main = runSalak def { configName = Just "salak", loadExt = loadByExt $ YAML :|: TOML } $ do +main = runSalakWith "salak" (YAML :|: TOML) $ do c :: Config <- require "test.config" lift $ print c ``` @@ -83,16 +83,16 @@ GHCi play ```Haskell λ> import Salak -λ> import Salak.Load.YAML -λ> import Salak.Load.TOML +λ> import Salak.Yaml +λ> import Salak.Toml λ> import Data.Menshen λ> :set -XTypeApplications λ> instance FromProp Config where fromProp = Config <$> "user" <*> "dir" <*> "ext" .?= 1 -λ> f = runSalak def { configName = Just "salak", loadExt = loadByExt $ YAML :|: TOML } +λ> f = runSalakWith "salak" (YAML :|: TOML) λ> f (require "") >>= print @Config Config {name = "daniel", dir = Just "ls", ext = 2} ``` - TODO: - 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.8 +version: 0.2.9 license: BSD3 license-file: LICENSE copyright: (c) 2018 Daniel YU @@ -27,6 +27,7 @@ Salak.Load.Dynamic Salak.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, @@ -57,6 +58,7 @@ Salak.Types.Value Paths_salak default-language: Haskell2010 + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures build-depends: QuickCheck >=2.12.6.1 && <2.14, attoparsec >=0.13.2.2 && <0.14, diff --git a/src/Salak.hs b/src/Salak.hs --- a/src/Salak.hs +++ b/src/Salak.hs @@ -18,49 +18,44 @@ -- * How to use this library -- $use - -- * Salak + -- * Salak Main Functions loadAndRunSalak , runSalak + , runSalakWith , PropConfig(..) - -- * Static Get Properties + -- * Load Salak + , LoadSalakT + , loadCommandLine + , ParseCommandLine + , defaultParseCommandLine + , loadEnv + , loadMock + -- ** Load Extensions + , ExtLoad + , loadByExt + , HasLoad(..) + , (:|:)(..) + -- * Run Salak + , RunSalakT + -- ** Get Static Properties , HasSourcePack(..) , fetch , require - -- * Dynamic Get Properties - , ReloadableSourcePack - , ReloadableSourcePackT + -- ** Dynamic Get Properties , ReloadResult(..) - , reloadable - , reloadAction - , fetchD + , exec , requireD - -- * Prop Parser + -- ** Parse properties + , SourcePack + , Priority + , Value(..) , Prop , FromProp(..) , FromEnumProp(..) , (.?=) , (.?:) - -- * SourcePack - , SourcePack - , SourcePackT - -- * Load configurations - , loadCommandLine - , loadEnv - , loadMock - -- ** Load By Extension - , ExtLoad - , loadByExt - , HasLoad(..) - , (:|:)(..) - -- * Other - , ParseCommandLine - , defaultParseCommandLine - , Priority - , Value(..) - , defaultLoadSalak ) where -import Control.Applicative import Control.Monad (unless) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Reader @@ -82,7 +77,7 @@ , searchCurrent :: Bool -- ^ Search current directory, default true , searchHome :: Bool -- ^ Search home directory, default false. , commandLine :: ParseCommandLine -- ^ How to parse commandline - , loadExt :: FilePath -> SourcePackT IO () + , loadExt :: FilePath -> LoadSalakT IO () } instance Default PropConfig where @@ -96,19 +91,19 @@ -- | Load and run salak `SourcePack` and fetch properties. loadAndRunSalak - :: Monad m - => SourcePackT m () -- ^ Load properties monad. - -> ReaderT SourcePack m a -- ^ Fetch properties monad. + :: MonadIO m + => LoadSalakT m () -- ^ Load properties monad. + -> RunSalakT m a -- ^ Fetch properties monad. -> m a loadAndRunSalak spm a = do - sp <- runSourcePackT spm + sp <- runLoadT Nothing spm let es = errs sp unless (null es) $ fail (head es) - runReaderT a sp + runT a sp -- | Load file by extension -type ExtLoad = (String, FilePath -> SourcePackT IO ()) +type ExtLoad = (String, FilePath -> LoadSalakT IO ()) class HasLoad a where loaders :: a -> [ExtLoad] @@ -119,15 +114,12 @@ instance (HasLoad a, HasLoad b) => HasLoad (a :|: b) where loaders (a :|: b) = loaders a ++ loaders b -loadByExt :: (HasLoad a, MonadIO m) => a -> FilePath -> SourcePackT m () +loadByExt :: (HasLoad a, MonadIO m) => a -> FilePath -> LoadSalakT m () loadByExt xs f = mapM_ go (loaders xs) where go (ext, ly) = tryLoadFile (jump . ly) $ f ++ "." ++ ext -jump :: MonadIO m => StateT SourcePack IO a -> StateT SourcePack m () -jump a = get >>= lift . liftIO . execStateT a >>= put - --- | Default load salak. +-- | Default run salak. -- All these configuration sources has orders, from highest priority to lowest priority: -- -- > 1. loadCommandLine @@ -138,7 +130,7 @@ -- > 6. load file from home folder if enabled -- > 7. file extension matching, support yaml or toml or any other loader. -- -runSalak :: MonadIO m => PropConfig -> ReaderT SourcePack m a -> m a +runSalak :: MonadIO m => PropConfig -> RunSalakT m a -> m a runSalak PropConfig{..} = loadAndRunSalak $ do loadCommandLine commandLine loadEnv @@ -152,31 +144,20 @@ ifS _ _ = return Nothing loadConf n mf = mf >>= mapM_ (jump . loadExt . ( n)) -{-# DEPRECATED defaultLoadSalak "use runSalak instead" #-} -defaultLoadSalak :: MonadIO m => PropConfig -> ReaderT SourcePack m a -> m a -defaultLoadSalak = runSalak - - - -- loadC ffa n = (mapM_ . mapM_) g - -- cf <- fetch configDirKey - -- where - -- go ck n = do - -- case ck of - -- Left _ -> return () - -- Right d -> defaultLoadByExt $ d n - -- c <- liftIO getCurrentDirectory - -- when searchCurrent $ defaultLoadByExt $ c n - -- h <- liftIO getHomeDirectory - -- when searchHome $ defaultLoadByExt $ h n +-- | 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 = runSalak def { configName = Just name, loadExt = loadByExt a} +-- | Monad that can fetch properties. class Monad m => HasSourcePack m where askSourcePack :: m SourcePack -instance Monad m => HasSourcePack (ReaderT SourcePack m) where - askSourcePack = ask -instance Monad m => HasSourcePack (StateT SourcePack m) where - askSourcePack = get +instance MonadIO m => HasSourcePack (RunSalakT m) where + askSourcePack = askRSP +instance Monad m => HasSourcePack (LoadSalakT m) where + askSourcePack = LoadSalakT get + -- | Try fetch properties from `SourcePack` fetch :: (HasSourcePack m, FromProp a) @@ -189,43 +170,14 @@ :: (HasSourcePack m, FromProp a) => Text -- ^ Properties key -> m a -require k = do - x <- fetch k - case x of - Left e -> fail e - Right v -> return v +require k = fetch k >>= either error return -- | Fetch dynamic properties from `SourcePack`, or throw fail requireD :: (MonadIO m, FromProp a) => Text -- ^ Properties key - -> ReloadableSourcePackT m (IO a) -requireD k = do - x <- fetchD k - case x of - Left e -> fail e - Right v -> return v - --- | Try fetch dynamic properties from `SourcePack` -fetchD - :: (MonadIO m, FromProp a) - => Text -- ^ Properties key - -> ReloadableSourcePackT m (Either String (IO a)) -fetchD = search' - --- | Lift to reloadable environment for dynamic properties. -reloadable :: (MonadIO m, HasSourcePack m) => ReloadableSourcePackT m a -> m a -reloadable f = askSourcePack >>= runReloadable f - --- | 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 + -> RunSalakT m (IO a) +requireD k = search' k >>= either error return -- $use -- @@ -277,18 +229,18 @@ -- > <*> "pwd" -- > <*> "ext" .?= 1 -- > --- > main = runSalak def { configName = Just "salak", loadExt = loadByExt $ YAML :|: TOML } $ do +-- > main = runSalakWith "salak" (YAML :|: TOML) $ do -- > c :: Config <- require "test.config" -- > lift $ print c -- -- GHCi play -- -- > λ> import Salak --- > λ> import Salak.Load.YAML --- > λ> import Salak.Load.TOML +-- > λ> import Salak.YAML +-- > λ> import Salak.TOML -- > λ> :set -XTypeApplications -- > λ> instance FromProp Config where fromProp = Config <$> "user" <*> "dir" <*> "ext" .?= 1 --- > λ> f = runSalak def { configName = Just "salak", loadExt = loadByExt $ YAML :|: TOML } +-- > λ> f = runSalakWith "salak" (YAML :|: TOML) -- > λ> f (require "") >>= print @Config -- > Config {name = "daniel", dir = Just "ls", ext = 2} -- diff --git a/src/Salak/Load.hs b/src/Salak/Load.hs --- a/src/Salak/Load.hs +++ b/src/Salak/Load.hs @@ -7,28 +7,30 @@ -- 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( - -- * Reload - Reload(..) - , defReload -- * SourcePack - , Source + Source , SourcePack - , SourcePackT - , addErr' + , addErr + , newVStr -- * Selector , Selector(..) , simpleSelectors -- * Source + , emptySource + , nullSource , insertSource , updateSources , updateSource -- * Load , tryLoadFile , loadFile + , loading ) 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 --- a/src/Salak/Load/Dynamic.hs +++ b/src/Salak/Load/Dynamic.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} module Salak.Load.Dynamic where import Control.Concurrent.MVar @@ -13,8 +14,8 @@ import Salak.Types.Source data ReloadResult = ReloadResult - { isError :: Bool - , msg :: [String] + { isError :: Bool -- ^ msg stands for properties changing record if true, otherwise msg means reload error. + , msg :: [String] -- ^ message log } deriving (Eq, Show) -- | Reloadable SourcePack @@ -42,17 +43,26 @@ 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} -type ReloadableSourcePackT = StateT ReloadableSourcePack +-- | RunSalak Monad Transfer +newtype RunSalakT m a = RunSalakT { unRun :: StateT ReloadableSourcePack m a } + deriving (Functor, Applicative, Monad, MonadTrans) -search' :: (MonadIO m, FromProp a) => Text -> ReloadableSourcePackT m (Either String (IO a)) -search' k = do - ReloadableSourcePack{..} <- get - sp <- liftIO $ takeMVar sourcePack +instance MonadIO m => MonadIO (RunSalakT m) where + liftIO = lift . liftIO + +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 - put (ReloadableSourcePack sourcePack (reloadAll . go v)) + modify $ \rsp -> rsp { reloadAll = reloadAll rsp . go v} return $ Right $ readMVar v where go x f sp = do @@ -61,13 +71,14 @@ Left e -> return (as, e:es) Right r -> return (putMVar x r:as, es) -reloadAction :: Monad m => ReloadableSourcePackT m (IO ReloadResult) -reloadAction = do +reloadAction :: Monad m => RunSalakT m (IO ReloadResult) +reloadAction = RunSalakT $ do ReloadableSourcePack{..} <- get return $ reloadAll $ \_ -> return ([], []) -runReloadable :: MonadIO m => ReloadableSourcePackT m a -> SourcePack -> m a -runReloadable r sp = reloadableSourcePack sp >>= evalStateT r - - +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 --- a/src/Salak/Load/Env.hs +++ b/src/Salak/Load/Env.hs @@ -2,34 +2,37 @@ module Salak.Load.Env where import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.State import Data.Maybe import qualified Data.Text as T import Salak.Types import Salak.Types.Value import System.Environment -loadEnv :: MonadIO m => SourcePackT m () +-- | Load environment variables into `SourcePack` +loadEnv :: MonadIO m => LoadSalakT m () loadEnv = do args <- liftIO getEnvironment - modify $ load (emptyReload "environment") args go + loading "environment" args go where - go p (k,v) = (g2 k, VStr p $ T.pack v) + 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, \p -> VStr p $ T.pack b) + (a,'=':b) -> Just (T.pack a, newVStr (T.pack b)) _ -> Nothing go _ = Nothing -loadCommandLine :: MonadIO m => ParseCommandLine -> SourcePackT m () +-- | Load command line arguments into `SourcePack` +loadCommandLine :: MonadIO m => ParseCommandLine -> LoadSalakT m () loadCommandLine pcl = do args <- liftIO $ getArgs >>= pcl - modify $ load (emptyReload "commandline") args go + loading "commandline" args go where - go i (k,fv) = (k, fv i) + go i (k,fv) = return (k, fv i) diff --git a/src/Salak/Prop.hs b/src/Salak/Prop.hs --- a/src/Salak/Prop.hs +++ b/src/Salak/Prop.hs @@ -14,6 +14,7 @@ import Control.Applicative import Control.Monad.Reader +import Data.Default import Data.Int import qualified Data.Map.Strict as M import Data.Menshen @@ -56,16 +57,41 @@ (N s ) >>= _ = N s (F s e) >>= _ = F s e -newtype PropT m a = Prop { unProp :: ReaderT SourcePack m a } +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 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 = Prop ask - local f (Prop a) = Prop (local f a) + ask = currSP <$> Prop ask + local f (Prop a) = Prop (local (\sp -> sp { currSP = f (currSP sp) }) a) instance HasValid Prop where invalid = err . toI18n @@ -115,8 +141,8 @@ instance FromProp a => FromProp (Maybe a) where fromProp = do - sp <- ask - lift $ case runProp sp (fromProp :: Prop a) of + 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 @@ -128,22 +154,35 @@ return (reverse as) where go sp' as (ix,s) = do - a <- lift $ runProp sp' { prefix = ix : prefix sp', source = s} fromProp + so <- askSub $ \_ -> sp' { prefix = ix : prefix sp', source = s} + a <- lift $ runProp so fromProp return (a:as) instance {-# OVERLAPPABLE #-} FromEnumProp a => FromProp a where fromProp = readPrimitive $ \ss v -> case v of - VStr _ s -> case fromEnumProp $ T.toLower s of - Left e -> F ss e - Right r -> O ss r + 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 (\_ -> 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 + SourcePack{..} <- ask case getQ (value source) of - Just v -> lift $ f prefix v + Just v -> evalV prefix v >>= lift . f prefix _ -> lift $ N prefix class FromEnumProp a where @@ -159,14 +198,19 @@ readSelect :: FromProp a => Text -> Prop a readSelect key = case selectors key of Left e -> err e - Right s -> local (\sp -> foldl select sp s) fromProp + 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 = case runProp sp (readSelect key) of - O _ x -> Right x - N s -> Left $ "key " ++ toKey s ++ " not found" - F s e -> Left $ "key " ++ toKey s ++ " : " ++ e +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 @@ -177,7 +221,7 @@ "false" -> O s False "no" -> O s False _ -> F s "string convert bool failed" - go s x = F s $ getType x ++ " cannot be bool" + go s x = F s $ getType x ++ " cannot be bool" instance FromProp Text where fromProp = readPrimitive go diff --git a/src/Salak/Types.hs b/src/Salak/Types.hs --- a/src/Salak/Types.hs +++ b/src/Salak/Types.hs @@ -1,12 +1,14 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeSynonymInstances #-} module Salak.Types 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 @@ -22,13 +24,14 @@ instance Show Reload where show (Reload s _) = T.unpack s -defReload :: String -> SourcePackT IO () -> Reload -defReload s spt = Reload (T.pack s) (\i -> go <$> execStateT spt emptySourcePack {packId = i}) +defReload :: String -> LoadSalakT IO () -> Reload +defReload s spt = Reload (T.pack s) (\i -> go <$> runLoadT (Just i) spt) where go SourcePack{..} = (errs, source) emptyReload s = defReload s (return ()) +-- | Source package, used to store all properties. data SourcePack = SourcePack { prefix :: [Selector] , packId :: Int @@ -45,37 +48,68 @@ select :: SourcePack -> Selector -> SourcePack select sp n = sp { source = selectSource n (source sp), prefix = n : prefix sp} -addErr' :: String -> SourcePack -> SourcePack -addErr' e sp = sp {errs = e : errs sp} +addErr :: Monad m => String -> LoadSalakT m () +addErr e = LoadSalakT $ get >>= (\sp -> return sp {errs = e : errs sp}) >>= put -loadFile :: Reload -> SourcePack -> (Priority -> Source -> Writer [String] Source) -> SourcePack -loadFile name SourcePack{..} go = - let (s', e) = runWriter $ go packId source - in SourcePack prefix (packId+1) s' (MI.insert packId name reEnv) (errs ++ e) +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) -tryLoadFile :: MonadIO m => (FilePath -> SourcePackT m ()) -> FilePath -> SourcePackT m () +loadFile + :: MonadIO m + => String + -> (Priority -> Source -> WriterT [String] IO Source) + -> LoadSalakT m () +loadFile file go = loadInternal (defReload file $ loadFile 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 - :: Foldable f - => Reload +loading + :: (Foldable f, Monad m) + => String -> f a - -> (Priority -> a -> (Text, Value)) - -> SourcePack - -> SourcePack -load name fa f sp = loadFile name sp $ \i s -> foldl (go i) (return s) fa + -> (Priority -> a -> m (Text, Value)) + -> LoadSalakT m () +loading name fa f = loadInternal (emptyReload name) $ \i s -> foldM (go i) s fa where - go i s a = s >>= \s' -> let (k,v) = f i a in insert k v s' + go i s a = do + (k, v) <- lift $ f i a + insert k v s -loadMock :: Monad m => [(Text, Text)] -> SourcePackT m () -loadMock fs = modify $ load (emptyReload "Mock") fs (\i (k,v) -> (k, VStr i v)) +-- | Put key value pairs into `SourcePack` +loadMock :: Monad m => [(Text, Text)] -> LoadSalakT m () +loadMock fs = loading "Mock" fs (\i (k,v) -> return (k, newVStr v i)) -type SourcePackT = StateT SourcePack +runLoadT :: Monad m => Maybe Priority -> LoadSalakT m a -> m SourcePack +runLoadT i (LoadSalakT ac) = execStateT ac emptySourcePack { packId = fromMaybe 0 i } -runSourcePackT :: Monad m => SourcePackT m a -> m SourcePack -runSourcePackT ac = execStateT ac emptySourcePack +-- | 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 --- a/src/Salak/Types/Selector.hs +++ b/src/Salak/Types/Selector.hs @@ -39,21 +39,24 @@ exprs :: Parser [Selector] exprs = concat <$> ( (expr <|> return []) `sepBy` char '.') --- xx --- xx.xx --- xx.xx[0] --- xx.xx[1].xx -expr :: Parser [Selector] -expr = do - name <- T.pack <$> do +sName :: Parser Selector +sName = SStr . T.pack <$> do a <- choice [letter, digit] b <- many' (choice [letter, digit, char '-', char '_']) return (a:b) - ds <- many' (paren decimal) - return $ SStr name : (SNum <$> ds) + +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 --- a/src/Salak/Types/Source.hs +++ b/src/Salak/Types/Source.hs @@ -72,7 +72,7 @@ g2 k (1, a) = (1, a >>= \a' -> replace' (k:ss) i emptySource a') g2 _ (_, a) = (2 :: Int, a) -insert :: T.Text -> Value -> Source -> Writer [String] Source +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) diff --git a/src/Salak/Types/Value.hs b/src/Salak/Types/Value.hs --- a/src/Salak/Types/Value.hs +++ b/src/Salak/Types/Value.hs @@ -1,15 +1,25 @@ +{-# 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 @@ -24,8 +34,34 @@ 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)) @@ -55,11 +91,12 @@ replaceQ :: Monad m => String -> Priority -> QV -> QV -> WriterT [String] m QV replaceQ s i nq q = do - let (a,b) = Q.partition ((==i) . getPriority) q + 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 + if a == nq' then return q - else case getQ nq of + else case getQ nq' of Just v -> do go [(if Q.null a then "Add " else "Mod ") ++ s] return $ Q.insert v b diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -6,7 +6,6 @@ module Main where -import Control.Monad.Reader import Control.Monad.Writer import Data.Either import Data.List (intercalate) @@ -18,6 +17,7 @@ import Salak.Types import Salak.Types.Selector import Salak.Types.Source +import Salak.Types.Value import Test.Hspec import Test.QuickCheck @@ -69,6 +69,17 @@ toKey (reverse $ SStr "x" : (SNum <$> [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"]] context "source" $ do it "normal" $ do sizeSource emptySource `shouldBe` 0 @@ -79,7 +90,7 @@ it "normal - 3" $ do let (s2,e2) = runWriter $ insert "1" (VStr 0 "world") emptySource sizeSource s2 `shouldBe` 1 - length e2 `shouldBe` 00 + length e2 `shouldBe` 0 it "normal - 4" $ do let (s3,e3) = runWriter $ insert "a.b" (VStr 0 "world") emptySource print s3 @@ -87,26 +98,41 @@ 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 <- runSourcePackT $ loadMock + sp <- runLoadT Nothing $ loadMock [ ("name", "Daniel") , ("age", "18") , ("male", "yes") @@ -115,6 +141,25 @@ 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 (loadMock 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 (loadMock xs) (require "a") :: IO Text + x `shouldThrow` anyErrorCall