[Git][ghc/ghc][wip/always-use-rnImplicitBndrs] Always use rnImplicitBndrs to bring implicit tyvars into scope

Ryan Scott gitlab at gitlab.haskell.org
Wed May 27 20:24:36 UTC 2020



Ryan Scott pushed to branch wip/always-use-rnImplicitBndrs at Glasgow Haskell Compiler / GHC


Commits:
5d45579f by Ryan Scott at 2020-05-27T16:24:10-04:00
Always use rnImplicitBndrs to bring implicit tyvars into scope

This implements a first step towards #16762 by changing the renamer
to always use `rnImplicitBndrs` to bring implicitly bound type
variables into scope. The main change is in `rnFamInstEqn` and
`bindHsQTyVars`, which previously used _ad hoc_ methods of binding
their implicit tyvars.

There are a number of knock-on consequences:

* One of the reasons that `rnFamInstEqn` used an _ad hoc_ binding
  mechanism was to give more precise source locations in
  `-Wunused-type-patterns` warnings. (See
  https://gitlab.haskell.org/ghc/ghc/issues/16762#note_273343 for an
  example of this.) However, these warnings are actually a little
  _too_ precise, since implicitly bound type variables don't have
  exact binding sites like explicitly bound type variables do.
  A similar problem existed for
  "`Different names for the same type variable`" errors involving
  implicit tyvars bound by `bindHsQTyVars`.
  Therefore, we simply accept the less precise (but more accurate)
  source locations from `rnImplicitBndrs` in `rnFamInstEqn` and
  `bindHsQTyVars`. See
  `Note [Source locations for implicitly bound type variables]` in
  `GHC.Rename.HsType` for the full story.
* In order for `rnImplicitBndrs` to work in `rnFamInstEqn`, it needs
  to be able to look up names from the parent class (in the event
  that we are renaming an associated type family instance). As a
  result, `rnImplicitBndrs` now takes an argument of type
  `Maybe assoc`, which is `Just` in the event that a type family
  instance is associated with a class.
