diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,47 @@ # salak -[![Hackage](https://img.shields.io/badge/hackage-v0.2.2-orange.svg)](https://hackage.haskell.org/package/salak) +[![Hackage](https://img.shields.io/hackage/v/salak.svg)](https://hackage.haskell.org/package/salak) +[![stackage LTS package](http://stackage.org/package/salak/badge/lts)](http://stackage.org/lts/package/salak) +[![stackage Nightly package](http://stackage.org/package/salak/badge/nightly)](http://stackage.org/nightly/package/salak) [![Build Status](https://travis-ci.org/leptonyu/salak.svg?branch=master)](https://travis-ci.org/leptonyu/salak) Configuration Loader for Production in Haskell. + +This library default a standard configuration load process. It can load properties from `CommandLine`, `Environment`, +`JSON value` and `Yaml` files. They all load to the same format `SourcePack`. Earler property source has higher order +to load property. For example: + +``` +CommandLine: --package.a.enabled=true +Environment: PACKAGE_A_ENABLED: false + +lookup "package.a.enabled" properties => Just True +``` + +`CommandLine` has higher order then `Environment`, for the former load properties earler then later. + +Usage: + +```Haskell +data Config = Config + { name :: Text + , dir :: Maybe Text + , ext :: Int + } deriving (Eq, Show) + +instance FromProp Config where + fromProp = Config + <$> "user" + <*> "pwd" + <*> "ext" .?= 1 + +main = do + c :: Config <- defaultLoadSalak def $ require "" + print c +``` + +``` +λ> c +Config {name = "daniel", dir = Nothing, ext = 1} +``` 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.3 +version: 0.2.4 license: BSD3 license-file: LICENSE copyright: (c) 2018 Daniel YU @@ -18,9 +18,15 @@ library exposed-modules: + Salak Data.Salak hs-source-dirs: src other-modules: + Salak.Types + Salak.Env + Salak.Json + Salak.Prop + Salak.Dynamic Data.Salak.Types Data.Salak.Environment Data.Salak.CommandLine @@ -32,11 +38,15 @@ ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures build-depends: aeson <1.5, + attoparsec <0.14, base >=4.7 && <5, + containers <0.7, + data-default <0.8, directory <1.4, filepath <1.5, menshen <0.1, mtl <2.3, + pqueue <1.5, scientific <0.4, stm <2.6, text <1.3, @@ -58,18 +68,28 @@ Data.Salak.Operation Data.Salak.Types Data.Salak.Yaml + Salak + Salak.Dynamic + Salak.Env + Salak.Json + Salak.Prop + Salak.Types Paths_salak default-language: Haskell2010 ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures build-depends: QuickCheck <2.13, aeson <1.5, + attoparsec <0.14, base >=4.7 && <5, + containers <0.7, + data-default <0.8, directory <1.4, filepath <1.5, hspec ==2.*, menshen <0.1, mtl <2.3, + pqueue <1.5, scientific <0.4, stm <2.6, text <1.3, diff --git a/src/Data/Salak/Types.hs b/src/Data/Salak/Types.hs --- a/src/Data/Salak/Types.hs +++ b/src/Data/Salak/Types.hs @@ -123,6 +123,7 @@ -- | Return of `FromProperties` type Return = Either ErrResult + data ErrResult = EmptyKey Text | Fail String deriving Show instance HasValid Return where diff --git a/src/Salak.hs b/src/Salak.hs new file mode 100644 --- /dev/null +++ b/src/Salak.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +-- | +-- Module: Salak +-- Copyright: (c) 2019 Daniel YU +-- License: BSD3 +-- Maintainer: leptonyu@gmail.com +-- Stability: experimental +-- Portability: portable +-- +-- Configuration Loader for Production in Haskell. +-- +module Salak( + -- * How to use this library + -- $use + + -- * Source + Selector + , SourcePack + , SourcePackT + , Reload(..) + , load + , loadJSON + , loadYaml + , loadEnv + -- * Salak + , defaultLoadSalak + , loadSalak + , PropConfig(..) + , HasSourcePack(..) + , fetch + , require + -- * Utilities + , ReloadableSourcePack + , runReloadable + , Prop + , FromProp(..) + , PResult(..) + , readPrimitive + , readSelect + , err + ) where + +import Control.Monad (unless) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Reader +import Data.Default +import Data.Text (Text) +import Salak.Dynamic +import Salak.Env +import Salak.Json +import Salak.Prop +import Salak.Types + +data PropConfig = PropConfig + { configFileKey :: Maybe String + , commandLine :: ParseCommandLine + } + +instance Default PropConfig where + def = PropConfig Nothing defaultParseCommandLine + +loadSalak :: Monad m => ReaderT SourcePack m a -> SourcePackT m () -> m a +loadSalak a spm = do + (es, sp) <- runSourcePackT spm + unless (null es) $ do + fail (head es) + runReaderT a sp + +defaultLoadSalak :: MonadIO m => PropConfig -> ReaderT SourcePack m a -> m a +defaultLoadSalak PropConfig{..} a = loadSalak a $ do + loadCommandLine commandLine + loadEnv + go configFileKey + where + go (Just file) = loadYaml file + go _ = return () + +class Monad m => HasSourcePack m where + askSourcePack :: m SourcePack + +fetch :: (HasSourcePack m, FromProp a) => Text -> m (Either String a) +fetch key = askSourcePack >>= return . search key + +require :: (HasSourcePack m, FromProp a) => Text -> m a +require k = do + x <- fetch k + case x of + Left e -> fail e + Right v -> return v + +instance Monad m => HasSourcePack (ReaderT SourcePack m) where + askSourcePack = ask + +-- $use +-- +-- | This library default a standard configuration load process. It can load properties from `CommandLine`, `Environment`, +-- `JSON value` and `Yaml` files. They all load to the same format `SourcePack`. Earler property source has higher order +-- to load property. For example: +-- +-- > CommandLine: --package.a.enabled=true +-- > Environment: PACKAGE_A_ENABLED: false +-- +-- > lookup "package.a.enabled" properties => Just True +-- +-- `CommandLine` has higher order then `Environment`, for the former load properties earler then later. +-- +-- Usage: +-- +-- > data Config = Config +-- > { name :: Text +-- > , dir :: Maybe Text +-- > , ext :: Int +-- > } deriving (Eq, Show) +-- > +-- > instance FromProp Config where +-- > fromProp = Config +-- > <$> "user" +-- > <*> "pwd" +-- > <*> "ext" .?= 1 +-- +-- > main = do +-- > c :: Config <- defaultLoadSalak def $ require "" +-- > print c +-- +-- > λ> c +-- > Config {name = "daniel", dir = Nothing, ext = 1} diff --git a/src/Salak/Dynamic.hs b/src/Salak/Dynamic.hs new file mode 100644 --- /dev/null +++ b/src/Salak/Dynamic.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +module Salak.Dynamic where + +import Control.Concurrent.MVar +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.State +import qualified Data.IntMap.Strict as MI +import Data.Text (Text) +import Salak.Prop +import Salak.Types + +data ReloadableSourcePack = ReloadableSourcePack + { sourcePack :: MVar SourcePack + , reloadAll :: (SourcePack -> IO ([IO ()], [String])) -> IO (Bool, [String]) + } + +reloadableSourcePack :: MonadIO m => SourcePack -> m ReloadableSourcePack +reloadableSourcePack sp = do + msp <- liftIO $ newMVar sp + return $ ReloadableSourcePack msp (reloadAll' msp) + where + reloadAll' v f = do + sp'@(SourcePack _ _ _ it) <- readMVar v + as <- filter (not . nullSource . snd) <$> (mapM go $ MI.toList it) + if null as + then return (True, []) + else do + let (es, sp'') = extractErr' $ foldl g2 sp' as + (ac, es') <- f sp'' + if null es' + then putMVar v sp'' >> sequence_ ac >> return (True, es) + else return (False, es') + go (i, Reload _ f) = (i,) <$> f i + g2 (SourcePack ss i s it) (x,s') = SourcePack ss i (replace x s' s) it + +type ReloadableSourcePackT = StateT ReloadableSourcePack + +search' :: (MonadIO m, FromProp a) => Text -> ReloadableSourcePackT m (Either String (IO a)) +search' k = do + ReloadableSourcePack{..} <- get + sp <- liftIO $ takeMVar sourcePack + case search k sp of + Left e -> return (Left e) + Right r -> do + v <- liftIO $ newMVar r + put (ReloadableSourcePack sourcePack (reloadAll . 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 (putMVar x r:as, es) + +runReloadable :: MonadIO m => SourcePack -> ReloadableSourcePackT m a -> m (a, IO (Bool, [String])) +runReloadable sp r = do + rsp <- reloadableSourcePack sp + (a, ReloadableSourcePack{..}) <- runStateT r rsp + return (a, reloadAll (\_ -> return ([],[]))) + + + diff --git a/src/Salak/Env.hs b/src/Salak/Env.hs new file mode 100644 --- /dev/null +++ b/src/Salak/Env.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} +module Salak.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 System.Environment + +loadEnv :: MonadIO m => SourcePackT m () +loadEnv = do + args <- liftIO getEnvironment + modify $ load (emptyReload "environment") args go + where + go p (k,v) = (g2 k, VStr p $ T.pack v) + g2 = T.toLower . T.pack . map (\c -> if c == '_' then '.' else c) + +type ParseCommandLine = [String] -> IO [(T.Text,Priority -> Value)] + +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) + _ -> Nothing + go _ = Nothing + +loadCommandLine :: MonadIO m => ParseCommandLine -> SourcePackT m () +loadCommandLine pcl = do + args <- liftIO $ getArgs >>= pcl + modify $ load (emptyReload "commandline") args go + where + go i (k,fv) = (k, fv i) diff --git a/src/Salak/Json.hs b/src/Salak/Json.hs new file mode 100644 --- /dev/null +++ b/src/Salak/Json.hs @@ -0,0 +1,32 @@ +module Salak.Json where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.State +import qualified Data.Aeson as A +import qualified Data.HashMap.Strict as HM +import qualified Data.IntMap.Strict as MI +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.Text (pack) +import qualified Data.Vector as V +import qualified Data.Yaml as Y +import Salak.Types + +loadJSON :: Reload -> A.Value -> SourcePack -> SourcePack +loadJSON name v sp = loadFile name sp $ go v + where + go (A.Object m) i s = foldl (g2 i) s $ HM.toList m + go (A.Array m) i s = foldl (g3 i) s $ zipWith (,) [0..] $ V.toList m + go (A.String m) i s = insert' [] (VStr i m) s + go (A.Number m) i s = insert' [] (VNum i m) s + go (A.Bool m) i s = insert' [] (VBool i m) s + go A.Null _ s = s + g2 i (Source es p is ts) (k,v') = let s' = go v' i (fromMaybe emptySource $ M.lookup k ts) in Source es p is $ M.insert k s' ts + g3 i (Source es p is ts) (k,v') = let s' = go v' i (fromMaybe emptySource $ MI.lookup k is) in Source es p (MI.insert k s' is) ts + +loadYaml :: MonadIO m => FilePath -> SourcePackT m () +loadYaml file = do + v <- liftIO $ Y.decodeFileEither file + modify $ \sp -> case v of + Left e -> addErr' (show e) sp + Right a -> loadJSON (emptyReload $ pack file) a sp diff --git a/src/Salak/Prop.hs b/src/Salak/Prop.hs new file mode 100644 --- /dev/null +++ b/src/Salak/Prop.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Salak.Prop where + +import Control.Applicative +import Control.Monad.Reader +import Data.Int +import qualified Data.IntMap.Strict as MI +import qualified Data.PQueue.Min as Q +import Data.Scientific +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Word +import GHC.Exts +import GHC.Generics hiding (Selector) +import qualified GHC.Generics as G +import Salak.Types +import Text.Read (readMaybe) + +data PResult a + = O [Selector] a + | N [Selector] + | F [Selector] String + 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 + +type Prop a = ReaderT SourcePack PResult a + +infixl 5 .?= +(.?=) :: Prop a -> a -> Prop a +(.?=) a b = a <|> pure b + +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 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 (STxt $ 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 + sp <- ask + lift $ case runReaderT (fromProp :: Prop a) sp of + O s a -> O s $ Just a + N s -> O s Nothing + F s e -> F s e + +instance {-# OVERLAPPABLE #-} FromProp a => FromProp [a] where + fromProp = do + SourcePack ss i (Source _ _ is _) it <- ask + foldM (go ss i it) [] $ MI.toList is + where + go xx x xt as (ix,s) = do + a <- lift $ runReaderT fromProp (SourcePack (SNum ix:xx) x s xt) + return (a:as) + +-- | ReadPrimitive value +readPrimitive :: ([Selector] -> Value -> PResult a) -> Prop a +readPrimitive f = do + SourcePack ss _ (Source _ q _ _) _ <- ask + case Q.getMin q of + Just v -> lift $ f ss v + _ -> lift $ N ss + +err :: String -> Prop a +err e = do + SourcePack ss _ _ _ <- ask + lift $ F ss e + +-- | Parse value +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 + +search :: FromProp a => Text -> SourcePack -> Either String a +search key sp = case runReaderT (readSelect key) sp of + O _ x -> Right x + N s -> Left $ "key " ++ toKey s ++ " not found" + 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 (VNum _ _) = F s "number cannot be bool" + 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" + +instance FromProp Text where + fromProp = readPrimitive go + where + go s (VStr _ x) = O s x + go s (VBool _ _) = F s "boolean cannot be string" + go s (VNum _ _) = F s "number cannot be string" + +instance FromProp TL.Text where + fromProp = TL.fromStrict <$> 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 (VBool _ _) = F s "boolean cannot be number" + +instance FromProp Float where + fromProp = toRealFloat <$> fromProp + +instance FromProp Double where + fromProp = toRealFloat <$> fromProp + +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 + +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" diff --git a/src/Salak/Types.hs b/src/Salak/Types.hs new file mode 100644 --- /dev/null +++ b/src/Salak/Types.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Salak.Types where + +import Control.Applicative ((<|>)) +import Control.Monad.State +import Data.Attoparsec.Text +import qualified Data.IntMap.Strict as MI +import Data.List (intercalate) +import qualified Data.Map.Strict as M +import Data.Maybe +import qualified Data.PQueue.Min as Q +import Data.Scientific (Scientific) +import Data.Text (Text) +import qualified Data.Text as T + +type Priority = Int + +data Value + = VStr Priority !Text + | VNum Priority !Scientific + | VBool Priority !Bool + deriving (Eq, Show, Ord) + +type QV = Q.MinQueue Value + +getPriority :: Value -> Priority +getPriority (VStr p _) = p +getPriority (VNum p _) = p +getPriority (VBool p _) = p + +data Reload = Reload + { sourceName :: Text + , reload :: Priority -> IO Source + } + +instance Show Reload where + show (Reload s _) = T.unpack s + +emptyReload :: Text -> Reload +emptyReload s = Reload s (\_ -> return emptySource) + +type PriorityEnv = MI.IntMap Reload + +nullSource :: Source -> Bool +nullSource (Source _ q is ts) = Q.null q && MI.null is && M.null ts + +getQ :: Source -> QV +getQ (Source _ q _ _) = q + +replaceQ :: String -> Priority -> QV -> QV -> ([String], QV) +replaceQ s i nq q = + let (a,b) = Q.partition ((==i) . getPriority) q + in if a == nq then ([], q) else case Q.getMin nq of + Just v -> ([ (if Q.null a then "Add " else "Mod ") ++ s], Q.insert v b) + _ -> (if Q.null a then [] else ["Del " ++ s], b) + +data Source' v = Source [String] v (MI.IntMap (Source' v)) (M.Map Text (Source' v)) deriving (Eq, Functor) + +type Source = Source' QV + +instance Show Source where + show = unlines . go "" + where + go p (Source _ q is ts) = (if Q.null q then [] else [ p ++ "=" ++ show q ]) + ++ concat ((\(k,v) -> go (p ++ "[" ++ show k ++ "]") v) <$> MI.toList is) + ++ concat ((\(k,v) -> go (if null p then T.unpack k else p ++ "." ++ T.unpack k) v) <$> M.toList ts) + +emptySource :: Source +emptySource = Source [] Q.empty MI.empty M.empty + +instance Foldable Source' where + foldr f b s@(Source _ _ is ts) = foldr go (foldr go (go s b) is) ts + where + go (Source _ q _ _) = f q + +foldSource :: (Value -> b -> b) -> b -> Source -> b +foldSource f = foldr (\q b -> fromMaybe b $ (\a -> f a b) <$> Q.getMin q) + +sizeSouce :: Source -> Int +sizeSouce = foldSource (\_ -> (+1)) 0 + +extractErr :: Source -> ([String], Source) +extractErr (Source es q is ts) = + let (ise, is') = MI.mapAccum go es is + (tse, ts') = M.mapAccum go ise ts + in (tse, Source [] q is' ts') + where + go e s = let (e', s') = extractErr s in (e ++ e', s') + +replace a b c = replace' [] a b c + +replace' :: [Selector] -> Priority -> Source -> Source -> Source +replace' ss i (Source _ nq nis nts) (Source es q is ts) = + let (ms, q') = replaceQ (toKey ss) i nq q + (isa,isb) = MI.partition nullSource $ MI.mapWithKey (g2.SNum) $ MI.unionWithKey (go.SNum) (f 0 nis) (f 1 is) + (tsa,tsb) = M.partition nullSource $ M.mapWithKey (g2.STxt) $ M.unionWithKey (go.STxt) (f 0 nts) (f 1 ts) + in Source (g $ Source (es ++ ms) Q.empty isa tsa) q' isb tsb + where + f x = ((x::Int,) <$>) + g = fst . extractErr + go st (_, s) (_, s') = (2, replace' (st:ss) i s s') + g2 st (0, s) = replace' (st:ss) i s emptySource + g2 st (1, s) = replace' (st:ss) i emptySource s + g2 _ (_, s) = s + +data Selector + = STxt !Text + | SNum !Int + deriving Eq + +instance Show Selector where + show (STxt x) = T.unpack x + show (SNum i) = "[" ++ show i ++ "]" + +toKey :: [Selector] -> String +toKey = intercalate "." . go . reverse + where + go (a@(STxt _):b@(SNum _):cs) = (show a ++ show b) : go cs + go (a:bs) = show a : go bs + go [] = [] + +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 '.') + +-- xx +-- xx.xx +-- xx.xx[0] +-- xx.xx[1].xx +expr :: Parser [Selector] +expr = do + name <- T.pack <$> do + a <- choice [letter, digit] + b <- many' (choice [letter, digit, char '-', char '_']) + return (a:b) + (paren decimal >>= \i -> return [STxt name, SNum i]) <|> return [STxt name] + where + paren e = do + _ <- char '[' + ex <- e + _ <- char ']' + return ex + +addErr :: String -> Source -> Source +addErr e (Source es a b c) = Source (e:es) a b c + +insert :: Text -> Value -> Source -> Source +insert k v s = case selectors k of + Left e -> addErr e s + Right k' -> insert' k' v s + +insert' :: [Selector] -> Value -> Source -> Source +insert' [] v (Source es q is ts) = Source es (Q.insert v q) is ts +insert' ((STxt n):ss) v (Source es q is ts) = Source es q is $ M.alter (Just . insert' ss v . fromMaybe emptySource) n ts +insert' ((SNum i):ss) v (Source es q is ts) = Source es q (MI.alter (Just . insert' ss v . fromMaybe emptySource) i is) ts + +data SourcePack = SourcePack [Selector] Int Source PriorityEnv deriving Show + +emptySourcePack = SourcePack [] 0 emptySource MI.empty + +mapSource :: (Source -> Source) -> SourcePack -> SourcePack +mapSource f (SourcePack ss i s it) = SourcePack ss i (f s) it + +select :: SourcePack -> Selector -> SourcePack +select (SourcePack ss i (Source _ _ _ ts) it) s@(STxt n) = SourcePack (s:ss) i (fromMaybe emptySource $ M.lookup n ts) it +select (SourcePack ss i (Source _ _ is _) it) s@(SNum n) = SourcePack (s:ss) i (fromMaybe emptySource $ MI.lookup n is) it + +addErr' :: String -> SourcePack -> SourcePack +addErr' e = mapSource (addErr e) + +extractErr' :: SourcePack -> ([String], SourcePack) +extractErr' (SourcePack ss i s it) = let (es, s') = extractErr s in (es, SourcePack ss i s' it) + +loadFile :: Reload -> SourcePack -> (Priority -> Source -> Source) -> SourcePack +loadFile name (SourcePack ss i s env) go = SourcePack ss (i+1) (go i s) $ MI.insert i name env + +load + :: (Functor f, Foldable f) + => Reload + -> f a + -> (Priority -> a -> (Text, Value)) + -> SourcePack + -> SourcePack +load name fa f sp = loadFile name sp $ \i s -> foldl (go i) s fa + where + go i s a = let (k,v) = f i a in insert k v s + +loadMock :: Monad m => [(Text, Text)] -> SourcePackT m () +loadMock fs = modify $ load (emptyReload "") fs (\i (k,v) -> (k, VStr i v)) + +type SourcePackT = StateT SourcePack + +runSourcePackT :: Monad m => SourcePackT m a -> m ([String], SourcePack) +runSourcePackT ac = extractErr' <$> execStateT ac emptySourcePack + diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,141 +1,109 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where -import qualified Data.HashMap.Strict as M -import Data.Salak -import Data.Salak.CommandLine -import Data.Salak.Environment -import Data.Salak.Operation () -import Data.Text (Text, intercalate, pack) -import System.Environment +import Data.Either +import Data.List (intercalate) +import Data.Text (Text, pack, unpack) +import GHC.Generics +import Salak.Prop +import Salak.Types import Test.Hspec import Test.QuickCheck + main = hspec spec spec :: Spec spec = do - describe "Data.Salak.Types" specProperty - describe "Data.Salak" specProperties - describe "Data.Salak.Dynamic" specDynamic + describe "Salak.Types" specProperty -shouldFail :: (Show a, Eq a) => a -> a -> Expectation -shouldFail f a = (f `shouldBe` a) `shouldThrow` anyErrorCall +newtype SKey = SKey { unKey :: Text } deriving Show -data Config = Config - { name :: Text - , dir :: Text - , ext :: Int - } deriving (Eq, Show) +instance Arbitrary SKey where + arbitrary = do + key <- choose (1,20) + vs <- vectorOf key $ do + k <- choose (1,20) + v <- vectorOf k $ choose ('a','z') + b <- choose (0,10) :: Gen Int + if b > 0 then return v else do + x <- choose (0,10) :: Gen Int + return (v ++ "[" ++ show x ++ "]") + return (SKey $ pack $ intercalate "." vs) -instance FromProperties Config where - fromProperties v = Config - <$> v .?> "name" - <*> v .?> "dir" - <*> v .?> "ext" .?= 1 +data Conf = Conf + { name :: String + , age :: Int + , male :: Bool + , det :: SubConf + } deriving (Eq, Show, Generic) +data SubConf = SubConf + { hello :: String } deriving (Eq, Show, Generic) + +instance FromProp SubConf where + fromProp = SubConf <$> "hello" .?= "yyy" + +instance FromProp Conf + specProperty = do - context "empty" $ do - it "normal" $ do - let p = empty - print p - p `shouldBe` Properties [] [] - context "toKeys" $ do - it "normal" $ do - [] `shouldBe` toKeys "" - ["a"] `shouldBe` toKeys "a" - ["a"] `shouldBe` toKeys "a." - ["a","b"] `shouldBe` toKeys "a.b" - ["a","b"] `shouldBe` toKeys "a.....b" - it "quickCheck" $ do - quickCheck $ \a -> let b = toKeys $ pack a in b == toKeys (intercalate "." b) - context "insert" $ do - let p = PStr "Hello" - k = toKeys "a.b" - m = insert k p empty - it "normal" $ do - insert [] p empty `shouldBe` Properties [p] [] - insert k p empty `shouldBe` Properties [] [M.insert "a" (Properties [] [M.insert "b" (Properties [p] []) M.empty]) M.empty] - it "Reject replacement" $ do - insert k "1" m `shouldBe` m - it "quickCheck" $ do - quickCheck $ \a' (b :: Int) -> let a = pack a' in Just b == (insert (toKeys a) (PNum $ fromIntegral b) empty) .>> a - quickCheck $ \a' (b :: Bool) -> let a = pack a' in Just b == (insert (toKeys a) (PBool b) empty) .>> a - quickCheck $ \a' (b :: String) -> let a = pack a' in Just b == (insert (toKeys a) (PStr $ pack b) empty) .>> a - context "lookup" $ do - it "normal" $ do - let m = insert ["a"] (PNum 1) empty - n = insert ["a"] (PStr "true") empty - (empty .>> "a" :: Maybe Int) `shouldBe` Nothing - (m .>> "a" :: Maybe Int) `shouldBe` Just 1 - (m .>> "a" :: Maybe Bool) `shouldFail` Nothing - (m .>> "a" :: Maybe String) `shouldBe` Just "1.0" - (n .>> "a" :: Maybe Int) `shouldFail` Nothing - (n .>> "a" :: Maybe Bool) `shouldBe` Just True - (n .>> "a" :: Maybe Text) `shouldBe` Just "true" - context "makeProperties" $ do - it "normal" $ do - m <- makePropertiesFromEnvironment empty - h <- getEnv "HOME" - (m .>> "home") `shouldBe` Just h - context "command-line" $ do + context "selectors" $ do it "normal" $ do - let args = ["--package.a.enabled=true","--package.b.enabled=false","package.c.enabled=false"] - m <- makePropertiesFromCommandLine' args defaultParseCommandLine empty - (m .>> "package.a.enabled") `shouldBe` Just True - (m .>> "package.b.enabled") `shouldBe` Just False - (m .>> "package.c.enabled" :: Maybe Bool )`shouldBe` Nothing - context "environment" $ do + selectors "" `shouldBe` Right [] + selectors "." `shouldBe` Right [] + selectors ".." `shouldBe` Right [] + selectors "xx" `shouldBe` Right [STxt "xx"] + selectors "xx[0]" `shouldBe` Right [STxt "xx", SNum 0] + selectors "xx.yy" `shouldBe` Right [STxt "xx", STxt "yy"] + it "QuickCheck" $ do + quickCheck $ \s -> let s' = unKey s in (toKey . reverse <$> selectors s') `shouldBe` Right (unpack s') + context "source" $ do it "normal" $ do - let args = [("PACKAGE_A_ENABLED","true"),("PACKAGE_B_ENABLED","false")] - m = makePropertiesFromEnvironment' args empty - (m .>> "package.a.enabled") `shouldBe` Just True - (m .>> "package.b.enabled") `shouldBe` Just False - (m .>> "package.c.enabled" :: Maybe Bool )`shouldBe` Nothing + nullSource emptySource `shouldBe` True + sizeSouce emptySource `shouldBe` 0 + it "normal - 2" $ do + let s1 = insert "hello" (VStr 0 "world") emptySource + sizeSouce s1 `shouldBe` 1 + let s2 = insert "1" (VStr 0 "world") emptySource + sizeSouce s2 `shouldBe` 1 + let (es,_) = extractErr s2 + length es `shouldBe` 0 + it "merge" $ do + let s = insert "hello" (VStr 0 "world") emptySource + s1 = insert "hello" (VStr 0 "xxxxx") emptySource + (e2, s2) = extractErr $ replace 0 emptySource s + s2 `shouldBe` emptySource + e2 `shouldBe` ["Del hello"] + let (e3, s3) = extractErr $ replace 0 s1 s + e3 `shouldBe` ["Mod hello"] + s3 `shouldBe` s1 + let (e4, s4) = extractErr $ replace 0 s emptySource + e4 `shouldBe` ["Add hello"] + s4 `shouldBe` s + let (e5, s5) = extractErr $ replace 0 s s + e5 `shouldBe` [] + s5 `shouldBe` s + context "Generic" $ do + it "conf" $ do + (e, sp) <- runSourcePackT $ loadMock + [ ("name", "Daniel") + , ("age", "18") + , ("male", "yes") + -- , ("det.hello", "world") + ] + e `shouldBe` [] + let a = search "" sp :: Either String Conf + print a + isRight a `shouldBe` True -specProperties = do - context "defaultPropertiesWithFile" $ do - let confName = "salak.yml" :: String - confName' = pack confName - it "read config" $ do - unsetEnv "SALAK_CONFIG_NAME" - p <- defaultPropertiesWithFile confName - p .>> "salak.config.name" `shouldBe` Just confName - it "read config - replacement" $ do - setEnv "SALAK_CONFIG_NAME" confName - p <- defaultPropertiesWithFile "salak.ok" - p .>> "salak.config.name" `shouldBe` Just confName - it "read config - not found" $ do - setEnv "SALAK_CONFIG_NAME" "salak.notfound" - setEnv "SALAK_CONFIG_DIR" "test" - defaultPropertiesWithFile confName `shouldThrow` anyException - it "read config - read file parse Config" $ do - setEnv "SALAK_CONFIG_NAME" confName - setEnv "SALAK_CONFIG_DIR" "test" - setEnv "SALAK_CONFIG" confName - p <- defaultPropertiesWithFile confName - (p .>> "salak.config.name") `shouldBe` Just confName - (p .>> "salak.config") `shouldBe` Just confName - (p .>> "salak.config" :: Maybe Config) `shouldBe` Just (Config confName' "test" 1) - (p .>> "array" :: Maybe [String]) `shouldBe` Just ["a","b"] - (p .>> "array" :: Maybe [Int]) `shouldFail` Nothing - (p .>> "array" :: Maybe String) `shouldFail` Nothing -specDynamic = do - context "Dynamic" $ do - it "dynamic load" $ do - p <- defaultPropertiesWithFile "salak.yml" - (c,s) <- runLoader p $ (,) <$> load "config" <*> askSetProperties - c1 <- c - s $ insert ["config","name"] "world" empty - c2 <- c - name c1 `shouldBe` "hello" - name c2 `shouldBe` "world" - dir c1 `shouldBe` dir c2 - ext c1 `shouldBe` ext c2 + +