From 51d78df83fc69df8e54cb72212a91576da8bf5b0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Thu, 5 Dec 2024 22:14:21 +0100
Subject: Arguments for user-defined functions

---
 src/Parser.hs | 36 ++++++++++++++++++++++++++++++++++--
 1 file changed, 34 insertions(+), 2 deletions(-)

(limited to 'src/Parser.hs')

diff --git a/src/Parser.hs b/src/Parser.hs
index ab44833..940bd60 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -9,6 +9,7 @@ import Control.Monad.State
 
 import Data.Map qualified as M
 import Data.Maybe
+import Data.Proxy
 import Data.Set qualified as S
 import Data.Text qualified as T
 import Data.Text.Lazy qualified as TL
@@ -41,15 +42,46 @@ parseDefinition = label "symbol definition" $ toplevel ToplevelDefinition $ do
     def <- localState $ L.indentBlock scn $ do
         wsymbol "def"
         name <- varName
+        argsDecl <- functionArguments (\off _ -> return . ( off, )) varName mzero (\_ -> return . VarName)
+        atypes <- forM argsDecl $ \( off, vname :: VarName ) -> do
+            tvar <- newTypeVar
+            modify $ \s -> s { testVars = ( vname, ExprTypeVar tvar ) : testVars s }
+            return ( off, vname, tvar )
         choice
             [ do
-                symbol ":"
+                osymbol ":"
                 let finish steps = do
-                        return $ ( name, SomeExpr $ mconcat steps )
+                        atypes' <- getInferredTypes atypes
+                        ( name, ) . SomeExpr . ArgsReq atypes' . FunctionAbstraction <$> replaceDynArgs (mconcat steps)
                 return $ L.IndentSome Nothing finish testStep
             ]
     modify $ \s -> s { testVars = fmap someExprType def : testVars s }
     return def
+  where
+    getInferredTypes atypes = forM atypes $ \( off, vname, tvar@(TypeVar tvarname) ) -> do
+        let err msg = do
+                registerParseError . FancyError off . S.singleton . ErrorFail $ T.unpack msg
+                return ( vname, SomeArgumentType (OptionalArgument @DynamicType) )
+        gets (M.lookup tvar . testTypeUnif) >>= \case
+            Just (ExprTypePrim (_ :: Proxy a)) -> return ( vname, SomeArgumentType (RequiredArgument @a) )
+            Just (ExprTypeVar (TypeVar tvar')) -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvar' <> "’"
+            Just (ExprTypeFunction {}) -> err $ "unsupported function type of ‘" <> textVarName vname <> "’"
+            Nothing -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvarname <> "’"
+
+    replaceDynArgs :: forall a. Expr a -> TestParser (Expr a)
+    replaceDynArgs expr = do
+        unif <- gets testTypeUnif
+        return $ mapExpr (go unif) expr
+      where
+        go :: forall b. M.Map TypeVar SomeExprType -> Expr b -> Expr b
+        go unif = \case
+            ArgsApp args body -> ArgsApp (fmap replaceArgs args) body
+              where
+                replaceArgs (SomeExpr (DynVariable tvar sline vname))
+                    | Just (ExprTypePrim (Proxy :: Proxy v)) <- M.lookup tvar unif
+                    = SomeExpr (Variable sline vname :: Expr v)
+                replaceArgs (SomeExpr e) = SomeExpr (go unif e)
+            e -> e
 
 parseTestModule :: FilePath -> TestParser Module
 parseTestModule absPath = do
-- 
cgit v1.2.3