summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2022-06-05 20:58:47 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2022-06-05 20:58:47 +0200
commit202fd8ba096ff5a80102cbec2922eef94061458b (patch)
tree5546acec206cffa4201c6e1d75634ece0347e32f
parent7f9decf5ec9e4d9fbdfad23d7ce438c95bd8a862 (diff)
Refactor expressions as GADT
-rw-r--r--erebos-tester.cabal1
-rw-r--r--src/Main.hs9
-rw-r--r--src/Parser.hs28
-rw-r--r--src/Test.hs37
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