From 81d6d9f99ce8ea56df2c926156a3e3600a1a4117 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sat, 25 Apr 2026 10:51:21 +0200
Subject: Polymorphic types in function arguments

---
 src/Parser/Core.hs | 34 +++++++++++++++++++++++++++-------
 src/Parser/Expr.hs | 10 +++++-----
 2 files changed, 32 insertions(+), 12 deletions(-)

(limited to 'src/Parser')

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)
-- 
cgit v1.2.3