salak 0.3.3.2 → 0.3.4
raw patch · 10 files changed
+226/−72 lines, 10 files
Files
- README.md +0/−1
- salak.cabal +2/−1
- src/Salak/Internal.hs +2/−1
- src/Salak/Internal/Key.hs +9/−3
- src/Salak/Internal/Prop.hs +27/−10
- src/Salak/Internal/Source.hs +28/−16
- src/Salak/Internal/Val.hs +86/−12
- src/Salak/Trie.hs +2/−19
- test/Salak/Internal/PropSpec.hs +46/−9
- test/Salak/Internal/TrieSpec.hs +24/−0
README.md view
@@ -96,6 +96,5 @@ ``` TODO:-- Recover placeholder - Add git pull support. - Add automatic reloading.
salak.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: salak-version: 0.3.3.2+version: 0.3.4 license: MIT license-file: LICENSE copyright: 2019 Daniel YU@@ -59,6 +59,7 @@ Salak.Internal.KeySpec Salak.Internal.PropSpec Salak.Internal.SourceSpec+ Salak.Internal.TrieSpec Salak Salak.Internal Salak.Internal.Key
src/Salak/Internal.hs view
@@ -66,6 +66,7 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM import Data.Maybe+import qualified Data.Set as S import Data.Text (Text, pack) import qualified Data.Text as TT import Salak.Internal.Key@@ -174,7 +175,7 @@ runLoad (lm >> MS.get) (UpdateSource r 0 HM.empty l q u) >>= toSourcePack toSourcePack :: MonadIO m => UpdateSource -> m SourcePack-toSourcePack UpdateSource{..} = liftIO (readMVar ref) >>= \s -> return $ SourcePack s mempty qfunc lfunc go+toSourcePack UpdateSource{..} = liftIO (readMVar ref) >>= \s -> return $ SourcePack s s S.empty mempty qfunc lfunc go where go = do t <- readMVar ref
src/Salak/Internal/Key.hs view
@@ -12,6 +12,7 @@ , ToKeys(..) , isNum , isStr+ , exprs ) where import Control.Applicative ((<|>))@@ -19,6 +20,7 @@ import qualified Data.DList as D import Data.Hashable import Data.List (intercalate)+import Data.String import Data.Text (Text) import qualified Data.Text as T #if __GLASGOW_HASKELL__ < 804@@ -36,7 +38,7 @@ compare (KI _) _ = LT compare _ _ = GT -newtype Keys = Keys { unKeys :: D.DList Key } deriving Eq+newtype Keys = Keys { unKeys :: D.DList Key } deriving (Eq, Ord) emptyKey :: Keys emptyKey = Keys D.empty@@ -58,9 +60,8 @@ mappend = (<>) instance Show Keys where- show = toKey . D.toList . unKeys+ show = intercalate "." . go . toKeyList 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 [] = []@@ -113,6 +114,11 @@ class ToKeys a where toKeys :: a -> Either String Keys++instance IsString Keys where+ fromString key = case toKeys key of+ Left _ -> singletonKey (KT $ T.pack key)+ Right k -> k instance ToKeys Keys where toKeys = Right
src/Salak/Internal/Prop.hs view
@@ -33,6 +33,7 @@ import Data.Menshen import Data.Scientific import Data.Semigroup+import qualified Data.Set as S import Data.Text (Text, unpack) import qualified Data.Text as T import qualified Data.Text.Encoding as TB@@ -50,6 +51,7 @@ import Text.Read (readMaybe) import Unsafe.Coerce (unsafeCoerce) + -- | Core type class of salak, which provide function to parse properties. class Monad m => MonadSalak m where @@ -165,7 +167,6 @@ instance Monad m => MonadFail (Prop m) where fail = failKey "" . PropException - -- | Type class used to parse properties. class FromProp m a where @@ -212,11 +213,11 @@ fromProp = M.fromList <$> fromProp -- | Supports for parsing `IO` value.-instance {-# OVERLAPPABLE #-} (MonadIO m, MonadIO n, FromProp (Either SomeException) a, FromProp m a) => FromProp m (n a) where+instance {-# OVERLAPPABLE #-} (MonadIO m, FromProp (Either SomeException) a, FromProp m a) => FromProp m (IO a) where fromProp = do sp <- ask a <- fromProp- lift $ liftIO <$> buildIO sp a+ buildIO sp a buildIO :: (MonadIO m, FromProp (Either SomeException) a) => SourcePack -> a -> m (IO a) buildIO sp a = liftIO $ do@@ -282,13 +283,29 @@ readPrimitive :: Monad m => (Value -> Either String a) -> Prop m a readPrimitive f = do SourcePack{..} <- ask- vx <- g $ TR.getPrimitive source >>= getVal- case f <$> vx of- Just (Left e) -> Control.Monad.Fail.fail e- Just (Right a) -> return a- _ -> A.empty- where- g = return+ let go (VRT t : as) = if null as then return t else (t <>) <$> go as+ go (VRR k d : as) = if S.member k kref+ then Control.Monad.Fail.fail $ "reference cycle of key " <> show k+ else do+ t <- withProp (\_ -> SourcePack+ { pref = k+ , source = TR.subTries k origin+ , kref = S.insert k kref+ , .. }) fromProp+ w <- case t of+ Just x -> return x+ _ -> if null d then A.empty else go d+ if null as then return w else (w <>) <$> go as+ go [] = A.empty+ g2 (VR r) = VT <$> go r+ g2 v = return v+ case TR.getPrimitive source >>= getVal of+ Just v -> do+ vy <- g2 v+ case f vy of+ Left e -> Control.Monad.Fail.fail e+ Right a -> return a+ _ -> A.empty -- | Parse enum value from `Text` readEnum :: Monad m => (Text -> Either String a) -> Prop m a
src/Salak/Internal/Source.hs view
@@ -6,7 +6,7 @@ import Control.Concurrent.MVar import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM-import qualified Data.Heap as H+import qualified Data.Set as S import Salak.Internal.Key import Salak.Internal.Val import qualified Salak.Trie as T@@ -26,6 +26,8 @@ data SourcePack = SourcePack { source :: !Source+ , origin :: !Source+ , kref :: !(S.Set Keys) , pref :: !Keys , qref :: !(MVar QFunc) , lref :: !(MVar LFunc)@@ -36,15 +38,15 @@ diff = T.unionWith' 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+ go (Just a) Nothing = if nullVals a then Nothing else Just Add+ go Nothing (Just a) = if nullVals a then Nothing else Just Del+ go (Just a) (Just b)+ | nullVals a && nullVals b = Nothing+ | nullVals a = Just Del+ | nullVals b = Just Add+ | otherwise =+ let Val i x = minimumVals a+ Val j y = minimumVals b in if i==j && x==y then Nothing else Just Mod extract :: Source -> TraceSource -> (Source, T.Trie ModType, [String])@@ -62,10 +64,14 @@ go (k,v) x = case toKeys k of Left e -> T.alter (g3 e) mempty 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)+ g2 v (Just (a,c)) = case modVals v c of+ Left e -> Just (e:a, c)+ Right d -> Just (a, d)+ g2 v _ = case singletonVals v of+ Left e -> Just ([e], emptyVals)+ Right d -> Just ([], d) g3 e (Just (a,c)) = Just (e:a,c)- g3 e _ = Just ([e], Vals H.empty)+ g3 e _ = Just ([e], emptyVals) fmt :: ModType -> Int -> String -> String -> String fmt m i s n = concat ['#' : show i, ' ' : show m, ' ' : s , ' ' : n]@@ -79,10 +85,16 @@ 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)+ go (Just (e1,v1)) (Just (e2,v2)) = case modVals' v2 v1 of+ Left e -> Just (e:e1++e2, v2)+ Right v -> Just (e1++e2,v) setVal :: ToValue v => Int -> v -> TraceSource -> TraceSource setVal i v = T.update go where- go Nothing = Just ([], modVals (Val i $ toVal v) emptyVals)- go (Just (e,vs)) = Just (e, modVals (Val i $ toVal v) vs)+ go Nothing = case modVals (Val i $ toVal v) emptyVals of+ Left e -> Just ([e], emptyVals)+ Right x -> Just ([], x)+ go (Just (e,vs)) = case modVals (Val i $ toVal v) vs of+ Left e1 -> Just (e1:e, vs)+ Right x -> Just (e, x)
src/Salak/Internal/Val.hs view
@@ -1,21 +1,30 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoOverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} module Salak.Internal.Val where -import Data.ByteString (ByteString)-import Data.Heap (Heap)-import qualified Data.Heap as H+import Control.Applicative+import Data.Attoparsec.Text+import Data.ByteString (ByteString)+import Data.Heap (Heap)+import qualified Data.Heap as H import Data.Int-import Data.List (intercalate)+import Data.List (intercalate) import Data.Scientific-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8) import Data.Time+import Salak.Internal.Key+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup((<>))+#endif data Val v = Val !Int !v deriving (Eq, Show)+ data ModType = Add | Mod@@ -27,6 +36,18 @@ priority :: Val v -> Int priority (Val i _) = i +data VRef+ = VRT !Text+ | VRR !Keys ![VRef]+ deriving Eq++instance Show VRef where+ show (VRT t) = T.unpack t+ show (VRR k m) = "${" <> show k <> (if null m then go m else ":" <> go m) <> "}"+ where+ go [] = ""+ go (x:as) = show x <> go as+ data Value = VT !Text | VI !Scientific@@ -36,6 +57,7 @@ | VH !TimeOfDay | VZT !TimeZone !LocalTime | VU !UTCTime+ | VR ![VRef] deriving Eq instance Show Value where@@ -49,11 +71,54 @@ typeOfV (VD b) = ("Day", show b) typeOfV (VH b) = ("TimeOfDay", show b) typeOfV (VZT _ b) = ("ZonedTime", show b)-typeOfV (VU b) = ("UTCTime", show b)+typeOfV (VU b) = ("UTCTime", show b)+typeOfV (VR b) = ("Ref", show b) getType :: Value -> String getType = fst . typeOfV +mkValue :: Value -> Either String Value+mkValue (VT v) = case parseOnly (vref <* endOfInput) v of+ Left e -> Left e+ Right x -> Right $ case go x of+ [VRT _] -> VT v+ vs -> VR vs+ where+ go (VRT a:VRT b:as) = go (VRT (a <> b):as)+ go (VRT a:b:as) = VRT a:b:go as+ go (a:as) = a : go as+ go [] = []+mkValue v = Right v++-- mkValue' :: Value -> Value+-- mkValue' v = case mkValue v of+-- Left _ -> v+-- Right x -> x++exprChar :: Parser Char+exprChar = satisfy (notInClass "\\${}") <|> go+ where+ go = do+ a <- char '\\'+ v <- peekChar+ case v of+ Just '\\' -> char '\\'+ Just '$' -> char '$'+ Just '{' -> char '{'+ Just '}' -> char '}'+ Just x -> fail $ "error char sequence \\" <> [x]+ _ -> return a++vref :: Parser [VRef]+vref = many1' (go <|> (VRT . T.pack <$> many1' exprChar))+ where+ go = do+ _ <- string "${"+ k <- exprs+ v <- option [] $ (char ':' >> option [VRT ""] vref )+ _ <- char '}'+ return (VRR (fromKeys k) v)+ newtype Vals = Vals { unVals :: Heap (Val Value) } deriving Eq instance Show Vals where@@ -67,6 +132,9 @@ nullVals :: Vals -> Bool nullVals (Vals v) = H.null v +minimumVals :: Vals -> Val Value+minimumVals (Vals h) = H.minimum h+ emptyVals :: Vals emptyVals = Vals H.empty @@ -119,12 +187,18 @@ 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 :: Val Value -> Vals -> Either String Vals+modVals (Val p x) (Vals v) = case mkValue x of+ Left e -> Left e+ Right y -> Right $ Vals $ H.insert (Val p y) $ H.filter ((/=p) . priority) v +singletonVals :: Val Value -> Either String Vals+singletonVals (Val p x) = case mkValue x of+ Left e -> Left e+ Right y -> Right $ Vals $ H.singleton $ Val p y -modVals' :: Vals -> Vals -> Vals-modVals' (Vals v) vals = if H.null v then vals else modVals (H.minimum v) vals+modVals' :: Vals -> Vals -> Either String Vals+modVals' (Vals v) vals = if H.null v then Right vals else modVals (H.minimum v) vals
src/Salak/Trie.hs view
@@ -25,7 +25,7 @@ , subTries , insert , modify- , modifyF+ -- , modifyF , modify' , update , alter@@ -41,7 +41,6 @@ ) where import Control.Applicative (pure, (<*>))-import Control.Monad (Monad (..)) import Data.Bool import qualified Data.DList as D import Data.Eq@@ -126,13 +125,6 @@ modify' :: Eq v => Keys -> (Trie v -> Trie v) -> Trie v -> Trie v modify' ks f = foldr modify f (toKeyList ks) --- | /O(log m)/. The expression (`modifyF` k f trie) modifies the sub trie at k.-modifyF :: (Monad m, Eq v) => Key -> (Trie v -> m (Trie v)) -> Trie v -> m (Trie v)-modifyF k f (Trie v m) = Trie v <$> HM.alterF go k m- where- go (Just w) = (\x -> if x == empty then Nothing else Just x) <$> f w- go _ = return Nothing- -- | /O(1)/. The expression (update f trie) updates the primitive value in the trie. update :: Eq v => (Maybe v -> Maybe v) -> Trie v -> Trie v update f = alter f mempty@@ -141,15 +133,6 @@ alter :: Eq v => (Maybe v -> Maybe v) -> Keys -> Trie v -> Trie v alter f keys = modify' keys (\(Trie a b) -> Trie (f a) b) --- | /O(n)/. The expression (update f ks trie) updates the primitive value of sub trie at ks.--- alterF :: (Functor f, Eq v) => (Maybe v -> f(Maybe v)) -> Keys -> Trie v -> f (Trie v)--- alterF f keys = modifyF- -- where- -- go D.Nil (Trie v m) = (`Trie` m) <$> f v- -- go (D.Cons 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- -- | /O(n*m)/. Return a list of this tries's elements. The list is produced lazily. toList :: Trie v -> [(Keys, v)] toList = go D.empty@@ -157,7 +140,7 @@ go p (Trie (Just v) m) = (Keys 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 (D.cons k p) t+ g3 p (k,t) = go (D.snoc p k) t -- | /O(n*m*log n)/. Construct a trie with the supplied mappings. -- If the list contains duplicate mappings, the later mappings take precedence.
test/Salak/Internal/PropSpec.hs view
@@ -1,20 +1,26 @@ module Salak.Internal.PropSpec where import Control.Concurrent.MVar+import Control.Monad.Writer+import Data.Either import Data.Int+import qualified Data.Set as S+import Salak import Salak.Internal-import Salak.Internal.Source import Salak.Internal.Val import qualified Salak.Trie as T import Test.Hspec--- import Test.QuickCheck newSource :: Value -> Source-newSource v = T.singleton $ modVals (Val 0 v) emptyVals+newSource v = case modVals (Val 0 v) emptyVals of+ Left _ -> T.empty+ Right x -> T.singleton x newSourcePack :: Value -> IO SourcePack newSourcePack v = do let source = newSource v+ origin = source+ kref = S.empty pref = mempty reload = return $ ReloadResult False [] qref <- newMVar $ \_ -> Right (return ())@@ -28,10 +34,41 @@ sp <- newSourcePack (VT "128") let run :: forall m a. Monad m => RunSalakT m a -> m a run = (`runRun` sp)- vInt :: Int <- run $ require ""- vInt32 :: Int32 <- run $ require ""- -- vInt8 :: Int8 <- run $ require ""- 128 `shouldBe` vInt- 128 `shouldBe` vInt32- -- print vInt8+ vInt <- run $ require ""+ vInt32 <- run $ require ""+ 128 `shouldBe` (vInt :: Int)+ 128 `shouldBe` (vInt32 :: Int32)+ context "placeholder" $ do+ it "placeholder" $ do+ mkValue (VT "${xxxx}") `shouldBe` Right (VR [VRR "xxxx" []])+ mkValue (VT "${xxxx:}") `shouldBe` Right (VR [VRR "xxxx" [VRT ""]])+ mkValue (VT "${xxxx:7}") `shouldBe` Right (VR [VRR "xxxx" [VRT "7"]])+ mkValue (VT "${xxxx:\\}}") `shouldBe` Right (VR [VRR "xxxx" [VRT "}"]])+ mkValue (VT "${xxxx:${yyy}}") `shouldBe` Right (VR [VRR "xxxx" [VRR "yyy" []]])+ mkValue (VT "--${xxxx:7}") `shouldBe` Right (VR [VRT "--", VRR "xxxx" [VRT "7"]])+ mkValue (VT "${xxxx:7}\\}") `shouldBe` Right (VR [VRR "xxxx" [VRT "7"], VRT "}"])+ mkValue (VT "128") `shouldBe` Right (VT "128")+ mkValue (VT "${128") `shouldSatisfy` isLeft+ it "source" $ do+ let vals =+ [ ("hello","${hey}")+ , ("hey","girl")+ , ("ok", "${xx:girl}")+ , ("nk", "${xx}")+ , ("a", "${b}")+ , ("b", "${a}")+ ]+ loadAndRunSalak (loadMock vals) $ do+ v <- require "hello"+ x <- require "hey"+ y <- require "a"+ z <- require "ok"+ w <- require "nk"+ lift $ do+ (x :: String) `shouldBe` "girl"+ (v :: String) `shouldBe` "girl"+ (z :: String) `shouldBe` "girl"+ (w :: Either String String) `shouldSatisfy` isLeft+ (y :: Either String String) `shouldSatisfy` isLeft+
+ test/Salak/Internal/TrieSpec.hs view
@@ -0,0 +1,24 @@+module Salak.Internal.TrieSpec where++import qualified Data.HashMap.Strict as HM+import Salak.Internal.Key+import qualified Salak.Trie as T+import Test.Hspec+++spec :: SpecWith ()+spec = do+ context "Trie" $ do+ it "insert" $ do+ let Right keys = toKeys ("a.b.c" :: String)+ v = T.insert keys (1 :: Int) T.empty+ w = T.alter (\_ -> Just 1) keys T.empty+ v `shouldBe` w+ T.getPrimitive (T.subTries keys v) `shouldBe` Just 1+ it "toList" $ do+ let Right keys = toKeys ("a.b.c.d" :: String)+ w = T.insert keys (2 :: Int) T.empty+ [(k,v)] = T.toList w+ k `shouldBe` keys+ v `shouldBe` 2+ HM.member (KT "a") (T.getMap w) `shouldBe` True