Polymorphic types in function arguments

5 files changed, 45 insertions, 35 deletions

diff --git a/src/Parser.hs b/src/Parser.hs
index 191d40d..e3d174e 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -101,19 +101,9 @@ parseDefinition href = label "symbol definition" $ do
     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) )
-        let getConcreteType = \case
-                (ExprTypeApp (ExprTypeConstr1 (Proxy :: Proxy a)) [ pb ])
-                    | ExprTypePrim (_ :: Proxy b) <- getConcreteType pb
-                    -> ExprTypePrim (Proxy :: Proxy (a b))
-                t -> t
+                return ( vname, SomeArgumentType OptionalArgument (ExprTypeForall (TypeVar "a") (ExprTypeVar (TypeVar "a"))) )
         gets (M.lookup tvar . testTypeUnif) >>= \case
-            Just t
-                | ExprTypePrim (_ :: Proxy a) <- getConcreteType t
-                -> return ( vname, SomeArgumentType (RequiredArgument @a) )
-
-                | otherwise
-                -> err $ "expected concrete type for ‘" <> textVarName vname <> " : " <> textSomeExprType t <> "’"
+            Just t -> return ( vname, SomeArgumentType RequiredArgument t )
             Nothing -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvarname <> "’"
 
     replaceDynArgs :: forall a. Expr a -> TestParser (Expr a)
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)
diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs
index 06eb9f6..bbb6083 100644
--- a/src/Script/Expr.hs
+++ b/src/Script/Expr.hs
@@ -457,12 +457,12 @@ exprArgs = \case
     App {} -> error "exprArgs: app"
     Undefined {} -> error "exprArgs: undefined"
 
-data SomeArgumentType = forall a. ExprType a => SomeArgumentType (ArgumentType a)
+data SomeArgumentType = SomeArgumentType ArgumentType SomeExprType
 
-data ArgumentType a
+data ArgumentType
     = RequiredArgument
     | OptionalArgument
-    | ExprDefault (Expr a)
+    | ExprDefault SomeExpr
     | ContextDefault
 
 
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index 4ad6049..32483d1 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -40,8 +40,8 @@ builtinSend = SomeExpr $ ArgsReq (biArgs atypes) $
     FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Send <$> biVar "$to" <*> biVar "$0")
   where
     atypes =
-        [ ( Just "to", SomeArgumentType (ContextDefault @Process) )
-        , ( Nothing, SomeArgumentType (RequiredArgument @Text) )
+        [ ( Just "to", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) )
+        , ( Nothing, SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Text)) )
         ]
 
 builtinFlush :: SomeExpr
@@ -49,8 +49,8 @@ builtinFlush = SomeExpr $ ArgsReq (biArgs atypes) $
     FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Flush <$> biVar "$from" <*> biOpt "$matching")
   where
     atypes =
-        [ ( Just "from", SomeArgumentType (ContextDefault @Process) )
-        , ( Just "matching", SomeArgumentType (OptionalArgument @Regex) )
+        [ ( Just "from", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) )
+        , ( Just "matching", SomeArgumentType OptionalArgument (ExprTypePrim (Proxy @Regex)) )
         ]
 
 builtinIgnore :: SomeExpr
@@ -58,17 +58,17 @@ builtinIgnore = SomeExpr $ ArgsReq (biArgs atypes) $
     FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (CreateObject (Proxy @IgnoreProcessOutput) <$> ((,) <$> biVar "$from" <*> biOpt "$matching"))
   where
     atypes =
-        [ ( Just "from", SomeArgumentType (ContextDefault @Process) )
-        , ( Just "matching", SomeArgumentType (OptionalArgument @Regex) )
+        [ ( Just "from", SomeArgumentType ContextDefault (ExprTypePrim (Proxy @Process)) )
+        , ( Just "matching", SomeArgumentType OptionalArgument (ExprTypePrim (Proxy @Regex)) )
         ]
 
 builtinGuard :: SomeExpr
 builtinGuard = SomeExpr $
-    ArgsReq (biArgs [ ( Nothing, SomeArgumentType (RequiredArgument @Bool) ) ]) $
+    ArgsReq (biArgs [ ( Nothing, SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Bool)) ) ]) $
     FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (Guard <$> Variable SourceLineBuiltin callStackFqVarName <*> biVar "$0")
 
 builtinMultiplyTimeout :: SomeExpr
-builtinMultiplyTimeout = SomeExpr $ ArgsReq (biArgs $ [ ( Just "by", SomeArgumentType (RequiredArgument @Scientific) ) ]) $
+builtinMultiplyTimeout = SomeExpr $ ArgsReq (biArgs $ [ ( Just "by", SomeArgumentType RequiredArgument (ExprTypePrim (Proxy @Scientific)) ) ]) $
     FunctionAbstraction $ TestBlockStep EmptyTestBlock <$> (CreateObject (Proxy @MultiplyTimeout) <$> biVar "$by")
 
 builtinWait :: SomeExpr