diff options
| author | Roman Smrž <roman.smrz@seznam.cz> | 2026-04-12 11:39:29 +0200 |
|---|---|---|
| committer | Roman Smrž <roman.smrz@seznam.cz> | 2026-04-12 14:05:29 +0200 |
| commit | 3a6faf446c2e62add01c5d912a533f20e853ac77 (patch) | |
| tree | b700d72535e9b23e8ec2e57c71a52449d3c26b16 /src/Parser.hs | |
| parent | cd2e1323ef62574f0879e789457248c68ee46326 (diff) | |
Type constructors
Diffstat (limited to 'src/Parser.hs')
| -rw-r--r-- | src/Parser.hs | 14 |
1 files changed, 11 insertions, 3 deletions
diff --git a/src/Parser.hs b/src/Parser.hs index bb8288e..e38f1ef 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -102,10 +102,18 @@ parseDefinition href = label "symbol definition" $ 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 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 <> "’" + Just t + | ExprTypePrim (_ :: Proxy a) <- getConcreteType t + -> return ( vname, SomeArgumentType (RequiredArgument @a) ) + + | otherwise + -> err $ "expected concrete type for ‘" <> textVarName vname <> " : " <> textSomeExprType t <> "’" Nothing -> err $ "ambiguous type for ‘" <> textVarName vname <> " : " <> tvarname <> "’" replaceDynArgs :: forall a. Expr a -> TestParser (Expr a) |