diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Parser.hs | 37 | ||||
| -rw-r--r-- | src/Test.hs | 8 |
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 |