Commit dbf72dbc authored by niteria's avatar niteria
Browse files

Build the substitution correctly in piResultTy

This fixes a bug where piResultTy created
substitutions that would violate both of the invariants
in Note [The substitution invariant].

Test Plan: ./validate --slow

Reviewers: goldfire, simonpj, austin, bgamari

Reviewed By: simonpj, bgamari

Subscribers: simonmar, thomie

Differential Revision:

GHC Trac Issues: #11371
parent efba41e2
......@@ -801,15 +801,29 @@ funResultTy ty = piResultTy ty (pprPanic "funResultTy" (ppr ty))
-- | Essentially 'funResultTy' on kinds handling pi-types too
piResultTy :: Type -> Type -> Type
piResultTy ty arg | Just ty' <- coreView ty = piResultTy ty' arg
piResultTy (ForAllTy (Anon _) res) _ = res
piResultTy (ForAllTy (Named tv _) res) arg = substTyWithUnchecked [tv] [arg] res
piResultTy ty arg = pprPanic "piResultTy"
(ppr ty $$ ppr arg)
piResultTy ty arg = piResultTys ty [arg]
-- | Fold 'piResultTy' over many types
piResultTys :: Type -> [Type] -> Type
piResultTys = foldl piResultTy
piResultTys ty args = go empty_subst ty args
empty_subst = mkEmptyTCvSubst (mkInScopeSet $ tyCoVarsOfTypes (ty:args))
-- The free vars of 'ty' and 'args' need to be in scope to satisfy the
-- invariant in Note [The substitution invariant] in TyCoRep.
go subst ty [] = substTy subst ty
go subst ty args@(arg:args')
| Just (bndr, res) <- splitPiTy_maybe ty
= case bndr of
Anon _ -> go subst res args'
Named tv _ -> go (extendTCvSubst subst tv arg) res args'
| Just tv <- getTyVar_maybe ty
-- Deals with piResultTys (forall a. a) [forall b.b, Int]
= go empty_subst (substTyVar subst tv) args
| otherwise
= panic "piResultTys"
funArgTy :: Type -> Type
-- ^ Extract the function argument type and panic if that is not possible
Supports Markdown
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