[commit: ghc] wip/T14068: Avoid name capture in setJoinResTy (6a50466)

[git at git.haskell.org]

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

On branch  : wip/T14068
Link       : http://ghc.haskell.org/trac/ghc/changeset/6a5046684f93f1870663119b447fff6baeb7a7c4/ghc

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

commit 6a5046684f93f1870663119b447fff6baeb7a7c4
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Aug 1 22:48:26 2017 -0400

    Avoid name capture in setJoinResTy


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

6a5046684f93f1870663119b447fff6baeb7a7c4
 compiler/types/Type.hs | 22 ++++++++++++++++------
 1 file changed, 16 insertions(+), 6 deletions(-)

diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 50a35b0..c69d4ff 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -2445,11 +2445,21 @@ setJoinResTy :: Int  -- Number of binders to skip
              -> Type -- New type
 -- INVARIANT: If any of the first n binders are foralls, those tyvars cannot
 -- appear in the original result type. See isValidJoinPointType.
+--
+-- When we set the return type under a forall, avoid capture!
 setJoinResTy orig_ar new_res_ty orig_ty
-  = go orig_ar orig_ty
+  = go init_subst orig_ar orig_ty
   where
-    go 0 _  = new_res_ty
-    go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty
-            = mkPiTy arg_bndr (go (n-1) res_ty)
-            | otherwise
-            = pprPanic "setJoinResTy" (ppr orig_ar <+> ppr orig_ty)
+    init_subst :: TCvSubst
+    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType new_res_ty))
+
+    go _     0 _  = new_res_ty
+    go subst n ty
+        | Just (t, ty') <- splitForAllTy_maybe ty
+        , let (subst', t') = substTyVarBndr subst t
+        = mkForAllTy t' Inferred (go subst' (n-1) ty')
+        | Just (arg_ty, ty') <- splitFunTy_maybe ty
+        , let arg_ty' = substTy subst arg_ty
+        = mkFunTy arg_ty' (go subst (n-1) ty')
+        | otherwise
+        = pprPanic "setJoinResTy" (ppr orig_ar <+> ppr orig_ty)