* Previously, GHC kept track of three type synonyms for free type
  variables in the renamer: `FreeKiTyVars`, `FreeKiTyVarsDups`
  (which are allowed to contain duplicates)`, and
  `FreeKiTyVarsNoDups` (which contain no duplicates). However, making
  is a distinction between `-Dups` and `-NoDups` is now pointless, as
  all code that returns `FreeKiTyVars{,Dups,NoDups}` will eventually
  end up being passed to `rnImplicitBndrs`, which removes duplicates.
  As a result, I decided to just get rid of `FreeKiTyVarsDups` and
  `FreeKiTyVarsNoDups`, leaving only `FreeKiTyVars`.
* The `bindLRdrNames` and `deleteBys` functions are now dead code, so
  I took the liberty of removing them.

- - - - -


16 changed files:

- compiler/GHC/Data/List/SetOps.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Gen/Splice.hs
- testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.stderr
- testsuite/tests/indexed-types/should_compile/T16356_Compile2.stderr
- testsuite/tests/indexed-types/should_compile/T16632.stderr
- testsuite/tests/indexed-types/should_compile/UnusedTyVarWarnings.stderr
- testsuite/tests/indexed-types/should_compile/UnusedTyVarWarningsNamedWCs.stderr
- testsuite/tests/indexed-types/should_fail/T17008a.stderr
- testsuite/tests/indexed-types/should_fail/T7536.stderr
- testsuite/tests/polykinds/T11203.stderr
- testsuite/tests/polykinds/T11821a.stderr
- testsuite/tests/typecheck/should_fail/T17566b.stderr
- testsuite/tests/typecheck/should_fail/T17566c.stderr


Changes:

=====================================
compiler/GHC/Data/List/SetOps.hs
=====================================
@@ -10,7 +10,7 @@
 --
 -- Avoid using them as much as possible
 module GHC.Data.List.SetOps (
-        unionLists, minusList, deleteBys,
+        unionLists, minusList,
 
         -- Association lists
         Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
@@ -39,11 +39,6 @@ getNth :: Outputable a => [a] -> Int -> a
 getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs )
              xs !! n
 
-deleteBys :: (a -> a -> Bool) -> [a] -> [a] -> [a]
--- (deleteBys eq xs ys) returns xs-ys, using the given equality function
--- Just like 'Data.List.delete' but with an equality function
-deleteBys eq xs ys = foldl' (flip (L.deleteBy eq)) xs ys
-
 {-
 ************************************************************************
 *                                                                      *


=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -30,7 +30,7 @@ module GHC.Hs.Type (
         HsTyLit(..),
         HsIPName(..), hsIPNameFS,
         HsArg(..), numVisibleArgs,
-        LHsTypeArg,
+        LHsTypeArg, lhsTypeArgSrcSpan,
         OutputableBndrFlag,
 
         LBangType, BangType,
@@ -1287,6 +1287,13 @@ numVisibleArgs = count is_vis
 -- type level equivalent
 type LHsTypeArg p = HsArg (LHsType p) (LHsKind p)
 
+-- | Compute the 'SrcSpan' associated with an 'LHsTypeArg'.
+lhsTypeArgSrcSpan :: LHsTypeArg pass -> SrcSpan
+lhsTypeArgSrcSpan arg = case arg of
+  HsValArg  tm    -> getLoc tm
+  HsTypeArg at ty -> at `combineSrcSpans` getLoc ty
+  HsArgPar  sp    -> sp
+
 instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where
   ppr (HsValArg tm)    = ppr tm
   ppr (HsTypeArg _ ty) = char '@' <> ppr ty


=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -24,11 +24,11 @@ module GHC.Rename.HsType (
 
         -- Binding related stuff
         bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,
-        bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
+        bindSigTyVarsFV, bindHsQTyVars,
+        FreeKiTyVars,
         extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
-        extractHsTysRdrTyVarsDups,
-        extractRdrKindSigVars, extractDataDefnKindVars,
-        extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup,
+        extractHsTysRdrTyVars, extractRdrKindSigVars, extractDataDefnKindVars,
+        extractHsTvBndrs, extractHsTyArgRdrKiTyVars,
         forAllOrNothing, nubL
   ) where
 
@@ -56,7 +56,6 @@ import GHC.Types.Name.Set
 import GHC.Types.FieldLabel
 
 import GHC.Utils.Misc
-import GHC.Data.List.SetOps ( deleteBys )
 import GHC.Types.Basic  ( compareFixity, funTyFixity, negateFixity
                         , Fixity(..), FixityDirection(..), LexicalFixity(..)
                         , TypeOrKind(..) )
@@ -164,14 +163,14 @@ rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> Maybe SDoc
                   -> RnM (a, FreeVars)
 rn_hs_sig_wc_type scoping ctxt inf_err hs_ty thing_inside
   = do { check_inferred_vars ctxt inf_err hs_ty
-       ; free_vars <- filterInScopeM (extractHsTyRdrTyVarsDups hs_ty)
+       ; free_vars <- filterInScopeM (extractHsTyRdrTyVars hs_ty)
        ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars
        ; let nwc_rdrs = nubL nwc_rdrs'
        ; implicit_bndrs <- case scoping of
            AlwaysBind       -> pure tv_rdrs
            BindUnlessForall -> forAllOrNothing (isLHsForAllTy hs_ty) tv_rdrs
            NeverBind        -> pure []
-       ; rnImplicitBndrs implicit_bndrs $ \ vars ->
+       ; rnImplicitBndrs Nothing implicit_bndrs $ \ vars ->
     do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
        ; (res, fvs2) <- thing_inside wcs vars hs_ty'
        ; return (res, fvs1 `plusFV` fvs2) } }
@@ -179,7 +178,8 @@ rn_hs_sig_wc_type scoping ctxt inf_err hs_ty thing_inside
 rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
 rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
   = do { free_vars <- filterInScopeM (extractHsTyRdrTyVars hs_ty)
-       ; (nwc_rdrs, _) <- partition_nwcs free_vars
+       ; (nwc_rdrs', _) <- partition_nwcs free_vars
+       ; let nwc_rdrs = nubL nwc_rdrs'
        ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty
        ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' }
        ; return (sig_ty', fvs) }
@@ -328,8 +328,8 @@ rnHsSigType ctx level inf_err (HsIB { hsib_body = hs_ty })
        ; check_inferred_vars ctx inf_err hs_ty
        ; vars0 <- forAllOrNothing (isLHsForAllTy hs_ty)
            $ filterInScope rdr_env
-           $ extractHsTyRdrTyVarsDups hs_ty
-       ; rnImplicitBndrs vars0 $ \ vars ->
+           $ extractHsTyRdrTyVars hs_ty
+       ; rnImplicitBndrs Nothing vars0 $ \ vars ->
     do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty
 
        ; return ( HsIB { hsib_ext = vars
@@ -357,9 +357,9 @@ forAllOrNothing :: Bool
                 --  we do not want to bring 'b' into scope, hence True
                 -- But   f :: a -> b
                 --  we want to bring both 'a' and 'b' into scope, hence False
-                -> FreeKiTyVarsWithDups
+                -> FreeKiTyVars
                 -- ^ Free vars of the type
-                -> RnM FreeKiTyVarsWithDups
+                -> RnM FreeKiTyVars
 forAllOrNothing has_outer_forall fvs = case has_outer_forall of
   True -> do
     traceRn "forAllOrNothing" $ text "has explicit outer forall"
@@ -368,24 +368,50 @@ forAllOrNothing has_outer_forall fvs = case has_outer_forall of
     traceRn "forAllOrNothing" $ text "no explicit forall. implicit binders:" <+> ppr fvs
     pure fvs
 
-rnImplicitBndrs :: FreeKiTyVarsWithDups
+rnImplicitBndrs :: Maybe assoc
+                -- ^ @'Just' _@ => an associated type decl
+                -> FreeKiTyVars
                 -- ^ Surface-syntax free vars that we will implicitly bind.
-                -- May have duplicates, which is checked here
+                -- May have duplicates, which are removed here.
                 -> ([Name] -> RnM (a, FreeVars))
                 -> RnM (a, FreeVars)
-rnImplicitBndrs implicit_vs_with_dups
-                thing_inside
+rnImplicitBndrs mb_assoc implicit_vs_with_dups thing_inside
   = do { let implicit_vs = nubL implicit_vs_with_dups
 
        ; traceRn "rnImplicitBndrs" $
          vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ]
 
+         -- Use the currently set SrcSpan as the new source location for each Name.
+         -- See Note [Source locations for implicitly bound type variables].
        ; loc <- getSrcSpanM
-       ; vars <- mapM (newLocalBndrRn . L loc . unLoc) implicit_vs
+       ; vars <- mapM (newTyVarNameRn mb_assoc . L loc . unLoc) implicit_vs
 
        ; bindLocalNamesFV vars $
          thing_inside vars }
 
+{-
+Note [Source locations for implicitly bound type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When bringing implicitly bound type variables into scope (in rnImplicitBndrs),
+we do something peculiar: we drop the original SrcSpan attached to each
+variable and replace it with the currently set SrcSpan. Moreover, this new
+SrcSpan is usually /less/ precise than the original one, and that's OK. To see
+why this is done, consider the following example:
+
+  f :: a -> b -> a
+
+Suppose that a warning or error message needs to point to the SrcSpans of the
+binding sites for `a` and `b`. But where /are/ they bound, anyway? Technically,
+they're bound by an unwritten `forall` at the front of the type signature, but
+there is no SrcSpan for that. We could point to the first occurrence of `a` as
+the binding site for `a`, but that would make the first occurrence of `a`
+special. Moreover, we don't want IDEs to confuse binding sites and occurrences.
+
+As a result, we make the `SrcSpan`s for `a` and `b` span the entirety of the
+type signature, since the type signature implicitly carries their binding
+sites. This is less precise, but more accurate.
+-}
+
 check_inferred_vars :: HsDocContext
                     -> Maybe SDoc
                     -- ^ The error msg if the signature is not allowed to contain
@@ -831,24 +857,13 @@ bindSigTyVarsFV tvs thing_inside
           else
                 bindLocalNamesFV tvs thing_inside }
 
--- | Simply bring a bunch of RdrNames into scope. No checking for
--- validity, at all. The binding location is taken from the location
--- on each name.
-bindLRdrNames :: [Located RdrName]
-              -> ([Name] -> RnM (a, FreeVars))
-              -> RnM (a, FreeVars)
-bindLRdrNames rdrs thing_inside
-  = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs
-       ; bindLocalNamesFV var_names $
-         thing_inside var_names }
-
 ---------------
 bindHsQTyVars :: forall a b.
                  HsDocContext
               -> Maybe SDoc         -- Just d => check for unused tvs
                                     --   d is a phrase like "in the type ..."
               -> Maybe a            -- Just _  => an associated type decl
-              -> [Located RdrName]  -- Kind variables from scope, no dups
+              -> FreeKiTyVars       -- Kind variables from scope
               -> (LHsQTyVars GhcPs)
               -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
                   -- The Bool is True <=> all kind variables used in the
@@ -871,10 +886,10 @@ bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
              -- all these various things are doing
              bndrs, implicit_kvs :: [Located RdrName]
              bndrs        = map hsLTyVarLocName hs_tv_bndrs
-             implicit_kvs = nubL $ filterFreeVarsToBind bndrs $
+             implicit_kvs = filterFreeVarsToBind bndrs $
                bndr_kv_occs ++ body_kv_occs
-             del          = deleteBys eqLocated
-             body_remaining = (body_kv_occs `del` bndrs) `del` bndr_kv_occs
+             body_remaining = filterFreeVarsToBind bndr_kv_occs $
+              filterFreeVarsToBind bndrs body_kv_occs
              all_bound_on_lhs = null body_remaining
 
        ; traceRn "checkMixedVars3" $
@@ -885,9 +900,7 @@ bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
                 , text "body_remaining" <+> ppr body_remaining
                 ]
 
-       ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs
-
-       ; bindLocalNamesFV implicit_kv_nms                     $
+       ; rnImplicitBndrs mb_assoc implicit_kvs $ \ implicit_kv_nms ->
          bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs ->
     do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs)
        ; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms
@@ -909,12 +922,12 @@ Then:
   body_kv_occs = [k2,k1], kind variables free in the
                           result kind signature
 
-  implicit_kvs = [k1,k2], kind variables free in kind signatures
-                          of hs_tv_bndrs, and not bound by bndrs
+  implicit_kvs = [k1,k2,k1], kind variables free in kind signatures
+                             of hs_tv_bndrs, and not bound by bndrs
 
 * We want to quantify add implicit bindings for implicit_kvs
 
-* If implicit_body_kvs is non-empty, then there is a kind variable
+* If body_kv_occs is non-empty, then there is a kind variable
   mentioned in the kind signature that is not bound "on the left".
   That's one of the rules for a CUSK, so we pass that info on
   as the second argument to thing_inside.
@@ -922,6 +935,9 @@ Then:
 * Order is not important in these lists.  All we are doing is
   bring Names into scope.
 
+* bndr_kv_occs, body_kv_occs, and implicit_kvs can contain duplicates. All
+  duplicate occurrences are removed when we bind them with rnImplicitBndrs.
+
 Finally, you may wonder why filterFreeVarsToBind removes in-scope variables
 from bndr/body_kv_occs.  How can anything be in scope?  Answer:
 HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax
@@ -1040,14 +1056,15 @@ bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x fl lrdr@(L lv _) kind))
                $ thing_inside (L loc (KindedTyVar x fl (L lv tv_nm) kind'))
            ; return (b, fvs1 `plusFV` fvs2) }
 
-newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name
-newTyVarNameRn mb_assoc (L loc rdr)
+newTyVarNameRn :: Maybe a -- associated class
+               -> Located RdrName -> RnM Name
+newTyVarNameRn mb_assoc lrdr@(L _ rdr)
   = do { rdr_env <- getLocalRdrEnv
        ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of
            (Just _, Just n) -> return n
               -- Use the same Name as the parent class decl
 
-           _                -> newLocalBndrRn (L loc rdr) }
+           _                -> newLocalBndrRn lrdr }
 {-
 *********************************************************
 *                                                       *
@@ -1504,7 +1521,10 @@ To do that, we need to walk over a type and find its free type/kind variables.
 We preserve the left-to-right order of each variable occurrence.
 See Note [Ordering of implicit variables].
 
-Clients of this code can remove duplicates with nubL.
+It is common for lists of free type variables to contain duplicates. For
+example, in `f :: a -> a`, the free type variable list is [a, a]. When these
+implicitly bound variables are brought into scope (with rnImplicitBndrs),
+duplicates are removed with nubL.
 
 Note [Ordering of implicit variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1533,9 +1553,8 @@ the a in the code. Thus, GHC does ScopedSort on the variables.
 See Note [ScopedSort] in GHC.Core.Type.
 
 Implicitly bound variables are collected by any function which returns a
-FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably
-includes the `extract-` family of functions (extractHsTysRdrTyVarsDups,
-extractHsTyVarBndrsKVs, etc.).
+FreeKiTyVars, which notably includes the `extract-` family of functions
+(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.).
 These functions thus promise to keep left-to-right ordering.
 
 Note [Implicit quantification in type synonyms]
@@ -1621,18 +1640,13 @@ type checking. While viable, this would mean we'd end up accepting this:
 
 -}
 
+-- A list of free type/kind variables, which can contain duplicates.
 -- See Note [Kind and type-variable binders]
 -- These lists are guaranteed to preserve left-to-right ordering of
 -- the types the variables were extracted from. See also
 -- Note [Ordering of implicit variables].
 type FreeKiTyVars = [Located RdrName]
 
--- | A 'FreeKiTyVars' list that is allowed to have duplicate variables.
-type FreeKiTyVarsWithDups = FreeKiTyVars
-
--- | A 'FreeKiTyVars' list that contains no duplicate variables.
-type FreeKiTyVarsNoDups   = FreeKiTyVars
-
 -- | Filter out any type and kind variables that are already in scope in the
 -- the supplied LocalRdrEnv. Note that this includes named wildcards, which
 -- look like perfectly ordinary type variables at this point.
@@ -1650,46 +1664,32 @@ filterInScopeM vars
 inScope :: LocalRdrEnv -> RdrName -> Bool
 inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env
 
-extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVars -> FreeKiTyVars
 extract_tyarg (HsValArg ty) acc = extract_lty ty acc
 extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc
 extract_tyarg (HsArgPar _) acc = acc
 
-extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVars -> FreeKiTyVars
 extract_tyargs args acc = foldr extract_tyarg acc args
 
-extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups
-extractHsTyArgRdrKiTyVarsDup args
+extractHsTyArgRdrKiTyVars :: [LHsTypeArg GhcPs] -> FreeKiTyVars
+extractHsTyArgRdrKiTyVars args
   = extract_tyargs args []
 
 -- | 'extractHsTyRdrTyVars' finds the type/kind variables
 --                          of a HsType/HsKind.
 -- It's used when making the @forall at s explicit.
--- When the same name occurs multiple times in the types, only the first
--- occurrence is returned.
 -- See Note [Kind and type-variable binders]
-extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsNoDups
-extractHsTyRdrTyVars ty
-  = nubL (extractHsTyRdrTyVarsDups ty)
-
--- | 'extractHsTyRdrTyVarsDups' finds the type/kind variables
---                              of a HsType/HsKind.
--- It's used when making the @forall at s explicit.
--- When the same name occurs multiple times in the types, all occurrences
--- are returned.
-extractHsTyRdrTyVarsDups :: LHsType GhcPs -> FreeKiTyVarsWithDups
-extractHsTyRdrTyVarsDups ty
-  = extract_lty ty []
+extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVars
+extractHsTyRdrTyVars ty = extract_lty ty []
 
 -- | Extracts the free type/kind variables from the kind signature of a HsType.
 --   This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k at .
--- When the same name occurs multiple times in the type, only the first
--- occurrence is returned, and the left-to-right order of variables is
--- preserved.
+-- The left-to-right order of variables is preserved.
 -- See Note [Kind and type-variable binders] and
 --     Note [Ordering of implicit variables] and
 --     Note [Implicit quantification in type synonyms].
-extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVarsNoDups
+extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVars
 extractHsTyRdrTyVarsKindVars (L _ ty) =
   case ty of
     HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty
@@ -1699,51 +1699,45 @@ extractHsTyRdrTyVarsKindVars (L _ ty) =
 -- | Extracts free type and kind variables from types in a list.
 -- When the same name occurs multiple times in the types, all occurrences
 -- are returned.
-extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> FreeKiTyVarsWithDups
-extractHsTysRdrTyVarsDups tys
-  = extract_ltys tys []
+extractHsTysRdrTyVars :: [LHsType GhcPs] -> FreeKiTyVars
+extractHsTysRdrTyVars tys = extract_ltys tys []
 
 -- Returns the free kind variables of any explicitly-kinded binders, returning
 -- variable occurrences in left-to-right order.
 -- See Note [Ordering of implicit variables].
 -- NB: Does /not/ delete the binders themselves.
---     However duplicates are removed
 --     E.g. given  [k1, a:k1, b:k2]
 --          the function returns [k1,k2], even though k1 is bound here
-extractHsTyVarBndrsKVs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVarsNoDups
-extractHsTyVarBndrsKVs tv_bndrs
-  = nubL (extract_hs_tv_bndrs_kvs tv_bndrs)
+extractHsTyVarBndrsKVs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
+extractHsTyVarBndrsKVs tv_bndrs = extract_hs_tv_bndrs_kvs tv_bndrs
 
 -- Returns the free kind variables in a type family result signature, returning
 -- variable occurrences in left-to-right order.
 -- See Note [Ordering of implicit variables].
-extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName]
+extractRdrKindSigVars :: LFamilyResultSig GhcPs -> FreeKiTyVars
 extractRdrKindSigVars (L _ resultSig) = case resultSig of
   KindSig _ k                            -> extractHsTyRdrTyVars k
   TyVarSig _ (L _ (KindedTyVar _ _ _ k)) -> extractHsTyRdrTyVars k
   _ -> []
 
 -- | Get type/kind variables mentioned in the kind signature, preserving
--- left-to-right order and without duplicates:
+-- left-to-right order:
 --
 --  * data T a (b :: k1) :: k2 -> k1 -> k2 -> Type   -- result: [k2,k1]
 --  * data T a (b :: k1)                             -- result: []
 --
 -- See Note [Ordering of implicit variables].
-extractDataDefnKindVars :: HsDataDefn GhcPs ->  FreeKiTyVarsNoDups
+extractDataDefnKindVars :: HsDataDefn GhcPs ->  FreeKiTyVars
 extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })
   = maybe [] extractHsTyRdrTyVars ksig
 
-extract_lctxt :: LHsContext GhcPs
-              -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
 extract_lctxt ctxt = extract_ltys (unLoc ctxt)
 
-extract_ltys :: [LHsType GhcPs]
-             -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_ltys :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars
 extract_ltys tys acc = foldr extract_lty acc tys
 
-extract_lty :: LHsType GhcPs
-            -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_lty :: LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
 extract_lty (L _ ty) acc
   = case ty of
       HsTyVar _ _  ltv            -> extract_tv ltv acc
@@ -1784,15 +1778,15 @@ extract_lty (L _ ty) acc
       HsWildCardTy {}             -> acc
 
 extractHsTvBndrs :: [LHsTyVarBndr flag GhcPs]
-                 -> FreeKiTyVarsWithDups           -- Free in body
-                 -> FreeKiTyVarsWithDups       -- Free in result
+                 -> FreeKiTyVars       -- Free in body
+                 -> FreeKiTyVars       -- Free in result
 extractHsTvBndrs tv_bndrs body_fvs
   = extract_hs_tv_bndrs tv_bndrs [] body_fvs
 
 extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs]
-                    -> FreeKiTyVarsWithDups  -- Accumulator
-                    -> FreeKiTyVarsWithDups  -- Free in body
-                    -> FreeKiTyVarsWithDups
+                    -> FreeKiTyVars  -- Accumulator
+                    -> FreeKiTyVars  -- Free in body
+                    -> FreeKiTyVars
 -- In (forall (a :: Maybe e). a -> b) we have
 --     'a' is bound by the forall
 --     'b' is a free type variable
@@ -1807,24 +1801,28 @@ extract_hs_tv_bndrs tv_bndrs acc_vars body_vars = new_vars ++ acc_vars
     bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs
     tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs
 
-extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVarsWithDups
+extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
 -- Returns the free kind variables of any explicitly-kinded binders, returning
 -- variable occurrences in left-to-right order.
 -- See Note [Ordering of implicit variables].
 -- NB: Does /not/ delete the binders themselves.
---     Duplicates are /not/ removed
 --     E.g. given  [k1, a:k1, b:k2]
 --          the function returns [k1,k2], even though k1 is bound here
 extract_hs_tv_bndrs_kvs tv_bndrs =
     foldr extract_lty []
           [k | L _ (KindedTyVar _ _ _ k) <- tv_bndrs]
 
-extract_tv :: Located RdrName
-           -> [Located RdrName] -> [Located RdrName]
+extract_tv :: Located RdrName -> FreeKiTyVars -> FreeKiTyVars
 extract_tv tv acc =
   if isRdrTyVar (unLoc tv) then tv:acc else acc
 
--- Deletes duplicates in a list of Located things.
+-- Deletes duplicates in a list of Located things. This is used to:
+--
+-- * Delete duplicate occurrences of implicitly bound type/kind variables when
+--   bringing them into scope (in rnImplicitBndrs).
+--
+-- * Delete duplicate occurrences of named wildcards (in rn_hs_sig_wc_type and
+--   rnHsWcType).
 --
 -- Importantly, this function is stable with respect to the original ordering
 -- of things in the list. This is important, as it is a property that GHC
@@ -1838,9 +1836,9 @@ nubL = nubBy eqLocated
 -- already in scope, or are explicitly bound in the binder.
 filterFreeVarsToBind :: FreeKiTyVars
                      -- ^ Explicitly bound here
-                     -> FreeKiTyVarsWithDups
+                     -> FreeKiTyVars
                      -- ^ Potential implicit binders
-                     -> FreeKiTyVarsWithDups
+                     -> FreeKiTyVars
                      -- ^ Final implicit binders
 filterFreeVarsToBind bndrs = filterOut is_in_scope
     -- Make sure to list the binder kvs before the body kvs, as mandated by


=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -664,7 +664,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
 
 rnFamInstEqn :: HsDocContext
              -> AssocTyFamInfo
-             -> [Located RdrName]
+             -> FreeKiTyVars
              -- ^ Kind variables from the equation's RHS to be implicitly bound
              -- if no explicit forall.
              -> FamInstEqn GhcPs rhs
@@ -676,16 +676,7 @@ rnFamInstEqn doc atfi rhs_kvars
                                , feqn_pats   = pats
                                , feqn_fixity = fixity
                                , feqn_rhs    = payload }}) rn_payload
-  = do { let mb_cls = case atfi of
-                        NonAssocTyFamEqn     -> Nothing
-                        AssocTyFamDeflt cls  -> Just cls
-                        AssocTyFamInst cls _ -> Just cls
-       ; tycon'   <- lookupFamInstName mb_cls tycon
-       ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats
-             -- Use the "...Dups" form because it's needed
-             -- below to report unused binder on the LHS
-
-       ; let bndrs = fromMaybe [] mb_bndrs
+  = do { tycon' <- lookupFamInstName mb_cls tycon
 
          -- all_imp_vars represent the implicitly bound type variables. This is
          -- empty if we have an explicit `forall` (see
@@ -713,48 +704,45 @@ rnFamInstEqn doc atfi rhs_kvars
            -- No need to filter out explicit binders (the 'mb_bndrs = Just
            -- explicit_bndrs' case) because there must be none if we're going
            -- to implicitly bind anything, per the previous comment.
-           nubL $ pat_kity_vars_with_dups ++ rhs_kvars
-       ; all_imp_var_names <- mapM (newTyVarNameRn mb_cls) all_imp_vars
-
-             -- All the free vars of the family patterns
-             -- with a sensible binding location
-       ; ((bndrs', pats', payload'), fvs)
-              <- bindLocalNamesFV all_imp_var_names $
-                 bindLHsTyVarBndrs doc (Just $ inHsDocContext doc)
-                                   Nothing bndrs $ \bndrs' ->
-                 -- Note: If we pass mb_cls instead of Nothing here,
-                 --  bindLHsTyVarBndrs will use class variables for any names
-                 --  the user meant to bring in scope here. This is an explicit
-                 --  forall, so we want fresh names, not class variables.
-                 --  Thus: always pass Nothing
-                 do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats
-                    ; (payload', rhs_fvs) <- rn_payload doc payload
-
-                       -- Report unused binders on the LHS
-                       -- See Note [Unused type variables in family instances]
-                    ; let groups :: [NonEmpty (Located RdrName)]
-                          groups = equivClasses cmpLocated $
-                                   pat_kity_vars_with_dups
-                    ; nms_dups <- mapM (lookupOccRn . unLoc) $
-                                     [ tv | (tv :| (_:_)) <- groups ]
-                          -- Add to the used variables
-                          --  a) any variables that appear *more than once* on the LHS
-                          --     e.g.   F a Int a = Bool
-                          --  b) for associated instances, the variables
-                          --     of the instance decl.  See
-                          --     Note [Unused type variables in family instances]
-                    ; let nms_used = extendNameSetList rhs_fvs $
-                                        inst_tvs ++ nms_dups
-                          inst_tvs = case atfi of
-                                       NonAssocTyFamEqn          -> []
-                                       AssocTyFamDeflt _         -> []
-                                       AssocTyFamInst _ inst_tvs -> inst_tvs
-                          all_nms = all_imp_var_names ++ hsLTyVarNames bndrs'
-                    ; warnUnusedTypePatterns all_nms nms_used
-
-                    ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) }
-
-       ; let all_fvs  = fvs `addOneFV` unLoc tycon'
+           pat_kity_vars_with_dups ++ rhs_kvars
+
+       ; rnImplicitBndrs mb_cls all_imp_vars $ \all_imp_var_names' ->
+         bindLHsTyVarBndrs doc (Just $ inHsDocContext doc)
+                           Nothing (fromMaybe [] mb_bndrs) $ \bndrs' ->
+         -- Note: If we pass mb_cls instead of Nothing here,
+         --  bindLHsTyVarBndrs will use class variables for any names
+         --  the user meant to bring in scope here. This is an explicit
+         --  forall, so we want fresh names, not class variables.
+         --  Thus: always pass Nothing
+    do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats
+       ; (payload', rhs_fvs) <- rn_payload doc payload
+
+          -- Report unused binders on the LHS
+          -- See Note [Unused type variables in family instances]
+       ; let -- The SrcSpan that rnImplicitBndrs will attach to each Name will
+             -- span the entire type family instance, which will be reflected in
+             -- -Wunused-type-patterns warnings. We can be a little more precise
+             -- than that by pointing to the LHS of the instance instead, which
+             -- is what lhs_loc corresponds to.
+             all_imp_var_names = map (`setNameLoc` lhs_loc) all_imp_var_names'
+
+             groups :: [NonEmpty (Located RdrName)]
+             groups = equivClasses cmpLocated $
+                      pat_kity_vars_with_dups
+       ; nms_dups <- mapM (lookupOccRn . unLoc) $
+                        [ tv | (tv :| (_:_)) <- groups ]
+             -- Add to the used variables
+             --  a) any variables that appear *more than once* on the LHS
+             --     e.g.   F a Int a = Bool
+             --  b) for associated instances, the variables
+             --     of the instance decl.  See
+             --     Note [Unused type variables in family instances]
+       ; let nms_used = extendNameSetList rhs_fvs $
+                           inst_tvs ++ nms_dups
+             all_nms = all_imp_var_names ++ hsLTyVarNames bndrs'
+       ; warnUnusedTypePatterns all_nms nms_used
+
+       ; let all_fvs = (rhs_fvs `plusFV` pat_fvs) `addOneFV` unLoc tycon'
             -- type instance => use, hence addOneFV
 
        ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances]
@@ -765,7 +753,33 @@ rnFamInstEqn doc atfi rhs_kvars
                                    , feqn_pats   = pats'
                                    , feqn_fixity = fixity
                                    , feqn_rhs    = payload' } },
-                 all_fvs) }
+                 all_fvs) } }
+  where
+    -- The parent class, if we are dealing with an associated type family
+    -- instance.
+    mb_cls = case atfi of
+      NonAssocTyFamEqn     -> Nothing
+      AssocTyFamDeflt cls  -> Just cls
+      AssocTyFamInst cls _ -> Just cls
+
+    -- The type variables from the instance head, if we are dealing with an
+    -- associated type family instance.
+    inst_tvs = case atfi of
+      NonAssocTyFamEqn          -> []
+      AssocTyFamDeflt _         -> []
+      AssocTyFamInst _ inst_tvs -> inst_tvs
+
+    pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVars pats
+             -- It is crucial that extractHsTyArgRdrKiTyVars return
+             -- duplicate occurrences, since they're needed to help
+             -- determine unused binders on the LHS.
+
+    -- The SrcSpan of the LHS of the instance. For example, lhs_loc would be
+    -- the highlighted part in the example below:
+    --
+    --   type instance F a b c = Either a b
+    --                 ^^^^^^^
+    lhs_loc = foldr combineSrcSpans (getLoc tycon) (map lhsTypeArgSrcSpan pats)
 
 rnTyFamInstDecl :: AssocTyFamInfo
                 -> TyFamInstDecl GhcPs
@@ -2116,12 +2130,12 @@ rnConDecl decl@(ConDeclGADT { con_names   = names
           -- See #14808.
         ; implicit_bndrs <- forAllOrNothing explicit_forall
             $ extractHsTvBndrs explicit_tkvs
-            $ extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty])
+            $ extractHsTysRdrTyVars (theta ++ arg_tys ++ [res_ty])
 
         ; let ctxt    = ConDeclCtx new_names
               mb_ctxt = Just (inHsDocContext ctxt)
 
-        ; rnImplicitBndrs implicit_bndrs $ \ implicit_tkvs ->
+        ; rnImplicitBndrs Nothing implicit_bndrs $ \ implicit_tkvs ->
           bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs ->
     do  { (new_cxt, fvs1)    <- rnMbContext ctxt mcxt
         ; (new_args, fvs2)   <- rnConDeclDetails (unLoc (head new_names)) ctxt args


=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -1431,7 +1431,7 @@ reifyInstances th_nm th_tys
                              -- must error before proceeding to typecheck the
                              -- renamed type, as that will result in GHC
                              -- internal errors (#13837).
-               bindLRdrNames tv_rdrs $ \ tv_names ->
+               rnImplicitBndrs Nothing tv_rdrs $ \ tv_names ->
                do { (rn_ty, fvs) <- rnLHsType doc rdr_ty
                   ; return ((tv_names, rn_ty), fvs) }
         ; (_tvs, ty)


=====================================
testsuite/tests/indexed-types/should_compile/ExplicitForAllFams2.stderr
=====================================
@@ -5,8 +5,8 @@ ExplicitForAllFams2.hs:34:10: warning: [-Wunused-type-patterns]
 ExplicitForAllFams2.hs:35:10: warning: [-Wunused-type-patterns]
     Defined but not used on the right hand side: type variable ‘a’
 
-ExplicitForAllFams2.hs:38:7: warning: [-Wunused-type-patterns]
+ExplicitForAllFams2.hs:38:3: warning: [-Wunused-type-patterns]
     Defined but not used on the right hand side: type variable ‘t’
 
-ExplicitForAllFams2.hs:39:6: warning: [-Wunused-type-patterns]
+ExplicitForAllFams2.hs:39:3: warning: [-Wunused-type-patterns]
     Defined but not used on the right hand side: type variable ‘a’


=====================================
testsuite/tests/indexed-types/should_compile/T16356_Compile2.stderr
=====================================
@@ -1,8 +1,8 @@
 
-T16356_Compile2.hs:10:12: warning: [-Wunused-type-patterns]
+T16356_Compile2.hs:10:8: warning: [-Wunused-type-patterns]
     Defined but not used on the right hand side: type variable ‘j’
 
-T16356_Compile2.hs:10:17: warning: [-Wunused-type-patterns]
+T16356_Compile2.hs:10:8: warning: [-Wunused-type-patterns]
     Defined but not used on the right hand side: type variable ‘a’
 
 T16356_Compile2.hs:13:15: warning: [-Wunused-type-patterns]


=====================================
testsuite/tests/indexed-types/should_compile/T16632.stderr
=====================================
@@ -1,6 +1,6 @@
 
-T16632.hs:5:22: warning: [-Wunused-type-patterns]
+T16632.hs:5:15: warning: [-Wunused-type-patterns]
     Defined but not used on the right hand side: type variable ‘b’
   |
 5 | type instance F Char b Int = ()
-  |                      ^
+  |               ^^^^^^^^^^^^


=====================================
testsuite/tests/indexed-types/should_compile/UnusedTyVarWarnings.stderr
=====================================
@@ -1,12 +1,12 @@
 
-UnusedTyVarWarnings.hs:8:7: warning: [-Wunused-type-patterns]
+UnusedTyVarWarnings.hs:8:3: warning: [-Wunused-type-patterns]
     Defined but not used on the right hand side: type variable ‘b’
 
-UnusedTyVarWarnings.hs:11:20: warning: [-Wunused-type-patterns]
+UnusedTyVarWarnings.hs:11:15: warning: [-Wunused-type-patterns]
     Defined but not used on the right hand side: type variable ‘b’
 
-UnusedTyVarWarnings.hs:27:5: warning: [-Wunused-type-patterns]
+UnusedTyVarWarnings.hs:27:3: warning: [-Wunused-type-patterns]
     Defined but not used on the right hand side: type variable ‘a’
 
-UnusedTyVarWarnings.hs:33:19: warning: [-Wunused-type-patterns]
+UnusedTyVarWarnings.hs:33:15: warning: [-Wunused-type-patterns]
     Defined but not used on the right hand side: type variable ‘b’


=====================================
testsuite/tests/indexed-types/should_compile/UnusedTyVarWarningsNamedWCs.stderr
=====================================
@@ -1,12 +1,12 @@
 
-UnusedTyVarWarningsNamedWCs.hs:8:7: warning: [-Wunused-type-patterns]
+UnusedTyVarWarningsNamedWCs.hs:8:3: warning: [-Wunused-type-patterns]
     Defined but not used on the right hand side: type variable ‘b’
 
-UnusedTyVarWarningsNamedWCs.hs:11:20: warning: [-Wunused-type-patterns]
+UnusedTyVarWarningsNamedWCs.hs:11:15: warning: [-Wunused-type-patterns]
     Defined but not used on the right hand side: type variable ‘b’
 
-UnusedTyVarWarningsNamedWCs.hs:27:5: warning: [-Wunused-type-patterns]
+UnusedTyVarWarningsNamedWCs.hs:27:3: warning: [-Wunused-type-patterns]
     Defined but not used on the right hand side: type variable ‘a’
 
-UnusedTyVarWarningsNamedWCs.hs:33:19: warning: [-Wunused-type-patterns]
+UnusedTyVarWarningsNamedWCs.hs:33:15: warning: [-Wunused-type-patterns]
     Defined but not used on the right hand side: type variable ‘b’


=====================================
testsuite/tests/indexed-types/should_fail/T17008a.stderr
=====================================
@@ -1,5 +1,5 @@
 
-T17008a.hs:11:21: error:
+T17008a.hs:11:3: error:
     • Type variable ‘a1’ is mentioned in the RHS,
         but not bound on the LHS of the family instance
         The real LHS (expanding synonyms) is: F @a2 x


=====================================
testsuite/tests/indexed-types/should_fail/T7536.stderr
=====================================
@@ -1,5 +1,5 @@
 
-T7536.hs:8:21: error:
+T7536.hs:8:15: error:
     • Type variable ‘a’ is mentioned in the RHS,
         but not bound on the LHS of the family instance
         The real LHS (expanding synonyms) is: TF Int


=====================================
testsuite/tests/polykinds/T11203.stderr
=====================================
@@ -1,4 +1,4 @@
 
-T11203.hs:7:24: error:
+T11203.hs:7:1: error:
     • Different names for the same type variable: ‘k1’ and ‘k2’
     • In the data declaration for ‘Q’


=====================================
testsuite/tests/polykinds/T11821a.stderr
=====================================
@@ -1,4 +1,4 @@
 
-T11821a.hs:4:31: error:
+T11821a.hs:4:1: error:
     • Different names for the same type variable: ‘k1’ and ‘k2’
     • In the type declaration for ‘SameKind’


=====================================
testsuite/tests/typecheck/should_fail/T17566b.stderr
=====================================
@@ -1,4 +1,4 @@
 
-T17566b.hs:7:17: error:
+T17566b.hs:7:3: error:
     • Different names for the same type variable: ‘k1’ and ‘k2’
     • In the class declaration for ‘C’


=====================================
testsuite/tests/typecheck/should_fail/T17566c.stderr
=====================================
@@ -1,6 +1,6 @@
 
-T17566c.hs:11:23: error:
+T17566c.hs:11:3: error:
     • Different names for the same type variable:
-        ‘k’ bound at T17566c.hs:10:17
-        ‘k’ bound at T17566c.hs:11:23
+        ‘k’ bound at T17566c.hs:10:3
+        ‘k’ bound at T17566c.hs:11:3
     • In the class declaration for ‘C2’



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5d45579fa1258a7626c554313d672f0367ed63d6

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5d45579fa1258a7626c554313d672f0367ed63d6
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200527/be12aac0/attachment-0001.html>


More information about the ghc-commits mailing list