From ff46d84b08fed346156c1b67478d4090a0b83f7d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Wed, 10 Aug 2022 23:36:32 +0200
Subject: Integer expressions and variables

---
 src/Test.hs | 53 +++++++++++++++++++++++++++++++++++++++++------------
 1 file changed, 41 insertions(+), 12 deletions(-)

(limited to 'src/Test.hs')

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
-- 
cgit v1.2.3