Commit 6320398c authored by Kai-Oliver Prott's avatar Kai-Oliver Prott

Correct typing of functional patterns

parent 927f1fbb
......@@ -1155,6 +1155,7 @@ tcPatternHelper _ t@(RecordPattern spi _ c fs) = do
m <- lift getModuleIdent
vEnv <- lift getValueEnv
(ps, ty) <- fmap arrowBase <$> lift (inst (constrType m c vEnv))
-- tcField does not support passing "used" variables, thus we do it by hand
used <- S.get
(ps', fs') <- lift $ mapAccumM (tcField (tcPatternWith used) "pattern"
(\t' -> pPrintPrec 0 t $-$ text "Term:" <+> pPrintPrec 0 t') ty) ps fs
......@@ -1182,6 +1183,8 @@ tcPatternHelper p t@(FunctionPattern spi _ f ts) = do
m <- lift getModuleIdent
vEnv <- lift getValueEnv
(ps, ty) <- lift $ inst (snd $ funType m f vEnv)
-- insert all
S.modify (flip (foldr Set.insert) (bv t))
tcFuncPattern p spi (pPrintPrec 0 t) f id ps ty ts
tcPatternHelper p (InfixFuncPattern spi a t1 op t2) = do
(ps, ty, t') <- tcPatternHelper p (FunctionPattern spi a op [t1, t2])
......@@ -1197,9 +1200,8 @@ tcFuncPattern _ spi _ f ts ps ty [] =
tcFuncPattern p spi doc f ts ps ty (t':ts') = do
(alpha, beta) <- lift $
tcArrow p "functional pattern" (doc $-$ text "Term:" <+> pPrintPrec 0 t) ty
let ps' = Set.insert (Pred qDataId alpha) ps
(ps'', t'') <- ptcPatternArg p "functional pattern" doc ps' alpha t'
tcFuncPattern p spi doc f (ts . (t'' :)) ps'' beta ts'
(ps', t'') <- ptcPatternArg p "functional pattern" doc ps alpha t'
tcFuncPattern p spi doc f (ts . (t'' :)) ps' beta ts'
where t = FunctionPattern spi ty f (ts [])
ptcPatternArg :: HasPosition p => p -> String -> Doc -> PredSet -> Type
......
......@@ -270,7 +270,7 @@ failInfos = map (uncurry mkFailTest)
, ("PragmaError", ["Unknown language extension"])
, ("PrecedenceRange", ["Precedence out of range"])
, ("RankNTypes", ["Arbitrary-rank types are not supported in standard Curry."])
, ("RankNTypesFuncPats", ["Missing instance for Prelude.Data (Prelude.Int ->"])
, ("RankNTypesFuncPats", ["Missing instance for Prelude.Data (forall c . Prelude.Int ->"])
, ("RecordLabelIDs", ["Multiple declarations of `RecordLabelIDs.id'"])
, ("RecursiveTypeSyn", ["Mutually recursive synonym and/or renaming types A and B (line 12.6)"])
, ("Subsumption",
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment