summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2023-02-18 22:56:31 +0100
committerRoman Smrž <roman.smrz@seznam.cz>2023-02-19 21:51:00 +0100
commitf8c6706d5eefb8e4ebcdee7c963e8fe22fd9efab (patch)
tree4823a85427ba6a21b58b48cb5da4bc02b894d99a /src
parent4603b8e9b1d2b99b8286c82d55ac18ba00fe7331 (diff)
Equality operator for lists
Diffstat (limited to 'src')
-rw-r--r--src/Parser.hs37
-rw-r--r--src/Test.hs8
2 files changed, 41 insertions, 4 deletions
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