summaryrefslogtreecommitdiff
path: root/src/Parser
diff options
context:
space:
mode:
Diffstat (limited to 'src/Parser')
-rw-r--r--src/Parser/Core.hs34
-rw-r--r--src/Parser/Expr.hs10
2 files changed, 32 insertions, 12 deletions
diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index f2445a2..4c49ead 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -232,18 +232,19 @@ unifyExpr off pa expr = if
| Just (Refl :: FunctionType a :~: b) <- eqT
-> do
let FunctionArguments remaining = exprArgs expr
- showType ( Nothing, SomeArgumentType atype ) = "`<" <> textExprType atype <> ">'"
- showType ( Just (ArgumentKeyword kw), SomeArgumentType atype ) = "`" <> kw <> " <" <> textExprType atype <> ">'"
+ showType ( Nothing, SomeArgumentType _ stype ) = "‘<" <> textSomeExprType stype <> ">’"
+ showType ( Just (ArgumentKeyword kw), SomeArgumentType _ stype ) = "‘" <> kw <> " <" <> textSomeExprType stype <> ">’"
err = parseError . FancyError off . S.singleton . ErrorFail . T.unpack
defaults <- fmap catMaybes $ forM (M.toAscList remaining) $ \case
- arg@(_, SomeArgumentType RequiredArgument) -> err $ "missing " <> showType arg <> " argument"
- (_, SomeArgumentType OptionalArgument) -> return Nothing
- (kw, SomeArgumentType (ExprDefault def)) -> return $ Just ( kw, SomeExpr def )
- (kw, SomeArgumentType atype@ContextDefault) -> do
+ arg@( _, SomeArgumentType RequiredArgument _ ) -> err $ "missing " <> showType arg <> " argument"
+ ( _, SomeArgumentType OptionalArgument _ ) -> return Nothing
+ ( kw, SomeArgumentType (ExprDefault def) _ ) -> return $ Just ( kw, def )
+ ( kw, SomeArgumentType ContextDefault (ExprTypePrim atype) ) -> do
SomeExpr context <- gets testContext
context' <- unifyExpr off atype context
return $ Just ( kw, SomeExpr context' )
+ ( _, SomeArgumentType ContextDefault _ ) -> err "non-primitive context requirement"
sline <- getSourceLine
return (FunctionEval sline $ ArgsApp (FunctionArguments $ M.fromAscList defaults) expr)
@@ -255,7 +256,26 @@ unifyExpr off pa expr = if
| otherwise
-> do
parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
- "couldn't match expected type `" <> textExprType pa <> "' with actual type `" <> textExprType expr <> "'"
+ "couldn't match expected type ‘" <> textExprType pa <> "’ with actual type ‘" <> textExprType expr <> "’"
+
+
+unifySomeExpr :: Int -> SomeExprType -> SomeExpr -> TestParser SomeExpr
+unifySomeExpr off stype sexpr@(SomeExpr expr)
+ | ExprTypePrim pa <- stype
+ = SomeExpr <$> unifyExpr off pa expr
+
+ | ExprTypeConstr1 {} <- stype
+ = parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $ "unification with incomplete type"
+
+ | ExprTypeVar tvar <- stype
+ = do
+ _ <- unify off (ExprTypeVar tvar) (someExprType sexpr)
+ return sexpr
+
+ | otherwise
+ = do
+ parseError $ FancyError off $ S.singleton $ ErrorFail $ T.unpack $
+ "couldn't match expected type ‘" <> textSomeExprType stype <> "’ with actual type ‘" <> textSomeExprType (someExprType sexpr) <> "’"
skipLineComment :: TestParser ()
diff --git a/src/Parser/Expr.hs b/src/Parser/Expr.hs
index 53bd1a1..8d1fe03 100644
--- a/src/Parser/Expr.hs
+++ b/src/Parser/Expr.hs
@@ -426,17 +426,17 @@ recordSelector (SomeExpr expr) = do
checkFunctionArguments :: FunctionArguments SomeArgumentType
-> Int -> Maybe ArgumentKeyword -> SomeExpr -> TestParser SomeExpr
-checkFunctionArguments (FunctionArguments argTypes) poff kw sexpr@(SomeExpr expr) = do
+checkFunctionArguments (FunctionArguments argTypes) poff kw expr = do
case M.lookup kw argTypes of
- Just (SomeArgumentType (_ :: ArgumentType expected)) -> do
- withRecovery (\e -> registerParseError e >> return sexpr) $ do
- SomeExpr <$> unifyExpr poff (Proxy @expected) expr
+ Just (SomeArgumentType _ stype) -> do
+ withRecovery (\e -> registerParseError e >> return expr) $ do
+ unifySomeExpr poff stype expr
Nothing -> do
registerParseError $ FancyError poff $ S.singleton $ ErrorFail $ T.unpack $
case kw of
Just (ArgumentKeyword tkw) -> "unexpected parameter with keyword ‘" <> tkw <> "’"
Nothing -> "unexpected parameter"
- return sexpr
+ return expr
functionArguments :: (Int -> Maybe ArgumentKeyword -> a -> TestParser b) -> TestParser a -> TestParser a -> (Int -> Text -> TestParser a) -> TestParser (FunctionArguments b)