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/Test.hs | 32 ++++++++++++++++++++++++--------
 1 file changed, 24 insertions(+), 8 deletions(-)

(limited to 'src/Test.hs')

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