[commit: ghc] master: Build the substitution correctly in piResultTy (dbf72db)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/dbf72dbc6e49b3db7f2337a7a41e95c1d0169163/ghc

>---------------------------------------------------------------

commit dbf72dbc6e49b3db7f2337a7a41e95c1d0169163
Author: Bartosz Nitka <niteria at gmail.com>
Date:   Thu Feb 11 09:44:53 2016 -0800

    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: https://phabricator.haskell.org/D1855
    
    GHC Trac Issues: #11371


>---------------------------------------------------------------

dbf72dbc6e49b3db7f2337a7a41e95c1d0169163
 compiler/types/Type.hs | 26 ++++++++++++++++++++------
 1 file changed, 20 insertions(+), 6 deletions(-)

diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 67365e3..a649700 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -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
+  where
+    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