[commit: ghc] ghc-8.0: Pass InScopeSet to substTy in lintTyApp (1524945)

[git at git.haskell.org]

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

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/1524945eee9e7540be7df482d2d62bdbaebd2872/ghc

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

commit 1524945eee9e7540be7df482d2d62bdbaebd2872
Author: Bartosz Nitka <niteria at gmail.com>
Date:   Thu Jan 21 11:30:07 2016 -0800

    Pass InScopeSet to substTy in lintTyApp
    
    This is the fix proposed in #11371:
    ```
    In other cases, we already have the in-scope set in hand. Example: in
    CoreLint.lintTyApp we find a call to substTyWith. But Lint carries an
    in-scope set, so it would be easy to pass it to substTyWith.
    ```
    
    Test Plan: ./validate --slow (only pre-existing problems)
    
    Reviewers: simonpj, goldfire, austin, nomeata, bgamari
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D1820
    
    GHC Trac Issues: #11371
    
    (cherry picked from commit 01809bcd4c9066244d705360f0d9a3a2176385f4)


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

1524945eee9e7540be7df482d2d62bdbaebd2872
 compiler/coreSyn/CoreLint.hs |  9 ++++++++-
 compiler/types/TyCoRep.hs    | 24 +++++++++++++++++-------
 2 files changed, 25 insertions(+), 8 deletions(-)

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 50ae0bd..5702f93 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -785,7 +785,11 @@ lintTyApp :: OutType -> OutType -> LintM OutType
 lintTyApp fun_ty arg_ty
   | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty
   = do  { lintTyKind tv arg_ty
-        ; return (substTyWith [tv] [arg_ty] body_ty) }
+        ; in_scope <- getInScope
+        -- substTy needs the set of tyvars in scope to avoid generating
+        -- uniques that are already in scope.
+        -- See Note [The subsititution invariant] in TyCoRep
+        ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) }
 
   | otherwise
   = failWithL (mkTyAppMsg fun_ty arg_ty)
@@ -1686,6 +1690,9 @@ updateTCvSubst subst' m
 getTCvSubst :: LintM TCvSubst
 getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs))
 
+getInScope :: LintM InScopeSet
+getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs))
+
 applySubstTy :: InType -> LintM OutType
 applySubstTy ty = do { subst <- getTCvSubst; return (substTy subst ty) }
 
diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs
index 599f9b8..ce3290a 100644
--- a/compiler/types/TyCoRep.hs
+++ b/compiler/types/TyCoRep.hs
@@ -90,7 +90,7 @@ module TyCoRep (
         substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars,
         substCoWith,
         substTy, substTyAddInScope, substTyUnchecked,
-        substTyWithBinders,
+        substTyWithBinders, substTyWithInScope,
         substTys, substTheta,
         lookupTyVar, substTyVarBndr,
         substCo, substCos, substCoVar, substCoVars, lookupCoVar,
@@ -1388,7 +1388,7 @@ data TCvSubst
         -- See Note [Apply Once]
         -- and Note [Extending the TvSubstEnv]
         -- and Note [Substituting types and coercions]
-        -- and Note [Generating the in-scope set for a substitution]
+        -- and Note [The subsititution invariant]
 
 -- | A substitution of 'Type's for 'TyVar's
 --                 and 'Kind's for 'KindVar's
@@ -1461,7 +1461,7 @@ constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore,
 the range of the TvSubstEnv should *never* include a type headed with
 CoercionTy.
 
-Note [Generating the in-scope set for a substitution]
+Note [The subsititution invariant]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When calling substTy subst ty it should be the case that
 the in-scope set in the substitution is a superset of both:
@@ -1760,6 +1760,16 @@ substTyWith :: [TyVar] -> [Type] -> Type -> Type
 substTyWith tvs tys = ASSERT( length tvs == length tys )
                       substTyUnchecked (zipOpenTCvSubst tvs tys)
 
+-- | Substitute tyvars within a type using a known 'InScopeSet'.
+-- Pre-condition: the 'in_scope' set should satisfy Note [The substitution
+-- invariant]; specifically it should include the free vars of 'tys',
+-- and of 'ty' minus the domain of the subst.
+substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type
+substTyWithInScope in_scope tvs tys ty =
+  ASSERT( length tvs == length tys )
+  substTy (mkTCvSubst in_scope (tenv, emptyCvSubstEnv)) ty
+  where tenv = zipTyEnv tvs tys
+
 -- | Coercion substitution making use of an 'TCvSubst' that
 -- is assumed to be open, see 'zipOpenTCvSubst'
 substCoWith :: [TyVar] -> [Type] -> Coercion -> Coercion
@@ -1791,7 +1801,7 @@ substTyWithBinders bndrs tys = ASSERT( length bndrs == length tys )
 -- | Substitute within a 'Type' after adding the free variables of the type
 -- to the in-scope set. This is useful for the case when the free variables
 -- aren't already in the in-scope set or easily available.
--- See also Note [Generating the in-scope set for a substitution].
+-- See also Note [The subsititution invariant].
 substTyAddInScope :: TCvSubst -> Type -> Type
 substTyAddInScope subst ty =
   substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) ty
@@ -1799,7 +1809,7 @@ substTyAddInScope subst ty =
 -- | When calling `substTy` it should be the case that the in-scope set in
 -- the substitution is a superset of the free vars of the range of the
 -- substitution.
--- See also Note [Generating the in-scope set for a substitution].
+-- See also Note [The subsititution invariant].
 isValidTCvSubst :: TCvSubst -> Bool
 isValidTCvSubst (TCvSubst in_scope tenv cenv) =
   (tenvFVs `varSetInScope` in_scope) &&
@@ -1810,7 +1820,7 @@ isValidTCvSubst (TCvSubst in_scope tenv cenv) =
 
 -- | Substitute within a 'Type'
 -- The substitution has to satisfy the invariants described in
--- Note [Generating the in-scope set for a substitution].
+-- Note [The subsititution invariant].
 
 substTy ::
 -- CallStack wasn't present in GHC 7.10.1, disable callstacks in stage 1
@@ -1839,7 +1849,7 @@ substTy subst@(TCvSubst in_scope tenv cenv) ty
 
 -- | Substitute within a 'Type' disabling the sanity checks.
 -- The problems that the sanity checks in substTy catch are described in
--- Note [Generating the in-scope set for a substitution].
+-- Note [The subsititution invariant].
 -- The goal of #11371 is to migrate all the calls of substTyUnchecked to
 -- substTy and remove this function. Please don't use in new code.
 substTyUnchecked :: TCvSubst -> Type  -> Type