diff options
| -rw-r--r-- | erebos-tester.cabal | 1 | ||||
| -rw-r--r-- | src/Main.hs | 9 | ||||
| -rw-r--r-- | src/Parser.hs | 28 | ||||
| -rw-r--r-- | src/Test.hs | 37 |
4 files changed, 38 insertions, 37 deletions
diff --git a/erebos-tester.cabal b/erebos-tester.cabal index 90c768d..8b66f13 100644 --- a/erebos-tester.cabal +++ b/erebos-tester.cabal @@ -43,6 +43,7 @@ executable erebos-tester-core ExistentialQuantification FlexibleContexts FlexibleInstances + GADTs GeneralizedNewtypeDeriving ImportQualifiedPost LambdaCase diff --git a/src/Main.hs b/src/Main.hs index a1b6625..e062dee 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,6 +1,5 @@ module Main where -import Control.Arrow import Control.Applicative import Control.Concurrent import Control.Concurrent.STM @@ -333,13 +332,13 @@ runTest out opts test = do Send pname expr -> do p <- getProcess net pname - line <- evalStringExpr expr + line <- eval expr send p line - Expect pname expr@(RegexExpr ps) captures -> do + Expect pname expr@(Regex ps) captures -> do p <- getProcess net pname - regex <- evalRegexExpr expr - pat <- evalStringExpr (StringExpr $ map (left T.pack) ps) + regex <- eval expr + pat <- eval (Concat ps) expect p regex pat captures Wait -> do diff --git a/src/Parser.hs b/src/Parser.hs index bf7f75b..6131a78 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -103,12 +103,12 @@ varExpansion = do return $ VarName $ T.splitOn (T.singleton '.') (TL.toStrict name) ] -quotedString :: TestParser StringExpr +quotedString :: TestParser (Expr Text) quotedString = label "string" $ lexeme $ do symbol "\"" let inner = choice [ char '"' >> return [] - , takeWhile1P Nothing (`notElem` "\"\\$") >>= \s -> (Left (TL.toStrict s):) <$> inner + , takeWhile1P Nothing (`notElem` "\"\\$") >>= \s -> (StringLit (TL.toStrict s):) <$> inner ,do void $ char '\\' c <- choice [ char '\\' >> return '\\' @@ -118,29 +118,29 @@ quotedString = label "string" $ lexeme $ do , char 'r' >> return '\r' , char 't' >> return '\t' ] - (Left (T.singleton c) :) <$> inner + (StringLit (T.singleton c) :) <$> inner ,do name <- varExpansion - (Right name :) <$> inner + (StringVar name :) <$> inner ] - StringExpr <$> inner + Concat <$> inner -regex :: TestParser RegexExpr +regex :: TestParser (Expr Regex) regex = label "regular expression" $ lexeme $ do symbol "/" let inner = choice [ char '/' >> return [] - , takeWhile1P Nothing (`notElem` "/\\$") >>= \s -> (Left (TL.unpack s) :) <$> inner + , takeWhile1P Nothing (`notElem` "/\\$") >>= \s -> (StringLit (TL.toStrict s) :) <$> inner ,do void $ char '\\' s <- choice - [ char '/' >> return (Left $ "/") - , anySingle >>= \c -> return (Left ['\\', c]) + [ char '/' >> return (StringLit $ T.singleton '/') + , anySingle >>= \c -> return (StringLit $ T.pack ['\\', c]) ] (s:) <$> inner ,do name <- varExpansion - (Right name :) <$> inner + (StringVar name :) <$> inner ] - expr <- RegexExpr <$> inner - _ <- evalRegexExpr expr -- test regex parsing with empty variables + expr <- Regex <$> inner + _ <- eval expr -- test regex parsing with empty variables return expr @@ -200,7 +200,7 @@ testSpawn = command "spawn" data SendBuilder = SendBuilder { _sendBuilderProc :: Maybe ProcName - , _sendBuilderLine :: Maybe StringExpr + , _sendBuilderLine :: Maybe (Expr Text) } deriving (Generic) @@ -217,7 +217,7 @@ testSend = command "send" data ExpectBuilder = ExpectBuilder { _expectBuilderProc :: Maybe ProcName - , _expectBuilderRegex :: Maybe RegexExpr + , _expectBuilderRegex :: Maybe (Expr Regex) , _expectBuilderCaptures :: Maybe [VarName] } deriving (Generic) diff --git a/src/Test.hs b/src/Test.hs index c58a2a3..ab97bc7 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -7,8 +7,8 @@ module Test ( MonadEval(..), VarName(..), textVarName, unpackVarName, - StringExpr(..), evalStringExpr, - RegexExpr(..), evalRegexExpr, + Expr(..), eval, + Regex, ) where import Control.Monad @@ -18,7 +18,7 @@ import Data.Text (Text) import qualified Data.Text as T import Text.Regex.TDFA -import Text.Regex.TDFA.String +import Text.Regex.TDFA.Text import Process @@ -28,8 +28,8 @@ data Test = Test } data TestStep = Spawn ProcName NodeName - | Send ProcName StringExpr - | Expect ProcName RegexExpr [VarName] + | Send ProcName (Expr Text) + | Expect ProcName (Expr Regex) [VarName] | Wait newtype NodeName = NodeName Text @@ -42,7 +42,7 @@ unpackNodeName :: NodeName -> String unpackNodeName (NodeName tname) = T.unpack tname -class Monad m => MonadEval m where +class MonadFail m => MonadEval m where lookupStringVar :: VarName -> m Text @@ -55,20 +55,21 @@ textVarName (VarName name) = T.concat $ intersperse (T.singleton '.') name unpackVarName :: VarName -> String unpackVarName = T.unpack . textVarName -data StringExpr = StringExpr [Either Text VarName] -evalStringExpr :: MonadEval m => StringExpr -> m Text -evalStringExpr (StringExpr xs) = fmap T.concat $ forM xs $ \case - Left text -> return text - Right var -> lookupStringVar var +data Expr a where + StringVar :: VarName -> Expr Text + StringLit :: Text -> Expr Text + Concat :: [Expr Text] -> Expr Text + Regex :: [Expr Text] -> Expr Regex -data RegexExpr = RegexExpr [Either String VarName] - -evalRegexExpr :: (MonadFail m, MonadEval m) => RegexExpr -> m Regex -evalRegexExpr (RegexExpr xs) = do +eval :: MonadEval m => Expr a -> m a +eval (StringVar var) = lookupStringVar var +eval (StringLit str) = return str +eval (Concat xs) = T.concat <$> mapM eval xs +eval (Regex xs) = do parts <- forM xs $ \case - Left str -> return str - Right var -> concatMap (\c -> ['\\',c]) . T.unpack <$> lookupStringVar var - case compile defaultCompOpt defaultExecOpt $ concat $ concat [["^"], parts, ["$"]] of + StringLit str -> return str + expr -> T.concatMap (\c -> T.pack ['\\', c]) <$> eval expr + case compile defaultCompOpt defaultExecOpt $ T.concat $ concat [[T.singleton '^'], parts, [T.singleton '$']] of Left err -> fail err Right re -> return re |