From f8c6706d5eefb8e4ebcdee7c963e8fe22fd9efab Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sat, 18 Feb 2023 22:56:31 +0100
Subject: Equality operator for lists

---
 src/Parser.hs | 37 +++++++++++++++++++++++++++++++++----
 src/Test.hs   |  8 ++++++++
 2 files changed, 41 insertions(+), 4 deletions(-)

(limited to 'src')

diff --git a/src/Parser.hs b/src/Parser.hs
index 51fc0f0..19a1cf0 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -273,11 +273,13 @@ someExpr = join inner <?> "expression"
                              , SomeBinOp ((-) @Scientific)
                              ]
               ]
-            , [ binary "==" $ [ SomeBinOp ((==) @Integer)
+            , [ binary' "==" (\op xs ys -> length xs == length ys && and (zipWith op xs ys)) $
+                              [ SomeBinOp ((==) @Integer)
                               , SomeBinOp ((==) @Scientific)
                               , SomeBinOp ((==) @Text)
                               ]
-              , binary "/=" $ [ SomeBinOp ((/=) @Integer)
+              , binary' "/=" (\op xs ys -> length xs /= length ys || or  (zipWith op xs ys)) $
+                              [ SomeBinOp ((/=) @Integer)
                               , SomeBinOp ((/=) @Scientific)
                               , SomeBinOp ((/=) @Text)
                               ]
@@ -295,15 +297,42 @@ someExpr = join inner <?> "expression"
             maybe err return $ listToMaybe $ catMaybes $ map (\(SomeUnOp op) -> SomeExpr <$> applyUnOp op e) ops
 
     binary :: String -> [SomeBinOp] -> Operator TestParser (TestParser SomeExpr)
-    binary name ops = InfixL $ do
+    binary name = binary' name (undefined :: forall a b. (a -> b -> Void) -> [a] -> [b] -> Integer)
+      -- use 'Void' that can never match actually used type to disable recursion
+
+    binary' :: forall c c'. (Typeable c, ExprType c')
+            => String
+            -> (forall a b. (a -> b -> c) -> [a] -> [b] -> c')
+            -> [SomeBinOp]
+            -> Operator TestParser (TestParser SomeExpr)
+    binary' name listmap ops = InfixL $ do
         off <- stateOffset <$> getParserState
         void $ osymbol name
+
         return $ \p q -> do
             SomeExpr e <- p
             SomeExpr f <- q
+
+            let eqT' :: forall r s t. (Typeable r, Typeable s, Typeable t) => (r -> s -> t) -> Maybe ((r -> s -> t) :~: (r -> s -> c))
+                eqT' _ = eqT
+
+            let proxyOf :: proxy a -> Proxy a
+                proxyOf _ = Proxy
+
+            let tryop :: forall a b d sa sb.
+                    (ExprType a, ExprType b, ExprType d, ExprType sa, ExprType sb) =>
+                    (a -> b -> d) -> Proxy sa -> Proxy sb -> Maybe SomeExpr
+                tryop op pe pf = msum
+                    [ SomeExpr <$> applyBinOp op e f
+                    , do Refl <- eqT' op
+                         ExprListUnpacker _ une <- exprListUnpacker pe
+                         ExprListUnpacker _ unf <- exprListUnpacker pf
+                         tryop (listmap op) (une pe) (unf pf)
+                    ]
+
             let err = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ T.concat
                     [T.pack "operator '", T.pack name, T.pack "' not defined for '", textExprType e, T.pack "' and '", textExprType f, T.pack "'"]
-            maybe err return $ listToMaybe $ catMaybes $ map (\(SomeBinOp op) -> SomeExpr <$> applyBinOp op e f) ops
+            maybe err return $ listToMaybe $ catMaybes $ map (\(SomeBinOp op) -> tryop op (proxyOf e) (proxyOf f)) ops
 
     recordSelector :: Operator TestParser (TestParser SomeExpr)
     recordSelector = Postfix $ fmap (foldl1 (flip (.))) $ some $ do
diff --git a/src/Test.hs b/src/Test.hs
index b6a85ae..88be0dc 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -8,6 +8,7 @@ module Test (
     ExprType(..),
     SomeVarValue(..), fromSomeVarValue, textSomeVarValue,
     RecordSelector(..),
+    ExprListUnpacker(..),
     Expr(..), eval, gatherVars,
 
     Regex(RegexPart, RegexString), regexMatch,
@@ -70,6 +71,9 @@ class Typeable a => ExprType a where
     recordMembers :: [(Text, RecordSelector a)]
     recordMembers = []
 
+    exprListUnpacker :: proxy a -> Maybe (ExprListUnpacker a)
+    exprListUnpacker _ = Nothing
+
 instance ExprType Integer where
     textExprType _ = T.pack "integer"
     textExprValue x = T.pack (show x)
@@ -101,6 +105,8 @@ instance ExprType a => ExprType [a] where
     textExprValue x = "[" <> T.intercalate ", " (map textExprValue x) <> "]"
     emptyVarValue = []
 
+    exprListUnpacker _ = Just $ ExprListUnpacker id (const Proxy)
+
 data SomeVarValue = forall a. ExprType a => SomeVarValue a
 
 data RecordSelector a = forall b. ExprType b => RecordSelector (a -> b)
@@ -112,6 +118,8 @@ fromSomeVarValue name (SomeVarValue value) = maybe (fail err) return $ cast valu
 textSomeVarValue :: SomeVarValue -> Text
 textSomeVarValue (SomeVarValue value) = textExprValue value
 
+data ExprListUnpacker a = forall e. ExprType e => ExprListUnpacker (a -> [e]) (Proxy a -> Proxy e)
+
 
 data Expr a where
     Variable :: ExprType a => VarName -> Expr a
-- 
cgit v1.2.3