Maintain in-scope set in deeply_instantiate (fixes #12549).

Maintain in-scope set in deeply_instantiate (Fixes T12549).

lint fixes

Test Plan: validate

Reviewers: simonpj, austin, goldfire, bgamari

Reviewed By: simonpj, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2757

GHC Trac Issues: #12549

5 files changed, 42 insertions, 9 deletions

diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
index 0a50de48b0..5015913880 100644
--- a/compiler/typecheck/Inst.hs
+++ b/compiler/typecheck/Inst.hs
@@ -227,27 +227,45 @@ deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
 -- then  wrap e :: rho
 -- That is, wrap :: ty ~> rho
 
-deeplyInstantiate orig ty
+deeplyInstantiate orig ty =
+  deeply_instantiate orig
+                     (mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)))
+                     ty
+
+deeply_instantiate :: CtOrigin
+                   -> TCvSubst
+                   -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
+-- Internal function to deeply instantiate that builds on an existing subst.
+-- It extends the input substitution and applies the final subtitution to
+-- the types on return.  See #12549.
+
+deeply_instantiate orig subst ty
   | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
-  = do { (subst, tvs') <- newMetaTyVars tvs
-       ; ids1  <- newSysLocalIds (fsLit "di") (substTysUnchecked subst arg_tys)
-       ; let theta' = substThetaUnchecked subst theta
+  = do { (subst', tvs') <- newMetaTyVarsX subst tvs
+       ; ids1  <- newSysLocalIds (fsLit "di") (substTys subst' arg_tys)
+       ; let theta' = substTheta subst' theta
        ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'
        ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig
                                                 , text "type" <+> ppr ty
                                                 , text "with" <+> ppr tvs'
                                                 , text "args:" <+> ppr ids1
                                                 , text "theta:" <+>  ppr theta'
-                                                , text "subst:" <+> ppr subst ])
-       ; (wrap2, rho2) <- deeplyInstantiate orig (substTyUnchecked subst rho)
+                                                , text "subst:" <+> ppr subst'])
+       ; (wrap2, rho2) <- deeply_instantiate orig subst' rho
        ; return (mkWpLams ids1
                     <.> wrap2
                     <.> wrap1
                     <.> mkWpEvVarApps ids1,
                  mkFunTys arg_tys rho2) }
 
-  | otherwise = return (idHsWrapper, ty)
-
+  | otherwise
+  = do { let ty' = substTy subst ty
+       ; traceTc "deeply_instantiate final subst"
+                 (vcat [ text "origin:"   <+> pprCtOrigin orig
+                       , text "type:"     <+> ppr ty
+                       , text "new type:" <+> ppr ty'
+                       , text "subst:"    <+> ppr subst ])
+      ; return (idHsWrapper, ty') }
 
 {-
 ************************************************************************
diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs
index b5104a1a32..2e9a7a7d05 100644
--- a/compiler/typecheck/TcMType.hs
+++ b/compiler/typecheck/TcMType.hs
@@ -53,7 +53,7 @@ module TcMType (
 
   --------------------------------
   -- Instantiation
-  newMetaTyVars, newMetaTyVarX,
+  newMetaTyVars, newMetaTyVarX, newMetaTyVarsX,
   newMetaSigTyVars, newMetaSigTyVarX,
   newSigTyVar, newWildCardX,
   tcInstType,
@@ -811,6 +811,10 @@ newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
 -- an existing TyVar. We substitute kind variables in the kind.
 newMetaTyVarX subst tyvar = new_meta_tv_x TauTv subst tyvar
 
+newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- Just like newMetaTyVars, but start with an existing substitution.
+newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst
+
 newMetaSigTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
 -- Just like newMetaTyVarX, but make a SigTv
 newMetaSigTyVarX subst tyvar = new_meta_tv_x SigTv subst tyvar
@@ -827,6 +831,10 @@ new_meta_tv_x info subst tv
         ; let name   = mkSystemName uniq (getOccName tv)
                        -- See Note [Name of an instantiated type variable]
               kind   = substTyUnchecked subst (tyVarKind tv)
+                       -- NOTE: Trac #12549 is fixed so we could use
+                       -- substTy here, but the tc_infer_args problem
+                       -- is not yet fixed so leaving as unchecked for now.
+                       -- OLD NOTE:
                        -- Unchecked because we call newMetaTyVarX from
                        -- tcInstBinderX, which is called from tc_infer_args
                        -- which does not yet take enough trouble to ensure
diff --git a/testsuite/tests/ghci/should_run/T12549.script b/testsuite/tests/ghci/should_run/T12549.script
new file mode 100644
index 0000000000..012517fd6d
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T12549.script
@@ -0,0 +1,3 @@
+:set -XPolyKinds
+class C a where f :: a b c
+:t f
diff --git a/testsuite/tests/ghci/should_run/T12549.stdout b/testsuite/tests/ghci/should_run/T12549.stdout
new file mode 100644
index 0000000000..fd0a45c46b
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T12549.stdout
@@ -0,0 +1,3 @@
+f :: forall k1 k2 (b :: k1) (a :: k1 -> k2 -> *) (c :: k2).
+     C a =>
+     a b c
diff --git a/testsuite/tests/ghci/should_run/all.T b/testsuite/tests/ghci/should_run/all.T
index b6aa2e9da0..3dc05ce31c 100644
--- a/testsuite/tests/ghci/should_run/all.T
+++ b/testsuite/tests/ghci/should_run/all.T
@@ -26,3 +26,4 @@ test('T11328',     just_ghci, ghci_script, ['T11328.script'])
 test('T11825',     just_ghci, ghci_script, ['T11825.script'])
 test('T12128',     just_ghci, ghci_script, ['T12128.script'])
 test('T12456',     just_ghci, ghci_script, ['T12456.script'])
+test('T12549',     just_ghci, ghci_script, ['T12549.script'])