summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Parser.hs14
-rw-r--r--src/Parser/Core.hs34
-rw-r--r--src/Parser/Expr.hs10
-rw-r--r--src/Script/Expr.hs6
-rw-r--r--src/Test/Builtins.hs16
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
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-12 23:00:09 +0000