Build the substitution correctly in piResultTy
authorBartosz Nitka <niteria@gmail.com>
Thu, 11 Feb 2016 17:44:53 +0000 (09:44 -0800)
committerBartosz Nitka <niteria@gmail.com>
Thu, 11 Feb 2016 17:45:46 +0000 (09:45 -0800)
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

compiler/types/Type.hs

index 67365e3..a649700 100644 (file)
@@ -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