Refactor expressions as GADT

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