diff options
| -rw-r--r-- | erebos-tester.cabal | 1 | ||||
| -rw-r--r-- | src/Main.hs | 12 | ||||
| -rw-r--r-- | src/Parser.hs | 80 | ||||
| -rw-r--r-- | src/Test.hs | 53 | ||||
| -rw-r--r-- | src/Util.hs | 5 |
5 files changed, 119 insertions, 32 deletions
diff --git a/erebos-tester.cabal b/erebos-tester.cabal index 2ed105a..ed6398b 100644 --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -52,6 +52,7 @@ executable erebos-tester-core RankNTypes ScopedTypeVariables TupleSections + TypeApplications TypeFamilies TypeOperators build-depends: base >=4.13 && <5, diff --git a/src/Main.hs b/src/Main.hs index 7c6d587..bb5ec02 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -76,7 +76,7 @@ data TestEnv = TestEnv } data TestState = TestState - { tsVars :: [(VarName, Text)] + { tsVars :: [(VarName, SomeVarValue)] } newtype TestRun a = TestRun { fromTestRun :: ReaderT TestEnv (StateT TestState (ExceptT () IO)) a } @@ -96,7 +96,7 @@ instance MonadError () TestRun where catchError (TestRun act) handler = TestRun $ catchError act $ fromTestRun . handler instance MonadEval TestRun where - lookupStringVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< gets (lookup name . tsVars) + lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") return =<< gets (lookup name . tsVars) instance MonadOutput TestRun where getOutput = asks teOutput @@ -203,7 +203,7 @@ getNode net nname@(NodeName tnname) = (find ((nname==).nodeName) <$> liftIO (rea callOn node $ "ip link set dev lo up" return $ (node : nodes, ip) - modify $ \s -> s { tsVars = (VarName [tnname, T.pack "ip"], T.pack ip) : tsVars s } + modify $ \s -> s { tsVars = (VarName [tnname, T.pack "ip"], SomeVarValue (T.pack ip)) : tsVars s } return node callOn :: Node -> String -> IO () @@ -291,13 +291,13 @@ expect (SourceLine sline) p expr vars = do outLine OutputError (Just $ procName p) $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline throwError () - modify $ \s -> s { tsVars = zip vars capture ++ tsVars s } + modify $ \s -> s { tsVars = zip vars (map SomeVarValue capture) ++ tsVars s } outLine OutputMatch (Just $ procName p) line Nothing -> do outLine OutputMatchFail (Just $ procName p) $ T.pack "expect failed on " `T.append` sline exprVars <- gatherVars expr forM_ exprVars $ \(name, value) -> - outLine OutputMatchFail (Just $ procName p) $ T.concat [T.pack " ", textVarName name, T.pack " = ", T.pack (show value)] + outLine OutputMatchFail (Just $ procName p) $ T.concat [T.pack " ", textVarName name, T.pack " = ", textSomeVarValue value] throwError () testStepGuard :: SourceLine -> Expr Bool -> TestRun () @@ -342,7 +342,7 @@ runTest out opts test = do outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline throwError () value <- eval expr - modify $ \s -> s { tsVars = (name, value) : tsVars s } + modify $ \s -> s { tsVars = (name, SomeVarValue value) : tsVars s } Spawn pname nname -> do node <- getNode net nname diff --git a/src/Parser.hs b/src/Parser.hs index bce5a02..760b744 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -16,6 +16,7 @@ import Data.Text (Text) import Data.Text qualified as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as TL +import Data.Typeable import Data.Void import Generics.Deriving.Base as G @@ -28,12 +29,23 @@ import System.Exit import Test -type TestParser = ParsecT Void TestStream (State (Set ProcName)) +type TestParser = ParsecT Void TestStream (State TestParserState) type TestStream = TL.Text +data TestParserState = TestParserState + { testProcs :: Set ProcName + , testVars :: [(VarName, SomeExprType)] + } + +data SomeExprType = forall a. ExprType a => SomeExprType (Proxy a) + +someEmptyVar :: SomeExprType -> SomeVarValue +someEmptyVar (SomeExprType (Proxy :: Proxy a)) = SomeVarValue $ emptyVarValue @a + instance MonadEval TestParser where - lookupStringVar _ = return T.empty + lookupVar (VarName [_, ip]) | ip == T.pack "ip" = return $ SomeVarValue T.empty + lookupVar name = maybe (fail $ "variable not in scope: '" ++ unpackVarName name ++ "'") (return . someEmptyVar) =<< gets (lookup name . testVars) skipLineComment :: TestParser () skipLineComment = L.skipLineComment $ TL.pack "#" @@ -97,6 +109,19 @@ varName = do VarName . T.splitOn (T.singleton '.') . TL.toStrict <$> takeWhile1P Nothing (\x -> isAlphaNum x || x == '_' || x == '.') +newVarName :: forall a proxy. ExprType a => proxy a -> TestParser VarName +newVarName proxy = do + name <- VarName . (:[]) <$> identifier + addVarName proxy name + return name + +addVarName :: forall a proxy. ExprType a => proxy a -> VarName -> TestParser () +addVarName _ name = do + gets (lookup name . testVars) >>= \case + Just _ -> fail $ "variable '" ++ unpackVarName name ++ "' already exists" + Nothing -> return () + modify $ \s -> s { testVars = (name, SomeExprType @a Proxy) : testVars s } + varExpansion :: TestParser VarName varExpansion = do void $ char '$' @@ -108,12 +133,15 @@ varExpansion = do return name ] +integerLiteral :: TestParser (Expr Integer) +integerLiteral = Literal . read . TL.unpack <$> takeWhile1P (Just "integer") isDigit + quotedString :: TestParser (Expr Text) quotedString = label "string" $ lexeme $ do symbol "\"" let inner = choice [ char '"' >> return [] - , takeWhile1P Nothing (`notElem` "\"\\$") >>= \s -> (StringLit (TL.toStrict s):) <$> inner + , takeWhile1P Nothing (`notElem` "\"\\$") >>= \s -> (Literal (TL.toStrict s):) <$> inner ,do void $ char '\\' c <- choice [ char '\\' >> return '\\' @@ -123,9 +151,9 @@ quotedString = label "string" $ lexeme $ do , char 'r' >> return '\r' , char 't' >> return '\t' ] - (StringLit (T.singleton c) :) <$> inner + (Literal (T.singleton c) :) <$> inner ,do name <- varExpansion - (StringVar name :) <$> inner + (Variable name :) <$> inner ] Concat <$> inner @@ -134,24 +162,36 @@ regex = label "regular expression" $ lexeme $ do symbol "/" let inner = choice [ char '/' >> return [] - , takeWhile1P Nothing (`notElem` "/\\$") >>= \s -> (StringLit (TL.toStrict s) :) <$> inner + , takeWhile1P Nothing (`notElem` "/\\$") >>= \s -> (Literal (TL.toStrict s) :) <$> inner ,do void $ char '\\' s <- choice - [ char '/' >> return (StringLit $ T.singleton '/') - , anySingle >>= \c -> return (StringLit $ T.pack ['\\', c]) + [ char '/' >> return (Literal $ T.singleton '/') + , anySingle >>= \c -> return (Literal $ T.pack ['\\', c]) ] (s:) <$> inner ,do name <- varExpansion - (StringVar name :) <$> inner + (Variable name :) <$> inner ] expr <- Regex <$> inner _ <- eval expr -- test regex parsing with empty variables return expr +integerExpr :: TestParser (Expr Integer) +integerExpr = choice + [ integerLiteral + , try $ do + name <- varName + _ <- fromSomeVarValue @Integer name =<< lookupVar name + return $ Variable name + ] + stringExpr :: TestParser (Expr Text) stringExpr = choice [ quotedString - , StringVar <$> varName + , try $ do + name <- varName + _ <- fromSomeVarValue @Text name =<< lookupVar name + return $ Variable name ] boolExpr :: TestParser (Expr Bool) @@ -192,8 +232,16 @@ letStatement = do name <- VarName . (:[]) <$> identifier sc symbol "=" - value <- stringExpr - return [Let line name value] + let finish :: forall a. ExprType a => TestParser (Expr a) -> TestParser [TestStep] + finish expr = do + value <- expr + addVarName @a Proxy name + return [Let line name value] + + choice + [ finish integerExpr + , finish stringExpr + ] command :: (Generic b, GInit (Rep b)) => String -> [Param b] -> (SourceLine -> b -> TestParser a) -> TestParser [a] @@ -275,7 +323,7 @@ testExpect :: TestParser [TestStep] testExpect = command "expect" [ Param "from" expectBuilderProc procName , Param "" expectBuilderRegex regex - , Param "capture" expectBuilderCaptures (listOf $ VarName . (:[]) <$> identifier) + , Param "capture" expectBuilderCaptures (listOf $ newVarName @Text Proxy) ] $ \s b -> Expect s <$> (maybe (fail "missing 'from' <proc>") return $ b ^. expectBuilderProc) <*> (maybe (fail "missing regex to match") return $ b ^. expectBuilderRegex) @@ -324,6 +372,10 @@ parseTestDefinitions = do parseTestFile :: FilePath -> IO [Test] parseTestFile path = do content <- TL.readFile path - case evalState (runParserT parseTestDefinitions path content) S.empty of + let initState = TestParserState + { testProcs = S.empty + , testVars = [] + } + case evalState (runParserT parseTestDefinitions path content) initState of Left err -> putStr (errorBundlePretty err) >> exitFailure Right tests -> return tests diff --git a/src/Test.hs b/src/Test.hs index 80ee966..16c1b1f 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -8,6 +8,8 @@ module Test ( MonadEval(..), VarName(..), textVarName, unpackVarName, + ExprType(..), + SomeVarValue(..), fromSomeVarValue, textSomeVarValue, Expr(..), eval, gatherVars, Regex, ) where @@ -18,6 +20,7 @@ import Data.Char import Data.List import Data.Text (Text) import qualified Data.Text as T +import Data.Typeable import Text.Regex.TDFA import Text.Regex.TDFA.Text @@ -30,7 +33,7 @@ data Test = Test , testSteps :: [TestStep] } -data TestStep = Let SourceLine VarName (Expr Text) +data TestStep = forall a. ExprType a => Let SourceLine VarName (Expr a) | Spawn ProcName NodeName | Send ProcName (Expr Text) | Expect SourceLine ProcName (Expr Regex) [VarName] @@ -50,7 +53,7 @@ unpackNodeName (NodeName tname) = T.unpack tname class MonadFail m => MonadEval m where - lookupStringVar :: VarName -> m Text + lookupVar :: VarName -> m SomeVarValue data VarName = VarName [Text] @@ -63,20 +66,46 @@ unpackVarName :: VarName -> String unpackVarName = T.unpack . textVarName +class Typeable a => ExprType a where + textExprType :: proxy a -> Text + textExprValue :: a -> Text + emptyVarValue :: a + +instance ExprType Integer where + textExprType _ = T.pack "integer" + textExprValue x = T.pack (show x) + emptyVarValue = 0 + +instance ExprType Text where + textExprType _ = T.pack "string" + textExprValue x = T.pack (show x) + emptyVarValue = T.empty + +data SomeVarValue = forall a. ExprType a => SomeVarValue a + +fromSomeVarValue :: forall a m. (ExprType a, MonadFail m) => VarName -> SomeVarValue -> m a +fromSomeVarValue name (SomeVarValue value) = maybe (fail err) return $ cast value + where err = T.unpack $ T.concat [ T.pack "expected ", textExprType @a Proxy, T.pack ", but variable '", textVarName name, T.pack "' has type ", textExprType (Just value) ] + +textSomeVarValue :: SomeVarValue -> Text +textSomeVarValue (SomeVarValue value) = textExprValue value + + data Expr a where - StringVar :: VarName -> Expr Text - StringLit :: Text -> Expr Text + Variable :: ExprType a => VarName -> Expr a + Literal :: ExprType a => a -> Expr a Concat :: [Expr Text] -> Expr Text Regex :: [Expr Text] -> Expr Regex BinOp :: (b -> c -> a) -> Expr b -> Expr c -> Expr a eval :: MonadEval m => Expr a -> m a -eval (StringVar var) = lookupStringVar var -eval (StringLit str) = return str +eval (Variable name) = fromSomeVarValue name =<< lookupVar name +eval (Literal value) = return value eval (Concat xs) = T.concat <$> mapM eval xs eval (Regex xs) = do parts <- forM xs $ \case - StringLit str -> return str + Literal value | Just str <- cast value -> return str + | otherwise -> fail $ "regex expansion not defined for " ++ T.unpack (textExprType $ Just value) expr -> T.concatMap escapeChar <$> eval expr where escapeChar c | isAlphaNum c = T.singleton c @@ -87,12 +116,12 @@ eval (Regex xs) = do Right re -> return re eval (BinOp f x y) = f <$> eval x <*> eval y -gatherVars :: forall a m. MonadEval m => Expr a -> m [(VarName, Text)] -gatherVars = fmap (uniq . sort) . helper +gatherVars :: forall a m. MonadEval m => Expr a -> m [(VarName, SomeVarValue)] +gatherVars = fmap (uniqOn fst . sortOn fst) . helper where - helper :: forall b. Expr b -> m [(VarName, Text)] - helper (StringVar var) = (:[]) . (var,) <$> lookupStringVar var - helper (StringLit _) = return [] + helper :: forall b. Expr b -> m [(VarName, SomeVarValue)] + helper (Variable var) = (:[]) . (var,) <$> lookupVar var + helper (Literal _) = return [] helper (Concat es) = concat <$> mapM helper es helper (Regex es) = concat <$> mapM helper es helper (BinOp _ e f) = (++) <$> helper e <*> helper f diff --git a/src/Util.hs b/src/Util.hs index 99d51f6..4200e20 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -4,3 +4,8 @@ uniq :: Eq a => [a] -> [a] uniq (x:y:xs) | x == y = uniq (x:xs) | otherwise = x : uniq (y:xs) uniq xs = xs + +uniqOn :: Eq b => (a -> b) -> [a] -> [a] +uniqOn f (x:y:xs) | f x == f y = uniqOn f (x:xs) + | otherwise = x : uniqOn f (y:xs) +uniqOn _ xs = xs |