Commit 2350906b authored by johnleo's avatar johnleo Committed by Ben Gamari
Browse files

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
parent 895a131f
......@@ -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') }
{-
************************************************************************
......
......@@ -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
......
:set -XPolyKinds
class C a where f :: a b c
:t f
f :: forall k1 k2 (b :: k1) (a :: k1 -> k2 -> *) (c :: k2).
C a =>
a b c
......@@ -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'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment