[commit: ghc] master: Maintain in-scope set in deeply_instantiate (fixes #12549). (2350906)
git at git.haskell.org
git at git.haskell.org
Fri Dec 2 20:29:34 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/2350906bfb496758d81caf3b66b232e1950285e9/ghc
>---------------------------------------------------------------
commit 2350906bfb496758d81caf3b66b232e1950285e9
Author: John Leo <leo at halfaya.org>
Date: Fri Dec 2 14:33:12 2016 -0500
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
>---------------------------------------------------------------
2350906bfb496758d81caf3b66b232e1950285e9
compiler/typecheck/Inst.hs | 34 ++++++++++++++++++++-------
compiler/typecheck/TcMType.hs | 10 +++++++-
testsuite/tests/ghci/should_run/T12549.script | 3 +++
testsuite/tests/ghci/should_run/T12549.stdout | 3 +++
testsuite/tests/ghci/should_run/all.T | 1 +
5 files changed, 42 insertions(+), 9 deletions(-)
diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
index 0a50de4..5015913 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 b5104a1..2e9a7a7 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 0000000..012517f
--- /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 0000000..fd0a45c
--- /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 b6aa2e9..3dc05ce 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'])
More information about the ghc-commits
mailing list