diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Parser/Expr.hs | 24 |
1 files changed, 24 insertions, 0 deletions
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs index 7d57791..a0ae70d 100644 --- a/src/Parser/Expr.hs +++ b/src/Parser/Expr.hs @@ -302,6 +302,19 @@ someExpr complexity = label "expression" $ do , SomeBinOp ((-) @Scientific) ] ] + , [ let tvar = TypeVar "a" + targs = FunctionArguments $ M.fromList + [ ( Just "$l", ( VarName "$l", SomeArgumentType RequiredArgument $ ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ]) ) + , ( Just "$r", ( VarName "$r", SomeArgumentType RequiredArgument $ ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ]) ) + ] + in infixrExpr "++" $ SomeExpr $ TypeLambda tvar (ExprTypeFunction (ExprTypeArguments $ fmap snd targs) (ExprTypeApp (ExprTypeConstr1 (Proxy @[])) [ ExprTypeVar tvar ])) $ \case + ExprTypePrim (Proxy :: Proxy a) -> + HideFunType (fmap snd targs) $ ArgsReq targs $ + FunctionAbstraction $ ((++) @a) + <$> (Variable SourceLineBuiltin $ LocalVarName $ VarName "$l") + <*> (Variable SourceLineBuiltin $ LocalVarName $ VarName "$r") + t -> Undefined ("ambiguous type ‘" <> T.unpack (textSomeExprType t) <> "’ for operator ‘++’") :: Expr DynamicType + ] , [ binary' "==" (\op xs ys -> length xs == length ys && and (zipWith op xs ys)) $ [ SomeBinOp ((==) @Integer) , SomeBinOp ((==) @Scientific) @@ -345,6 +358,17 @@ someExpr complexity = label "expression" $ do choice $ map (\(SomeUnOp op) -> SomeExpr <$> applyUnOp off op e) ops + infixrExpr :: String -> SomeExpr -> Operator TestParser (TestParser SomeExpr) + infixrExpr name fun = InfixR $ do + void $ osymbol name + return $ \p q -> do + loff <- stateOffset <$> getParserState + l <- p + roff <- stateOffset <$> getParserState + r <- q + applyFunctionArguments (FunctionArguments $ M.fromList [ ( Just "$l", ( loff, l ) ), ( Just "$r", ( roff, r ) ) ]) fun + + binary :: String -> [SomeBinOp] -> Operator TestParser (TestParser SomeExpr) 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 |