From 92c763ad490accaec833ccf7a4775a5a3d4d078a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 7 May 2023 10:33:36 +0200
Subject: Show record selectors in failure reports

Changelog: Show record selectors in failure reports
---
 src/Parser/Expr.hs |  6 +++---
 src/Run.hs         |  4 ++--
 src/Test.hs        | 32 ++++++++++++++++++++++++--------
 3 files changed, 29 insertions(+), 13 deletions(-)

(limited to 'src')

diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index eefc5cc..70649b2 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -289,10 +289,10 @@ someExpr = join inner <?> "expression"
             SomeExpr e <- p
             let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
                     [ T.pack "value of type ", textExprType e, T.pack " does not have member '", m, T.pack "'" ]
-            maybe err return $ applyRecordSelector e <$> lookup m recordMembers
+            maybe err return $ applyRecordSelector m e <$> lookup m recordMembers
 
-    applyRecordSelector :: ExprType a => Expr a -> RecordSelector a -> SomeExpr
-    applyRecordSelector e (RecordSelector f) = SomeExpr $ f <$> e
+    applyRecordSelector :: ExprType a => Text -> Expr a -> RecordSelector a -> SomeExpr
+    applyRecordSelector m e (RecordSelector f) = SomeExpr $ App (AnnRecord m) (pure f) e
 
     literal = label "literal" $ choice
         [ return <$> numberLiteral
diff --git a/src/Run.hs b/src/Run.hs
index 01c4a03..26cc34f 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -266,8 +266,8 @@ exprFailed desc (SourceLine sline) pname expr = do
     let prompt = maybe T.empty textProcName pname
     exprVars <- gatherVars expr
     outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", sline]
-    forM_ exprVars $ \(name, value) ->
-        outLine OutputMatchFail (Just prompt) $ T.concat [T.pack "  ", textVarName name, T.pack " = ", textSomeVarValue value]
+    forM_ exprVars $ \((name, sel), value) ->
+        outLine OutputMatchFail (Just prompt) $ T.concat ["  ", textVarName name, T.concat (map ("."<>) sel), " = ", textSomeVarValue value]
     throwError Failed
 
 expect :: SourceLine -> Process -> Expr Regex -> [TypedVarName Text] -> TestRun () -> TestRun ()
diff --git a/src/Test.hs b/src/Test.hs
index 398fa03..e336858 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -11,6 +11,7 @@ module Test (
     ExprListUnpacker(..),
     ExprEnumerator(..),
     Expr(..), eval, gatherVars,
+    AppAnnotation(..),
 
     Regex(RegexPart, RegexString), regexMatch,
 ) where
@@ -137,22 +138,25 @@ data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a])
 data Expr a where
     Variable :: ExprType a => VarName -> Expr a
     Pure :: a -> Expr a
-    App :: Expr (a -> b) -> Expr a -> Expr b
+    App :: AppAnnotation b -> Expr (a -> b) -> Expr a -> Expr b
     Concat :: [Expr Text] -> Expr Text
     Regex :: [Expr Regex] -> Expr Regex
     RootNetwork :: Expr Network
 
+data AppAnnotation b = AnnNone
+                     | ExprType b => AnnRecord Text
+
 instance Functor Expr where
-    fmap f x = Pure f `App` x
+    fmap f x = Pure f <*> x
 
 instance Applicative Expr where
     pure = Pure
-    (<*>) = App
+    (<*>) = App AnnNone
 
 eval :: MonadEval m => Expr a -> m a
 eval (Variable name) = fromSomeVarValue name =<< lookupVar name
 eval (Pure value) = return value
-eval (App f x) = eval f <*> eval x
+eval (App _ f x) = eval f <*> eval x
 eval (Concat xs) = T.concat <$> mapM eval xs
 eval (Regex xs) = mapM eval xs >>= \case
     [re@RegexCompiled {}] -> return re
@@ -161,17 +165,29 @@ eval (Regex xs) = mapM eval xs >>= \case
         Right re -> return re
 eval (RootNetwork) = rootNetwork
 
-gatherVars :: forall a m. MonadEval m => Expr a -> m [(VarName, SomeVarValue)]
+gatherVars :: forall a m. MonadEval m => Expr a -> m [((VarName, [Text]), SomeVarValue)]
 gatherVars = fmap (uniqOn fst . sortOn fst) . helper
   where
-    helper :: forall b. Expr b -> m [(VarName, SomeVarValue)]
-    helper (Variable var) = (:[]) . (var,) <$> lookupVar var
+    helper :: forall b. Expr b -> m [((VarName, [Text]), SomeVarValue)]
+    helper (Variable var) = (:[]) . ((var, []),) <$> lookupVar var
     helper (Pure _) = return []
-    helper (App f x) = (++) <$> helper f <*> helper x
+    helper e@(App (AnnRecord sel) _ x)
+        | Just (var, sels) <- gatherSelectors x
+        = do val <- SomeVarValue <$> eval e
+             return [((var, sels ++ [sel]), val)]
+        | otherwise = helper x
+    helper (App _ f x) = (++) <$> helper f <*> helper x
     helper (Concat es) = concat <$> mapM helper es
     helper (Regex es) = concat <$> mapM helper es
     helper (RootNetwork) = return []
 
+    gatherSelectors :: forall b. Expr b -> Maybe (VarName, [Text])
+    gatherSelectors = \case
+        Variable var -> Just (var, [])
+        App (AnnRecord sel) _ x -> do
+            (var, sels) <- gatherSelectors x
+            return (var, sels ++ [sel])
+        _ -> Nothing
 
 data Regex = RegexCompiled Text RE.Regex
            | RegexPart Text
-- 
cgit v1.2.3