Remove -dtrace-level
[ghc.git] / compiler / rename / RnTypes.hs
index 822f6a9..56a0331 100644 (file)
@@ -10,7 +10,7 @@
 module RnTypes (
         -- Type related stuff
         rnHsType, rnLHsType, rnLHsTypes, rnContext,
-        rnHsKind, rnLHsKind, rnLHsMaybeKind,
+        rnHsKind, rnLHsKind,
         rnHsSigType, rnHsWcType,
         rnHsSigWcType, rnHsSigWcTypeScoped,
         rnLHsInstType,
@@ -23,9 +23,11 @@ module RnTypes (
         checkPrecMatch, checkSectionPrec,
 
         -- Binding related stuff
-        warnUnusedForAlls, bindLHsTyVarBndr,
+        bindLHsTyVarBndr,
         bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
+        extractFilteredRdrTyVars,
         extractHsTyRdrTyVars, extractHsTysRdrTyVars,
+        extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars,
         extractRdrKindSigVars, extractDataDefnKindVars,
         freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars
   ) where
@@ -54,13 +56,9 @@ import FastString
 import Maybes
 import qualified GHC.LanguageExtensions as LangExt
 
-import Data.List        ( nubBy )
+import Data.List        ( (\\), nubBy, partition )
 import Control.Monad    ( unless, when )
 
-#if __GLASGOW_HASKELL__ < 709
-import Data.Monoid      ( mappend, mempty, mconcat )
-#endif
-
 #include "HsVersions.h"
 
 {-
@@ -87,10 +85,14 @@ rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType RdrName
 --   - Signatures on binders in a RULE
 --   - Pattern type signatures
 -- Wildcards are allowed
+-- type signatures on binders only allowed with ScopedTypeVariables
 rnHsSigWcTypeScoped ctx sig_ty thing_inside
-  = rn_hs_sig_wc_type False ctx sig_ty thing_inside
+  = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
+       ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)
+       ; rn_hs_sig_wc_type False ctx sig_ty thing_inside
+       }
     -- False: for pattern type sigs and rules we /do/ want
-    --        to bring those type varibles into scope
+    --        to bring those type variables into scope
     -- e.g  \ (x :: forall a. a-> b) -> e
     -- Here we do bring 'b' into scope
 
@@ -101,88 +103,137 @@ rn_hs_sig_wc_type :: Bool   -- see rnImplicitBndrs
                   -> RnM (a, FreeVars)
 -- rn_hs_sig_wc_type is used for source-language type signatures
 rn_hs_sig_wc_type no_implicit_if_forall ctxt
-                  (HsIB { hsib_body = wc_ty }) thing_inside
-  = rnImplicitBndrs no_implicit_if_forall (hswc_body wc_ty) $ \ vars ->
-    rn_hs_wc_type ctxt wc_ty $ \ wc_ty' ->
-    thing_inside (HsIB { hsib_vars = vars
-                       , hsib_body = wc_ty' })
+                  (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
+                  thing_inside
+  = do { free_vars <- extractFilteredRdrTyVars hs_ty
+       ; (tv_rdrs, nwc_rdrs) <- partition_nwcs free_vars
+       ; rnImplicitBndrs no_implicit_if_forall tv_rdrs hs_ty $ \ vars ->
+    do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
+       ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = ib_ty' }
+             ib_ty'  = HsIB { hsib_vars = vars, hsib_body = hs_ty' }
+       ; (res, fvs2) <- thing_inside sig_ty'
+       ; return (res, fvs1 `plusFV` fvs2) } }
 
 rnHsWcType :: HsDocContext -> LHsWcType RdrName -> RnM (LHsWcType Name, FreeVars)
-rnHsWcType ctxt wc_ty
-  = rn_hs_wc_type ctxt wc_ty $ \ wc_ty' ->
-    return (wc_ty', emptyFVs)
+rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
+  = do { free_vars <- extractFilteredRdrTyVars hs_ty
+       ; (_, nwc_rdrs) <- partition_nwcs free_vars
+       ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty
+       ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = hs_ty' }
+       ; return (sig_ty', fvs) }
+
+rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType RdrName
+         -> RnM ([Name], LHsType Name, FreeVars)
+rnWcBody ctxt nwc_rdrs hs_ty
+  = do { nwcs <- mapM newLocalBndrRn nwc_rdrs
+       ; let env = RTKE { rtke_level = TypeLevel
+                        , rtke_what  = RnTypeBody
+                        , rtke_nwcs  = mkNameSet nwcs
+                        , rtke_ctxt  = ctxt }
+       ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $
+                          rn_lty env hs_ty
+       ; let awcs = collectAnonWildCards hs_ty'
+       ; return (nwcs ++ awcs, hs_ty', fvs) }
+  where
+    rn_lty env (L loc hs_ty)
+      = setSrcSpan loc $
+        do { (hs_ty', fvs) <- rn_ty env hs_ty
+           ; return (L loc hs_ty', fvs) }
+
+    rn_ty :: RnTyKiEnv -> HsType RdrName -> RnM (HsType Name, FreeVars)
+    -- A lot of faff just to allow the extra-constraints wildcard to appear
+    rn_ty env hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_body })
+      = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty)
+                           Nothing [] tvs $ \ _ tvs' _ _ ->
+        do { (hs_body', fvs) <- rn_lty env hs_body
+           ; return (HsForAllTy { hst_bndrs = tvs', hst_body = hs_body' }, fvs) }
+
+    rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt, hst_body = hs_ty })
+      | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
+      , L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last
+      = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
+           ; wc' <- setSrcSpan lx $
+                    do { checkExtraConstraintWildCard env wc
+                       ; rnAnonWildCard wc }
+           ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')]
+           ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
+           ; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
+                    , fvs1 `plusFV` fvs2) }
+
+      | otherwise
+      = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt
+           ; (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty
+           ; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
+                    , fvs1 `plusFV` fvs2) }
+
+    rn_ty env hs_ty = rnHsTyKi env hs_ty
+
+    rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })
+
+
+checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo RdrName
+                             -> RnM ()
+-- Rename the extra-constraint spot in a type signature
+--    (blah, _) => type
+-- Check that extra-constraints are allowed at all, and
+-- if so that it's an anonymous wildcard
+checkExtraConstraintWildCard env wc
+  = checkWildCard env mb_bad
+  where
+    mb_bad | not (extraConstraintWildCardsAllowed env)
+           = Just (text "Extra-constraint wildcard" <+> quotes (ppr wc)
+                   <+> text "not allowed")
+           | otherwise
+           = Nothing
 
-rn_hs_wc_type :: HsDocContext -> LHsWcType RdrName
-              -> (LHsWcType Name -> RnM (a, FreeVars))
-              -> RnM (a, FreeVars)
-rn_hs_wc_type ctxt (HsWC { hswc_body = hs_ty }) thing_inside
-  = do { let nwc_rdrs = collectNamedWildCards hs_ty
-       ; rdr_env <- getLocalRdrEnv
-       ; nwcs <- sequence [ newLocalBndrRn lrdr
-                          | lrdr@(L _ rdr) <- nwc_rdrs
-                          , not (inScope rdr_env rdr) ]
-                 -- nwcs :: [Name]   Named wildcards
-       ; bindLocalNamesFV nwcs $
-    do { (wc_ty, fvs1) <- rnWcSigTy ctxt hs_ty
-       ; let wc_ty' :: HsWildCardBndrs Name (LHsType Name)
-             wc_ty' = wc_ty { hswc_wcs = nwcs ++ hswc_wcs wc_ty }
-       ; (res, fvs2) <- thing_inside wc_ty'
-       ; return (res, fvs1 `plusFV` fvs2) } }
+extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
+extraConstraintWildCardsAllowed env
+  = case rtke_ctxt env of
+      TypeSigCtx {}       -> True
+      ExprWithTySigCtx {} -> True
+      _                   -> False
 
-rnWcSigTy :: HsDocContext -> LHsType RdrName
-          -> RnM (LHsWcType Name, FreeVars)
--- Renames just the top level of a type signature
--- It's exactly like rnHsTyKi, except that it uses rnWcSigContext
--- on a qualified type, and return info on any extra-constraints
--- wildcard.  Some code duplication, but no big deal.
-rnWcSigTy ctxt (L loc hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_tau }))
-  = bindLHsTyVarBndrs ctxt Nothing [] tvs $ \ _ tvs' ->
-    do { (hs_tau', fvs) <- rnWcSigTy ctxt hs_tau
-       ; warnUnusedForAlls (inTypeDoc hs_ty) tvs' fvs
-       ; let hs_ty' = HsForAllTy { hst_bndrs = tvs', hst_body = hswc_body hs_tau' }
-       ; return ( hs_tau' { hswc_body = L loc hs_ty' }, fvs) }
-
-rnWcSigTy ctxt (L loc (HsQualTy { hst_ctxt = hs_ctxt, hst_body = tau }))
-  = do { (hs_ctxt', fvs1) <- rnWcSigContext ctxt hs_ctxt
-       ; (tau',     fvs2) <- rnLHsType ctxt tau
-       ; let awcs_tau = collectAnonWildCards tau'
-             hs_ty'   = HsQualTy { hst_ctxt = hswc_body hs_ctxt'
-                                 , hst_body = tau' }
-       ; return ( HsWC { hswc_wcs = hswc_wcs hs_ctxt' ++ awcs_tau
-                       , hswc_ctx = hswc_ctx hs_ctxt'
-                       , hswc_body = L loc hs_ty' }
-                , fvs1 `plusFV` fvs2) }
+-- | Finds free type and kind variables in a type,
+--     without duplicates, and
+--     without variables that are already in scope in LocalRdrEnv
+--   NB: this includes named wildcards, which look like perfectly
+--       ordinary type variables at this point
+extractFilteredRdrTyVars :: LHsType RdrName -> RnM FreeKiTyVars
+extractFilteredRdrTyVars hs_ty
+  = do { rdr_env <- getLocalRdrEnv
+       ; filterInScope rdr_env <$> extractHsTyRdrTyVars hs_ty }
+
+-- | When the NamedWildCards extension is enabled, partition_nwcs
+-- removes type variables that start with an underscore from the
+-- FreeKiTyVars in the argument and returns them in a separate list.
+-- When the extension is disabled, the function returns the argument
+-- and empty list.  See Note [Renaming named wild cards]
+partition_nwcs :: FreeKiTyVars -> RnM (FreeKiTyVars, [Located RdrName])
+partition_nwcs free_vars@(FKTV { fktv_tys = tys, fktv_all = all })
+  = do { wildcards_enabled <- fmap (xopt LangExt.NamedWildCards) getDynFlags
+       ; let (nwcs, no_nwcs) | wildcards_enabled = partition is_wildcard tys
+                             | otherwise         = ([], tys)
+             free_vars' = free_vars { fktv_tys = no_nwcs
+                                    , fktv_all = all \\ nwcs }
+       ; return (free_vars', nwcs) }
+  where
+     is_wildcard :: Located RdrName -> Bool
+     is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr))
 
-rnWcSigTy ctxt hs_ty
-  = do { (hs_ty', fvs) <- rnLHsType ctxt hs_ty
-       ; return (HsWC { hswc_wcs = collectAnonWildCards hs_ty'
-                      , hswc_ctx = Nothing
-                      , hswc_body = hs_ty' }
-                , fvs) }
-
-rnWcSigContext :: HsDocContext -> LHsContext RdrName
-               -> RnM (HsWildCardBndrs Name (LHsContext Name), FreeVars)
-rnWcSigContext ctxt (L loc hs_ctxt)
-  | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
-  , L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last
-  = do { (hs_ctxt1', fvs) <- mapFvRn (rnLHsTyKi RnTopConstraint ctxt) hs_ctxt1
-       ; wc'              <- setSrcSpan lx $
-                             rnExtraConstraintWildCard ctxt wc
-       ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')]
-             awcs     = concatMap collectAnonWildCards hs_ctxt1'
-             -- NB: *not* including the extra-constraint wildcard
-       ; return ( HsWC { hswc_wcs = awcs
-                       , hswc_ctx = Just lx
-                       , hswc_body = L loc hs_ctxt' }
-                , fvs ) }
-  | otherwise
-  = do { (hs_ctxt', fvs) <- mapFvRn (rnLHsTyKi RnTopConstraint ctxt) hs_ctxt
-       ; return (HsWC { hswc_wcs = concatMap collectAnonWildCards hs_ctxt'
-                      , hswc_ctx = Nothing
-                      , hswc_body = L loc hs_ctxt' }, fvs) }
+{- Note [Renaming named wild cards]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Identifiers starting with an underscore are always parsed as type variables.
+It is only here in the renamer that we give the special treatment.
+See Note [The wildcard story for types] in HsTypes.
 
+It's easy!  When we collect the implicitly bound type variables, ready
+to bring them into scope, and NamedWildCards is on, we partition the
+variables into the ones that start with an underscore (the named
+wildcards) and the rest. Then we just add them to the hswc_wcs field
+of the HsWildCardBndrs structure, and we are done.
 
-{- ******************************************************
+
+*********************************************************
 *                                                       *
            HsSigtype (i.e. no wildcards)
 *                                                       *
@@ -193,30 +244,32 @@ rnHsSigType :: HsDocContext -> LHsSigType RdrName
 -- Used for source-language type signatures
 -- that cannot have wildcards
 rnHsSigType ctx (HsIB { hsib_body = hs_ty })
-  = rnImplicitBndrs True hs_ty $ \ vars ->
+  = do { vars <- extractFilteredRdrTyVars hs_ty
+       ; rnImplicitBndrs True vars hs_ty $ \ vars ->
     do { (body', fvs) <- rnLHsType ctx hs_ty
        ; return (HsIB { hsib_vars = vars
-                      , hsib_body = body' }, fvs) }
+                      , hsib_body = body' }, fvs) } }
 
 rnImplicitBndrs :: Bool    -- True <=> no implicit quantification
                            --          if type is headed by a forall
                            -- E.g.  f :: forall a. a->b
                            -- Do not quantify over 'b' too.
+                -> FreeKiTyVars
                 -> LHsType RdrName
                 -> ([Name] -> RnM (a, FreeVars))
                 -> RnM (a, FreeVars)
-rnImplicitBndrs no_implicit_if_forall hs_ty@(L loc _) thing_inside
-  = do { rdr_env <- getLocalRdrEnv
-       ; free_vars <- filterInScope rdr_env <$>
-                      extractHsTyRdrTyVars hs_ty
-       ; let real_tv_rdrs  -- Implicit quantification only if
-                        -- there is no explicit forall
+rnImplicitBndrs no_implicit_if_forall free_vars hs_ty@(L loc _) thing_inside
+  = do { let real_tv_rdrs  -- Implicit quantification only if
+                           -- there is no explicit forall
                | no_implicit_if_forall
                , L _ (HsForAllTy {}) <- hs_ty = []
                | otherwise                    = freeKiTyVarsTypeVars free_vars
              real_rdrs = freeKiTyVarsKindVars free_vars ++ real_tv_rdrs
-       ; traceRn (text "rnSigType" <+> (ppr hs_ty $$ ppr free_vars $$
-                                        ppr real_rdrs))
+       ; traceRn "rnSigType" (ppr hs_ty $$ ppr free_vars $$
+                                        ppr real_rdrs)
+
+       ; traceRn "" (text "rnSigType2" <+> ppr hs_ty $$ ppr free_vars $$
+                                        ppr real_rdrs)
        ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_rdrs
        ; bindLocalNamesFV vars $
          thing_inside vars }
@@ -229,14 +282,14 @@ rnLHsInstType doc_str inst_ty
   , isTcOcc (rdrNameOcc (unLoc cls))
          -- The guards check that the instance type looks like
          --   blah => C ty1 .. tyn
-  = do { let full_doc = doc_str <+> ptext (sLit "for") <+> quotes (ppr cls)
+  = do { let full_doc = doc_str <+> text "for" <+> quotes (ppr cls)
        ; rnHsSigType (GenericCtx full_doc) inst_ty }
 
   | otherwise  -- The instance is malformed, but we'd still like
                -- to make progress rather than failing outright, so
                -- we report more errors.  So we rename it anyway.
   = do { addErrAt (getLoc (hsSigType inst_ty)) $
-         ptext (sLit "Malformed instance:") <+> ppr inst_ty
+         text "Malformed instance:" <+> ppr inst_ty
        ; rnHsSigType (GenericCtx doc_str) inst_ty }
 
 
@@ -297,112 +350,159 @@ and
 as our lists. We can then do normal fixity resolution on these. The fixities
 must come along for the ride just so that the list stays in sync with the
 operators.
+
+Note [QualTy in kinds]
+~~~~~~~~~~~~~~~~~~~~~~
+I was wondering whether QualTy could occur only at TypeLevel.  But no,
+we can have a qualified type in a kind too. Here is an example:
+
+  type family F a where
+    F Bool = Nat
+    F Nat  = Type
+
+  type family G a where
+    G Type = Type -> Type
+    G ()   = Nat
+
+  data X :: forall k1 k2. (F k1 ~ G k2) => k1 -> k2 -> Type where
+    MkX :: X 'True '()
+
+See that k1 becomes Bool and k2 becomes (), so the equality is
+satisfied. If I write MkX :: X 'True 'False, compilation fails with a
+suitable message:
+
+  MkX :: X 'True '()
+    • Couldn't match kind ‘G Bool’ with ‘Nat’
+      Expected kind: G Bool
+        Actual kind: F Bool
+
+However: in a kind, the constraints in the QualTy must all be
+equalities; or at least, any kinds with a class constraint are
+uninhabited.
 -}
 
-rnLHsTyKi  :: RnTyKiWhat
-           -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
-rnLHsTyKi what doc (L loc ty)
-  = setSrcSpan loc $
-    do { (ty', fvs) <- rnHsTyKi what doc ty
-       ; return (L loc ty', fvs) }
+data RnTyKiEnv
+  = RTKE { rtke_ctxt  :: HsDocContext
+         , rtke_level :: TypeOrKind  -- Am I renaming a type or a kind?
+         , rtke_what  :: RnTyKiWhat  -- And within that what am I renaming?
+         , rtke_nwcs  :: NameSet     -- These are the in-scope named wildcards
+    }
 
-rnLHsType  :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
-rnLHsType cxt ty = -- pprTrace "rnHsType" (pprHsDocContext cxt $$ ppr ty) $
-                   rnLHsTyKi (RnTypeBody TypeLevel) cxt ty
+data RnTyKiWhat = RnTypeBody
+                | RnTopConstraint   -- Top-level context of HsSigWcTypes
+                | RnConstraint      -- All other constraints
 
-rnLHsPred  :: RnTyKiWhat -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
-rnLHsPred (RnTypeBody level) = rnLHsTyKi (RnConstraint level)
-rnLHsPred what               = rnLHsTyKi what
+instance Outputable RnTyKiEnv where
+  ppr (RTKE { rtke_level = lev, rtke_what = what
+            , rtke_nwcs = wcs, rtke_ctxt = ctxt })
+    = text "RTKE"
+      <+> braces (sep [ ppr lev, ppr what, ppr wcs
+                      , pprHsDocContext ctxt ])
 
-rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
-rnLHsKind = rnLHsTyKi (RnTypeBody KindLevel)
+instance Outputable RnTyKiWhat where
+  ppr RnTypeBody      = text "RnTypeBody"
+  ppr RnTopConstraint = text "RnTopConstraint"
+  ppr RnConstraint    = text "RnConstraint"
 
-rnLHsMaybeKind  :: HsDocContext -> Maybe (LHsKind RdrName)
-                -> RnM (Maybe (LHsKind Name), FreeVars)
-rnLHsMaybeKind _ Nothing
-  = return (Nothing, emptyFVs)
-rnLHsMaybeKind doc (Just kind)
-  = do { (kind', fvs) <- rnLHsKind doc kind
-       ; return (Just kind', fvs) }
+mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
+mkTyKiEnv cxt level what
+ = RTKE { rtke_level = level, rtke_nwcs = emptyNameSet
+        , rtke_what = what, rtke_ctxt = cxt }
+
+isRnKindLevel :: RnTyKiEnv -> Bool
+isRnKindLevel (RTKE { rtke_level = KindLevel }) = True
+isRnKindLevel _                                 = False
+
+--------------
+rnLHsType  :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
+rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
+
+rnLHsTypes :: HsDocContext -> [LHsType RdrName] -> RnM ([LHsType Name], FreeVars)
+rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
 
 rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
-rnHsType cxt ty = rnHsTyKi (RnTypeBody TypeLevel) cxt ty
+rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
+
+rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
+rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
 
 rnHsKind  :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars)
-rnHsKind = rnHsTyKi (RnTypeBody KindLevel)
+rnHsKind ctxt kind = rnHsTyKi  (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
 
-data RnTyKiWhat = RnTypeBody TypeOrKind
-                | RnTopConstraint           -- Top-level context of HsSigWcTypes
-                | RnConstraint TypeOrKind   -- All other constraints
+--------------
+rnTyKiContext :: RnTyKiEnv -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
+rnTyKiContext env (L loc cxt)
+  = do { traceRn "rncontext" (ppr cxt)
+       ; let env' = env { rtke_what = RnConstraint }
+       ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt
+       ; return (L loc cxt', fvs) }
 
-instance Outputable RnTyKiWhat where
-  ppr (RnTypeBody lev)   = text "RnTypeBody" <+> ppr lev
-  ppr RnTopConstraint    = text "RnTopConstraint"
-  ppr (RnConstraint lev) = text "RnConstraint" <+> ppr lev
-
-isRnKindLevel :: RnTyKiWhat -> Bool
-isRnKindLevel (RnTypeBody KindLevel)   = True
-isRnKindLevel (RnConstraint KindLevel) = True
-isRnKindLevel _                        = False
-
-rnHsTyKi :: RnTyKiWhat -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
-
-rnHsTyKi what doc ty@(HsForAllTy { hst_bndrs = tyvars, hst_body  = tau })
-  = do { checkTypeInType what ty
-       ; bindLHsTyVarBndrs doc Nothing [] tyvars $ \ _ tyvars' ->
-    do { (tau',  fvs) <- rnLHsTyKi what doc tau
-       ; warnUnusedForAlls (inTypeDoc ty) tyvars' fvs
+rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
+rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta
+
+--------------
+rnLHsTyKi  :: RnTyKiEnv -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
+rnLHsTyKi env (L loc ty)
+  = setSrcSpan loc $
+    do { (ty', fvs) <- rnHsTyKi env ty
+       ; return (L loc ty', fvs) }
+
+rnHsTyKi :: RnTyKiEnv -> HsType RdrName -> RnM (HsType Name, FreeVars)
+
+rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body  = tau })
+  = do { checkTypeInType env ty
+       ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)
+                           Nothing [] tyvars $ \ _ tyvars' _ _ ->
+    do { (tau',  fvs) <- rnLHsTyKi env tau
        ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body =  tau' }
-                , fvs) }}
+                , fvs) } }
 
-rnHsTyKi what doc ty@(HsQualTy { hst_ctxt = lctxt
-                               , hst_body = tau })
-  = do { checkTypeInType what ty
-       ; (ctxt', fvs1) <- rnTyKiContext what doc lctxt
-       ; (tau',  fvs2) <- rnLHsTyKi what doc tau
+rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })
+  = do { checkTypeInType env ty  -- See Note [QualTy in kinds]
+       ; (ctxt', fvs1) <- rnTyKiContext env lctxt
+       ; (tau',  fvs2) <- rnLHsTyKi env tau
        ; return (HsQualTy { hst_ctxt = ctxt', hst_body =  tau' }
                 , fvs1 `plusFV` fvs2) }
 
-rnHsTyKi what _ (HsTyVar (L loc rdr_name))
-  = do { name <- rnTyVar what rdr_name
+rnHsTyKi env (HsTyVar (L loc rdr_name))
+  = do { name <- rnTyVar env rdr_name
        ; return (HsTyVar (L loc name), unitFV name) }
 
-rnHsTyKi what doc ty@(HsOpTy ty1 l_op ty2)
+rnHsTyKi env ty@(HsOpTy ty1 l_op ty2)
   = setSrcSpan (getLoc l_op) $
-    do  { (l_op', fvs1) <- rnHsTyOp what ty l_op
+    do  { (l_op', fvs1) <- rnHsTyOp env ty l_op
         ; fix   <- lookupTyFixityRn l_op'
-        ; (ty1', fvs2) <- rnLHsTyKi what doc ty1
-        ; (ty2', fvs3) <- rnLHsTyKi what doc ty2
+        ; (ty1', fvs2) <- rnLHsTyKi env ty1
+        ; (ty2', fvs3) <- rnLHsTyKi env ty2
         ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2)
                                (unLoc l_op') fix ty1' ty2'
         ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
 
-rnHsTyKi what doc (HsParTy ty)
-  = do { (ty', fvs) <- rnLHsTyKi what doc ty
+rnHsTyKi env (HsParTy ty)
+  = do { (ty', fvs) <- rnLHsTyKi env ty
        ; return (HsParTy ty', fvs) }
 
-rnHsTyKi _ doc (HsBangTy b ty)
-  = do { (ty', fvs) <- rnLHsType doc ty
+rnHsTyKi env (HsBangTy b ty)
+  = do { (ty', fvs) <- rnLHsTyKi env ty
        ; return (HsBangTy b ty', fvs) }
 
-rnHsTyKi _ doc@(ConDeclCtx names) (HsRecTy flds)
-  = do {
-       -- AZ:reviewers: is there a monadic version of concatMap?
-         flss <- mapM (lookupConstructorFields . unLoc) names
-       ; let fls = concat flss
-       ; (flds', fvs) <- rnConDeclFields fls doc flds
-       ; return (HsRecTy flds', fvs) }
-
-rnHsTyKi _ doc ty@(HsRecTy flds)
-  = do { addErr (hang (ptext (sLit "Record syntax is illegal here:"))
-                    2 (ppr ty))
-       ; (flds', fvs) <- rnConDeclFields [] doc flds
+rnHsTyKi env ty@(HsRecTy flds)
+  = do { let ctxt = rtke_ctxt env
+       ; fls          <- get_fields ctxt
+       ; (flds', fvs) <- rnConDeclFields ctxt fls flds
        ; return (HsRecTy flds', fvs) }
-
-rnHsTyKi what doc (HsFunTy ty1 ty2)
-  = do { (ty1', fvs1) <- rnLHsTyKi what doc ty1
+  where
+    get_fields (ConDeclCtx names)
+      = concatMapM (lookupConstructorFields . unLoc) names
+    get_fields _
+      = do { addErr (hang (text "Record syntax is illegal here:")
+                                   2 (ppr ty))
+           ; return [] }
+
+rnHsTyKi env (HsFunTy ty1 ty2)
+  = do { (ty1', fvs1) <- rnLHsTyKi env ty1
         -- Might find a for-all as the arg of a function type
-       ; (ty2', fvs2) <- rnLHsTyKi what doc ty2
+       ; (ty2', fvs2) <- rnLHsTyKi env ty2
         -- Or as the result.  This happens when reading Prelude.hi
         -- when we find return :: forall m. Monad m -> forall a. a -> m a
 
@@ -410,54 +510,61 @@ rnHsTyKi what doc (HsFunTy ty1 ty2)
        ; res_ty <- mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
        ; return (res_ty, fvs1 `plusFV` fvs2) }
 
-rnHsTyKi what doc listTy@(HsListTy ty)
+rnHsTyKi env listTy@(HsListTy ty)
   = do { data_kinds <- xoptM LangExt.DataKinds
-       ; when (not data_kinds && isRnKindLevel what)
-              (addErr (dataKindsErr what listTy))
-       ; (ty', fvs) <- rnLHsTyKi what doc ty
+       ; when (not data_kinds && isRnKindLevel env)
+              (addErr (dataKindsErr env listTy))
+       ; (ty', fvs) <- rnLHsTyKi env ty
        ; return (HsListTy ty', fvs) }
 
-rnHsTyKi what doc t@(HsKindSig ty k)
-  = do { checkTypeInType what t
+rnHsTyKi env t@(HsKindSig ty k)
+  = do { checkTypeInType env t
        ; kind_sigs_ok <- xoptM LangExt.KindSignatures
-       ; unless kind_sigs_ok (badKindSigErr doc ty)
-       ; (ty', fvs1) <- rnLHsTyKi what doc ty
-       ; (k', fvs2) <- rnLHsKind doc k
+       ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)
+       ; (ty', fvs1) <- rnLHsTyKi env ty
+       ; (k', fvs2)  <- rnLHsTyKi (env { rtke_level = KindLevel }) k
        ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) }
 
-rnHsTyKi what doc t@(HsPArrTy ty)
-  = do { notInKinds what t
-       ; (ty', fvs) <- rnLHsType doc ty
+rnHsTyKi env t@(HsPArrTy ty)
+  = do { notInKinds env t
+       ; (ty', fvs) <- rnLHsTyKi env ty
        ; return (HsPArrTy ty', fvs) }
 
 -- Unboxed tuples are allowed to have poly-typed arguments.  These
 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
-rnHsTyKi what doc tupleTy@(HsTupleTy tup_con tys)
+rnHsTyKi env tupleTy@(HsTupleTy tup_con tys)
   = do { data_kinds <- xoptM LangExt.DataKinds
-       ; when (not data_kinds && isRnKindLevel what)
-              (addErr (dataKindsErr what tupleTy))
-       ; (tys', fvs) <- mapFvRn (rnLHsTyKi what doc) tys
+       ; when (not data_kinds && isRnKindLevel env)
+              (addErr (dataKindsErr env tupleTy))
+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
        ; return (HsTupleTy tup_con tys', fvs) }
 
+rnHsTyKi env sumTy@(HsSumTy tys)
+  = do { data_kinds <- xoptM LangExt.DataKinds
+       ; when (not data_kinds && isRnKindLevel env)
+              (addErr (dataKindsErr env sumTy))
+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
+       ; return (HsSumTy tys', fvs) }
+
 -- Ensure that a type-level integer is nonnegative (#8306, #8412)
-rnHsTyKi what _ tyLit@(HsTyLit t)
+rnHsTyKi env tyLit@(HsTyLit t)
   = do { data_kinds <- xoptM LangExt.DataKinds
-       ; unless data_kinds (addErr (dataKindsErr what tyLit))
+       ; unless data_kinds (addErr (dataKindsErr env tyLit))
        ; when (negLit t) (addErr negLitErr)
-       ; checkTypeInType what tyLit
+       ; checkTypeInType env tyLit
        ; return (HsTyLit t, emptyFVs) }
   where
     negLit (HsStrTy _ _) = False
     negLit (HsNumTy _ i) = i < 0
-    negLitErr = ptext (sLit "Illegal literal in type (type literals must not be negative):") <+> ppr tyLit
+    negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit
 
-rnHsTyKi isType doc overall_ty@(HsAppsTy tys)
+rnHsTyKi env overall_ty@(HsAppsTy tys)
   = do { -- Step 1: Break up the HsAppsTy into symbols and non-symbol regions
          let (non_syms, syms) = splitHsAppsTy tys
 
              -- Step 2: rename the pieces
-       ; (syms1, fvs1)      <- mapFvRn (rnHsTyOp isType overall_ty) syms
-       ; (non_syms1, fvs2)  <- (mapFvRn . mapFvRn) (rnLHsTyKi isType doc) non_syms
+       ; (syms1, fvs1)      <- mapFvRn (rnHsTyOp env overall_ty) syms
+       ; (non_syms1, fvs2)  <- (mapFvRn . mapFvRn) (rnLHsTyKi env) non_syms
 
              -- Step 3: deal with *. See Note [Dealing with *]
        ; let (non_syms2, syms2) = deal_with_star [] [] non_syms1 syms1
@@ -507,107 +614,78 @@ rnHsTyKi isType doc overall_ty@(HsAppsTy tys)
     build_res_ty [arg] [] = return arg
     build_res_ty _ _ = pprPanic "build_op_ty" (ppr overall_ty)
 
-rnHsTyKi what doc (HsAppTy ty1 ty2)
-  = do { (ty1', fvs1) <- rnLHsTyKi what doc ty1
-       ; (ty2', fvs2) <- rnLHsTyKi what doc ty2
+rnHsTyKi env (HsAppTy ty1 ty2)
+  = do { (ty1', fvs1) <- rnLHsTyKi env ty1
+       ; (ty2', fvs2) <- rnLHsTyKi env ty2
        ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) }
 
-rnHsTyKi what doc t@(HsIParamTy n ty)
-  = do { notInKinds what t
-       ; (ty', fvs) <- rnLHsType doc ty
+rnHsTyKi env t@(HsIParamTy n ty)
+  = do { notInKinds env t
+       ; (ty', fvs) <- rnLHsTyKi env ty
        ; return (HsIParamTy n ty', fvs) }
 
-rnHsTyKi what doc t@(HsEqTy ty1 ty2)
-  = do { checkTypeInType what t
-       ; (ty1', fvs1) <- rnLHsTyKi what doc ty1
-       ; (ty2', fvs2) <- rnLHsTyKi what doc ty2
+rnHsTyKi env t@(HsEqTy ty1 ty2)
+  = do { checkTypeInType env t
+       ; (ty1', fvs1) <- rnLHsTyKi env ty1
+       ; (ty2', fvs2) <- rnLHsTyKi env ty2
        ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
 
-rnHsTyKi _ (HsSpliceTy sp k)
+rnHsTyKi _ (HsSpliceTy sp k)
   = rnSpliceType sp k
 
-rnHsTyKi _ doc (HsDocTy ty haddock_doc)
-  = do { (ty', fvs) <- rnLHsType doc ty
+rnHsTyKi env (HsDocTy ty haddock_doc)
+  = do { (ty', fvs) <- rnLHsTyKi env ty
        ; haddock_doc' <- rnLHsDoc haddock_doc
        ; return (HsDocTy ty' haddock_doc', fvs) }
 
-rnHsTyKi _ (HsCoreTy ty)
+rnHsTyKi _ (HsCoreTy ty)
   = return (HsCoreTy ty, emptyFVs)
     -- The emptyFVs probably isn't quite right
     -- but I don't think it matters
 
-rnHsTyKi what doc ty@(HsExplicitListTy k tys)
-  = do { checkTypeInType what ty
+rnHsTyKi env ty@(HsExplicitListTy k tys)
+  = do { checkTypeInType env ty
        ; data_kinds <- xoptM LangExt.DataKinds
-       ; unless data_kinds (addErr (dataKindsErr what ty))
-       ; (tys', fvs) <- mapFvRn (rnLHsTyKi what doc) tys
+       ; unless data_kinds (addErr (dataKindsErr env ty))
+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
        ; return (HsExplicitListTy k tys', fvs) }
 
-rnHsTyKi what doc ty@(HsExplicitTupleTy kis tys)
-  = do { checkTypeInType what ty
+rnHsTyKi env ty@(HsExplicitTupleTy kis tys)
+  = do { checkTypeInType env ty
        ; data_kinds <- xoptM LangExt.DataKinds
-       ; unless data_kinds (addErr (dataKindsErr what ty))
-       ; (tys', fvs) <- mapFvRn (rnLHsTyKi what doc) tys
+       ; unless data_kinds (addErr (dataKindsErr env ty))
+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
        ; return (HsExplicitTupleTy kis tys', fvs) }
 
-rnHsTyKi what ctxt (HsWildCardTy wc)
-  = do { wc' <- case mb_bad of
-           Just msg -> do { addErr (wildCardMsg ctxt msg)
-                          ; discardErrs (rnWildCard ctxt wc) }
-                          -- discardErrs: avoid reporting
-                          -- a second error
-           Nothing  -> rnWildCard ctxt wc
-
-       ; traceRn (text "rnHsTyKi wild" <+> ppr wc <+> ppr (isJust mb_bad))
+rnHsTyKi env (HsWildCardTy wc)
+  = do { checkAnonWildCard env wc
+       ; wc' <- rnAnonWildCard wc
        ; return (HsWildCardTy wc', emptyFVs) }
          -- emptyFVs: this occurrence does not refer to a
          --           user-written binding site, so don't treat
          --           it as a free variable
-  where
-    mb_bad :: Maybe SDoc
-    mb_bad | not (wildCardsAllowed ctxt)
-           = Just (notAllowed wc)
-           | otherwise
-           = case what of
-               RnTypeBody _    -> Nothing
-               RnConstraint _  -> Just constraint_msg
-               RnTopConstraint -> case wc of
-                     AnonWildCard {}  -> Just constraint_msg
-                     NamedWildCard {} -> Nothing
-
-    constraint_msg = hang (notAllowed wc <+> ptext (sLit "in a constraint"))
-                        2 hint_msg
-
-    hint_msg = case wc of
-       NamedWildCard {} -> empty
-       AnonWildCard {}  -> vcat [ ptext (sLit "except as the last top-level constraint of a type signature")
-                                , nest 2 (ptext (sLit "e.g  f :: (Eq a, _) => blah")) ]
-
-notAllowed :: HsWildCardInfo RdrName -> SDoc
-notAllowed wc =  ptext (sLit "Wildcard") <+> quotes (ppr wc)
-                 <+> ptext (sLit "not allowed")
-
-wildCardMsg :: HsDocContext -> SDoc -> SDoc
-wildCardMsg ctxt doc
-  = vcat [doc, nest 2 (ptext (sLit "in") <+> pprHsDocContext ctxt)]
 
 --------------
-rnTyVar :: RnTyKiWhat -> RdrName -> RnM Name
-rnTyVar what rdr_name
-  | isRnKindLevel what = lookupKindOccRn rdr_name
-  | otherwise          = lookupTypeOccRn rdr_name
+rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
+rnTyVar env rdr_name
+  = do { name <- if   isRnKindLevel env
+                 then lookupKindOccRn rdr_name
+                 else lookupTypeOccRn rdr_name
+       ; checkNamedWildCard env name
+       ; return name }
 
 rnLTyVar :: Located RdrName -> RnM (Located Name)
+-- Called externally; does not deal with wildards
 rnLTyVar (L loc rdr_name)
   = do { tyvar <- lookupTypeOccRn rdr_name
        ; return (L loc tyvar) }
 
 --------------
 rnHsTyOp :: Outputable a
-         => RnTyKiWhat -> a -> Located RdrName -> RnM (Located Name, FreeVars)
-rnHsTyOp what overall_ty (L loc op)
+         => RnTyKiEnv -> a -> Located RdrName -> RnM (Located Name, FreeVars)
+rnHsTyOp env overall_ty (L loc op)
   = do { ops_ok <- xoptM LangExt.TypeOperators
-       ; op' <- rnTyVar what op
+       ; op' <- rnTyVar env op
        ; unless (ops_ok
                  || op' == starKindTyConName
                  || op' == unicodeStarKindTyConName
@@ -617,21 +695,55 @@ rnHsTyOp what overall_ty (L loc op)
        ; return (l_op', unitFV op') }
 
 --------------
-rnLHsTypes :: HsDocContext -> [LHsType RdrName]
-           -> RnM ([LHsType Name], FreeVars)
-rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
+notAllowed :: SDoc -> SDoc
+notAllowed doc
+  = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed")
+
+checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()
+checkWildCard env (Just doc)
+  = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))]
+checkWildCard _ Nothing
+  = return ()
 
---------------
-extraConstraintWildCardsAllowed :: HsDocContext -> Bool
-extraConstraintWildCardsAllowed ctxt
-  = case ctxt of
-      TypeSigCtx {}       -> True
-      _                   -> False
+checkAnonWildCard :: RnTyKiEnv -> HsWildCardInfo RdrName -> RnM ()
+-- Report an error if an anonymoous wildcard is illegal here
+checkAnonWildCard env wc
+  = checkWildCard env mb_bad
+  where
+    mb_bad :: Maybe SDoc
+    mb_bad | not (wildCardsAllowed env)
+           = Just (notAllowed (ppr wc))
+           | otherwise
+           = case rtke_what env of
+               RnTypeBody      -> Nothing
+               RnConstraint    -> Just constraint_msg
+               RnTopConstraint -> Just constraint_msg
+
+    constraint_msg = hang (notAllowed (ppr wc) <+> text "in a constraint")
+                        2 hint_msg
+    hint_msg = vcat [ text "except as the last top-level constraint of a type signature"
+                    , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]
+
+checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()
+-- Report an error if a named wildcard is illegal here
+checkNamedWildCard env name
+  = checkWildCard env mb_bad
+  where
+    mb_bad | not (name `elemNameSet` rtke_nwcs env)
+           = Nothing  -- Not a wildcard
+           | not (wildCardsAllowed env)
+           = Just (notAllowed (ppr name))
+           | otherwise
+           = case rtke_what env of
+               RnTypeBody      -> Nothing   -- Allowed
+               RnTopConstraint -> Nothing   -- Allowed
+               RnConstraint    -> Just constraint_msg
+    constraint_msg = notAllowed (ppr name) <+> text "in a constraint"
 
-wildCardsAllowed :: HsDocContext -> Bool
+wildCardsAllowed :: RnTyKiEnv -> Bool
 -- ^ In what contexts are wildcards permitted
-wildCardsAllowed ctxt
-   = case ctxt of
+wildCardsAllowed env
+   = case rtke_ctxt env of
        TypeSigCtx {}       -> True
        TypBrCtx {}         -> True   -- Template Haskell quoted type
        SpliceTypeCtx {}    -> True   -- Result of a Template Haskell splice
@@ -640,58 +752,24 @@ wildCardsAllowed ctxt
        RuleCtx {}          -> True
        FamPatCtx {}        -> True   -- Not named wildcards though
        GHCiCtx {}          -> True
+       HsTypeCtx {}        -> True
        _                   -> False
 
-rnExtraConstraintWildCard :: HsDocContext -> HsWildCardInfo RdrName
-                          -> RnM (HsWildCardInfo Name)
--- Rename the extra-constraint spot in a type signature
---    (blah, _) => type
--- Check that extra-constraints are allowed at all, and
--- if so that it's an anonymous wildcard
-rnExtraConstraintWildCard ctxt wc
-  = case mb_bad of
-      Nothing  -> rnWildCard ctxt wc
-      Just msg -> do { addErr (wildCardMsg ctxt msg)
-                     ; discardErrs (rnWildCard ctxt wc) }
-  where
-    mb_bad | not (extraConstraintWildCardsAllowed ctxt)
-           = Just (ptext (sLit "Extra-contraint wildcard") <+> quotes (ppr wc)
-                   <+> ptext (sLit "not allowed"))
-           | isNamedWildCard wc
-           = Just (hang (ptext (sLit "Named wildcard") <+> quotes (ppr wc)
-                         <+> ptext (sLit "not allowed as an extra-contraint"))
-                      2 (ptext (sLit "Use an anonymous wildcard instead")))
-           | otherwise
-           = Nothing
-
-rnWildCard :: HsDocContext -> HsWildCardInfo RdrName -> RnM (HsWildCardInfo Name)
-rnWildCard _ (AnonWildCard _)
+rnAnonWildCard :: HsWildCardInfo RdrName -> RnM (HsWildCardInfo Name)
+rnAnonWildCard (AnonWildCard _)
   = do { loc <- getSrcSpanM
        ; uniq <- newUnique
        ; let name = mkInternalName uniq (mkTyVarOcc "_") loc
        ; return (AnonWildCard (L loc name)) }
 
-rnWildCard ctxt wc@(NamedWildCard (L loc rdr_name))
-  -- NB: The parser only generates NamedWildCard if -XNamedWildCards
-  --     is on, so we don't need to check for that here
-  = do { mb_name <- lookupOccRn_maybe rdr_name
-       ; traceRn (text "rnWildCard named" <+> (ppr rdr_name $$ ppr mb_name))
-       ; case mb_name of
-           Just n  -> return (NamedWildCard (L loc n))
-           Nothing -> do { addErr msg  -- I'm not sure how this can happen
-                         ; return (NamedWildCard (L loc (mkUnboundNameRdr rdr_name))) } }
-  where
-    msg = wildCardMsg ctxt (notAllowed wc)
-
-
 ---------------
 -- | Ensures either that we're in a type or that -XTypeInType is set
 checkTypeInType :: Outputable ty
-                => RnTyKiWhat
+                => RnTyKiEnv
                 -> ty      -- ^ type
                 -> RnM ()
-checkTypeInType what ty
-  | isRnKindLevel what
+checkTypeInType env ty
+  | isRnKindLevel env
   = do { type_in_type <- xoptM LangExt.TypeInType
        ; unless type_in_type $
          addErr (text "Illegal kind:" <+> ppr ty $$
@@ -699,11 +777,11 @@ checkTypeInType what ty
 checkTypeInType _ _ = return ()
 
 notInKinds :: Outputable ty
-           => RnTyKiWhat
+           => RnTyKiEnv
            -> ty
            -> RnM ()
-notInKinds what ty
-  | isRnKindLevel what
+notInKinds env ty
+  | isRnKindLevel env
   = addErr (text "Illegal kind (even with TypeInType enabled):" <+> ppr ty)
 notInKinds _ _ = return ()
 
@@ -740,35 +818,48 @@ bindLRdrNames rdrs thing_inside
 ---------------
 bindHsQTyVars :: forall a b.
                  HsDocContext
+              -> Maybe SDoc         -- if we are to check for unused tvs,
+                                    -- a phrase like "in the type ..."
               -> Maybe a                 -- Just _  => an associated type decl
               -> [Located RdrName]       -- Kind variables from scope, in l-to-r
                                          -- order, but not from ...
               -> (LHsQTyVars RdrName)     -- ... these user-written tyvars
-              -> (LHsQTyVars Name -> RnM (b, FreeVars))
+              -> (LHsQTyVars Name -> NameSet -> RnM (b, FreeVars))
+                  -- also returns all names used in kind signatures, for the
+                  -- TypeInType clause of Note [Complete user-supplied kind
+                  -- signatures] in HsDecls
               -> RnM (b, FreeVars)
 -- (a) Bring kind variables into scope
 --     both (i)  passed in (kv_bndrs)
 --     and  (ii) mentioned in the kinds of tv_bndrs
 -- (b) Bring type variables into scope
-bindHsQTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
-  = do { bindLHsTyVarBndrs doc mb_assoc kv_bndrs (hsQTvExplicit tv_bndrs) $
-         \ rn_kvs rn_bndrs ->
+bindHsQTyVars doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
+  = do { bindLHsTyVarBndrs doc mb_in_doc
+                           mb_assoc kv_bndrs (hsQTvExplicit tv_bndrs) $
+         \ rn_kvs rn_bndrs dep_var_set all_dep_vars ->
          thing_inside (HsQTvs { hsq_implicit = rn_kvs
-                              , hsq_explicit = rn_bndrs }) }
+                              , hsq_explicit = rn_bndrs
+                              , hsq_dependent = dep_var_set }) all_dep_vars }
 
 bindLHsTyVarBndrs :: forall a b.
                      HsDocContext
+                  -> Maybe SDoc         -- if we are to check for unused tvs,
+                                        -- a phrase like "in the type ..."
                   -> Maybe a            -- Just _  => an associated type decl
                   -> [Located RdrName]  -- Unbound kind variables from scope,
                                         -- in l-to-r order, but not from ...
                   -> [LHsTyVarBndr RdrName]  -- ... these user-written tyvars
                   -> (   [Name]  -- all kv names
                       -> [LHsTyVarBndr Name]
+                      -> NameSet -- which names, from the preceding list,
+                                 -- are used dependently within that list
+                                 -- See Note [Dependent LHsQTyVars] in TcHsType
+                      -> NameSet -- all names used in kind signatures
                       -> RnM (b, FreeVars))
                   -> RnM (b, FreeVars)
-bindLHsTyVarBndrs doc mb_assoc kv_bndrs tv_bndrs thing_inside
+bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
   = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
-       ; go [] [] emptyNameSet emptyNameSet tv_bndrs }
+       ; go [] [] emptyNameSet emptyNameSet emptyNameSet tv_bndrs }
   where
     tv_names_w_loc = map hsLTyVarLocName tv_bndrs
 
@@ -776,34 +867,51 @@ bindLHsTyVarBndrs doc mb_assoc kv_bndrs tv_bndrs thing_inside
        -> [LHsTyVarBndr Name]    -- already renamed (in reverse order)
        -> NameSet                -- kind vars already in scope (for dup checking)
        -> NameSet                -- type vars already in scope (for dup checking)
+       -> NameSet                -- (all) variables used dependently
        -> [LHsTyVarBndr RdrName] -- still to be renamed, scoped
        -> RnM (b, FreeVars)
-    go rn_kvs rn_tvs kv_names tv_names (tv_bndr : tv_bndrs)
+    go rn_kvs rn_tvs kv_names tv_names dep_vars (tv_bndr : tv_bndrs)
       = bindLHsTyVarBndr doc mb_assoc kv_names tv_names tv_bndr $
-        \ kv_nms tv_bndr' -> go (reverse kv_nms ++ rn_kvs)
-                                (tv_bndr' : rn_tvs)
-                                (kv_names `extendNameSetList` kv_nms)
-                                (tv_names `extendNameSet` hsLTyVarName tv_bndr')
-                                tv_bndrs
-
-    go rn_kvs rn_tvs _kv_names tv_names []
+        \ kv_nms used_dependently tv_bndr' ->
+        do { (b, fvs) <- go (reverse kv_nms ++ rn_kvs)
+                            (tv_bndr' : rn_tvs)
+                            (kv_names `extendNameSetList` kv_nms)
+                            (tv_names `extendNameSet` hsLTyVarName tv_bndr')
+                            (dep_vars `unionNameSet` used_dependently)
+                            tv_bndrs
+           ; warn_unused tv_bndr' fvs
+           ; return (b, fvs) }
+
+    go rn_kvs rn_tvs _kv_names tv_names dep_vars []
       = -- still need to deal with the kv_bndrs passed in originally
-        bindImplicitKvs doc mb_assoc kv_bndrs tv_names $ \ kv_nms ->
+        bindImplicitKvs doc mb_assoc kv_bndrs tv_names $ \ kv_nms others ->
         do { let all_rn_kvs = reverse (reverse kv_nms ++ rn_kvs)
                  all_rn_tvs = reverse rn_tvs
            ; env <- getLocalRdrEnv
-           ; traceRn (text "bindHsTyVars" <+> (ppr env $$
-                                               ppr all_rn_kvs $$
-                                               ppr all_rn_tvs))
-           ; thing_inside all_rn_kvs all_rn_tvs }
+           ; let all_dep_vars = dep_vars `unionNameSet` others
+                 exp_dep_vars -- variables in all_rn_tvs that are in dep_vars
+                   = mkNameSet [ name
+                               | v <- all_rn_tvs
+                               , let name = hsLTyVarName v
+                               , name `elemNameSet` all_dep_vars ]
+           ; traceRn "bindHsTyVars" (ppr env $$
+                                     ppr all_rn_kvs $$
+                                     ppr all_rn_tvs $$
+                                     ppr exp_dep_vars)
+           ; thing_inside all_rn_kvs all_rn_tvs exp_dep_vars all_dep_vars }
+
+    warn_unused tv_bndr fvs = case mb_in_doc of
+      Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs
+      Nothing     -> return ()
 
 bindLHsTyVarBndr :: HsDocContext
                  -> Maybe a   -- associated class
                  -> NameSet   -- kind vars already in scope
                  -> NameSet   -- type vars already in scope
                  -> LHsTyVarBndr RdrName
-                 -> ([Name] -> LHsTyVarBndr Name -> RnM (b, FreeVars))
+                 -> ([Name] -> NameSet -> LHsTyVarBndr Name -> RnM (b, FreeVars))
                    -- passed the newly-bound implicitly-declared kind vars,
+                   -- any other names used in a kind
                    -- and the renamed LHsTyVarBndr
                  -> RnM (b, FreeVars)
 bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside
@@ -812,7 +920,7 @@ bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside
         do { check_dup loc rdr
            ; nm <- newTyVarNameRn mb_assoc lrdr
            ; bindLocalNamesFV [nm] $
-             thing_inside [] (L loc (UserTyVar (L lv nm))) }
+             thing_inside [] emptyNameSet (L loc (UserTyVar (L lv nm))) }
       L loc (KindedTyVar lrdr@(L lv rdr) kind) ->
         do { check_dup lv rdr
 
@@ -822,11 +930,12 @@ bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside
 
              -- deal with kind vars in the user-written kind
            ; free_kvs <- freeKiTyVarsAllVars <$> extractHsTyRdrTyVars kind
-           ; bindImplicitKvs doc mb_assoc free_kvs tv_names $ \ kv_nms ->
+           ; bindImplicitKvs doc mb_assoc free_kvs tv_names $
+             \ new_kv_nms other_kv_nms ->
              do { (kind', fvs1) <- rnLHsKind doc kind
                 ; tv_nm  <- newTyVarNameRn mb_assoc lrdr
                 ; (b, fvs2) <- bindLocalNamesFV [tv_nm] $
-                               thing_inside kv_nms
+                               thing_inside new_kv_nms other_kv_nms
                                  (L loc (KindedTyVar (L lv tv_nm) kind'))
                 ; return (b, fvs1 `plusFV` fvs2) }}
   where
@@ -854,9 +963,11 @@ bindImplicitKvs :: HsDocContext
                                       -- intent to bind is inferred
                 -> NameSet            -- ^ *type* variables, for type/kind
                                       -- misuse check for -XNoTypeInType
-                -> ([Name] -> RnM (b, FreeVars)) -- ^ passed new kv_names
+                -> ([Name] -> NameSet -> RnM (b, FreeVars))
+                   -- ^ passed new kv_names, and any other names used in a kind
                 -> RnM (b, FreeVars)
-bindImplicitKvs _   _        []       _        thing_inside = thing_inside []
+bindImplicitKvs _   _        []       _        thing_inside
+  = thing_inside [] emptyNameSet
 bindImplicitKvs doc mb_assoc free_kvs tv_names thing_inside
   = do { rdr_env <- getLocalRdrEnv
        ; let part_kvs lrdr@(L loc kv_rdr)
@@ -877,7 +988,7 @@ bindImplicitKvs doc mb_assoc free_kvs tv_names thing_inside
           -- bind the vars and move on
        ; kv_nms <- mapM (newTyVarNameRn mb_assoc) new_kvs
        ; bindLocalNamesFV kv_nms $
-         thing_inside kv_nms }
+         thing_inside kv_nms (mkNameSet (map unLoc bound_kvs)) }
   where
       -- check to see if the variables free in a kind are bound as type
       -- variables. Assume -XNoTypeInType.
@@ -902,41 +1013,34 @@ newTyVarNameRn mb_assoc (L loc rdr)
            _                -> newLocalBndrRn (L loc rdr) }
 
 ---------------------
-collectNamedWildCards :: LHsType RdrName -> [Located RdrName]
-collectNamedWildCards hs_ty
-  = nubBy eqLocated $
-    [n | L _ (NamedWildCard n) <- collectWildCards hs_ty ]
-
 collectAnonWildCards :: LHsType Name -> [Name]
-collectAnonWildCards hs_ty
-  = [n | L _ (AnonWildCard (L _ n)) <- collectWildCards hs_ty ]
-
-collectWildCards :: LHsType name -> [Located (HsWildCardInfo name)]
 -- | Extract all wild cards from a type.
-collectWildCards lty = go lty
+collectAnonWildCards lty = go lty
   where
-    go (L loc ty) = case ty of
-      HsAppsTy tys            -> gos (mapMaybe prefix_types_only tys)
-      HsAppTy ty1 ty2         -> go ty1 `mappend` go ty2
-      HsFunTy ty1 ty2         -> go ty1 `mappend` go ty2
-      HsListTy ty             -> go ty
-      HsPArrTy ty             -> go ty
-      HsTupleTy _ tys         -> gos tys
-      HsOpTy ty1 _ ty2        -> go ty1 `mappend` go ty2
-      HsParTy ty              -> go ty
-      HsIParamTy _ ty         -> go ty
-      HsEqTy ty1 ty2          -> go ty1 `mappend` go ty2
-      HsKindSig ty kind       -> go ty `mappend` go kind
-      HsDocTy ty _            -> go ty
-      HsBangTy _ ty           -> go ty
-      HsRecTy flds            -> gos $ map (cd_fld_type . unLoc) flds
-      HsExplicitListTy _ tys  -> gos tys
-      HsExplicitTupleTy _ tys -> gos tys
-      -- Interesting cases
-      HsWildCardTy wc         -> [L loc wc]
-      HsForAllTy { hst_body = ty } -> go ty
+    go (L _ ty) = case ty of
+      HsWildCardTy (AnonWildCard (L _ wc)) -> [wc]
+      HsAppsTy tys                 -> gos (mapMaybe (prefix_types_only . unLoc) tys)
+      HsAppTy ty1 ty2              -> go ty1 `mappend` go ty2
+      HsFunTy ty1 ty2              -> go ty1 `mappend` go ty2
+      HsListTy ty                  -> go ty
+      HsPArrTy ty                  -> go ty
+      HsTupleTy _ tys              -> gos tys
+      HsOpTy ty1 _ ty2             -> go ty1 `mappend` go ty2
+      HsParTy ty                   -> go ty
+      HsIParamTy _ ty              -> go ty
+      HsEqTy ty1 ty2               -> go ty1 `mappend` go ty2
+      HsKindSig ty kind            -> go ty `mappend` go kind
+      HsDocTy ty _                 -> go ty
+      HsBangTy _ ty                -> go ty
+      HsRecTy flds                 -> gos $ map (cd_fld_type . unLoc) flds
+      HsExplicitListTy _ tys       -> gos tys
+      HsExplicitTupleTy _ tys      -> gos tys
+      HsForAllTy { hst_bndrs = bndrs
+                 , hst_body = ty } -> collectAnonWildCardsBndrs bndrs
+                                      `mappend` go ty
       HsQualTy { hst_ctxt = L _ ctxt
                , hst_body = ty }  -> gos ctxt `mappend` go ty
+      HsSpliceTy (HsSpliced _ (HsSplicedTy ty)) _ -> go $ L noSrcSpan ty
       -- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit
       _ -> mempty
 
@@ -945,6 +1049,11 @@ collectWildCards lty = go lty
     prefix_types_only (HsAppPrefix ty) = Just ty
     prefix_types_only (HsAppInfix _)   = Nothing
 
+collectAnonWildCardsBndrs :: [LHsTyVarBndr Name] -> [Name]
+collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs
+  where
+    go (UserTyVar _)      = []
+    go (KindedTyVar _ ki) = collectAnonWildCards ki
 
 {-
 *********************************************************
@@ -960,45 +1069,30 @@ RnNames.getLocalNonValBinders), so we just take the list as an
 argument, build a map and look them up.
 -}
 
-rnConDeclFields :: [FieldLabel] -> HsDocContext -> [LConDeclField RdrName]
+rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField RdrName]
                 -> RnM ([LConDeclField Name], FreeVars)
-rnConDeclFields fls doc fields = mapFvRn (rnField fl_env doc) fields
+-- Also called from RnSource
+-- No wildcards can appear in record fields
+rnConDeclFields ctxt fls fields
+   = mapFvRn (rnField fl_env env) fields
   where
+    env    = mkTyKiEnv ctxt TypeLevel RnTypeBody
     fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]
 
-rnField :: FastStringEnv FieldLabel -> HsDocContext -> LConDeclField RdrName
+rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField RdrName
         -> RnM (LConDeclField Name, FreeVars)
-rnField fl_env doc (L l (ConDeclField names ty haddock_doc))
+rnField fl_env env (L l (ConDeclField names ty haddock_doc))
   = do { let new_names = map (fmap lookupField) names
-       ; (new_ty, fvs) <- rnLHsType doc ty
+       ; (new_ty, fvs) <- rnLHsTyKi env ty
        ; new_haddock_doc <- rnMbLHsDoc haddock_doc
        ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
   where
     lookupField :: FieldOcc RdrName -> FieldOcc Name
-    lookupField (FieldOcc rdr _) = FieldOcc rdr (flSelector fl)
+    lookupField (FieldOcc (L lr rdr) _) = FieldOcc (L lr rdr) (flSelector fl)
       where
         lbl = occNameFS $ rdrNameOcc rdr
         fl  = expectJust "rnField" $ lookupFsEnv fl_env lbl
 
-
-{-
-*********************************************************
-*                                                       *
-        Contexts
-*                                                       *
-*********************************************************
--}
-
-rnTyKiContext :: RnTyKiWhat
-              -> HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
-rnTyKiContext what doc (L loc cxt)
-  = do { traceRn (text "rncontext" <+> ppr cxt)
-       ; (cxt', fvs) <- mapFvRn (rnLHsPred what doc) cxt
-       ; return (L loc cxt', fvs) }
-
-rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
-rnContext = rnTyKiContext (RnConstraint TypeLevel)
-
 {-
 ************************************************************************
 *                                                                      *
@@ -1117,9 +1211,9 @@ mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 get_op :: LHsExpr Name -> Name
 -- An unbound name could be either HsVar or HsUnboundVar
 -- See RnExpr.rnUnboundVar
-get_op (L _ (HsVar (L _ n)))    = n
-get_op (L _ (HsUnboundVar occ)) = mkUnboundName occ
-get_op other                    = pprPanic "get_op" (ppr other)
+get_op (L _ (HsVar (L _ n)))   = n
+get_op (L _ (HsUnboundVar uv)) = mkUnboundName (unboundVarOcc uv)
+get_op other                   = pprPanic "get_op" (ppr other)
 
 -- Parser left-associates everything, but
 -- derived instances may have correctly-associated things to
@@ -1220,8 +1314,8 @@ checkPrecMatch op (MG { mg_alts = L _ ms })
 
 checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
-    op_fix@(Fixity op_prec  op_dir) <- lookupFixityRn op
-    op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
+    op_fix@(Fixity op_prec  op_dir) <- lookupFixityRn op
+    op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
     let
         inf_ok = op1_prec > op_prec ||
                  (op1_prec == op_prec &&
@@ -1249,8 +1343,8 @@ checkSectionPrec direction section op arg
         _                -> return ()
   where
     op_name = get_op op
-    go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
-          op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
+    go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
+          op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
           unless (op_prec < arg_prec
                   || (op_prec == arg_prec && direction == assoc))
                  (sectionPrecErr (op_name, op_fix)
@@ -1263,25 +1357,25 @@ precParseErr op1@(n1,_) op2@(n2,_)
   | isUnboundName n1 || isUnboundName n2
   = return ()     -- Avoid error cascade
   | otherwise
-  = addErr $ hang (ptext (sLit "Precedence parsing error"))
-      4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
+  = addErr $ hang (text "Precedence parsing error")
+      4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"),
                ppr_opfix op2,
-               ptext (sLit "in the same infix expression")])
+               text "in the same infix expression"])
 
 sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
   | isUnboundName n1 || isUnboundName n2
   = return ()     -- Avoid error cascade
   | otherwise
-  = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
-         nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
-                      nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
-         nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
+  = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"),
+         nest 4 (sep [text "must have lower precedence than that of the operand,",
+                      nest 2 (text "namely" <+> ppr_opfix arg_op)]),
+         nest 4 (text "in the section:" <+> quotes (ppr section))]
 
 ppr_opfix :: (Name, Fixity) -> SDoc
 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
    where
-     pp_op | op == negateName = ptext (sLit "prefix `-'")
+     pp_op | op == negateName = text "prefix `-'"
            | otherwise        = quotes (ppr op)
 
 {- *****************************************************
@@ -1290,51 +1384,53 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
 *                                                      *
 ***************************************************** -}
 
+unexpectedTypeSigErr :: LHsSigWcType RdrName -> SDoc
+unexpectedTypeSigErr ty
+  = hang (text "Illegal type signature:" <+> quotes (ppr ty))
+       2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")
+
 badKindBndrs :: HsDocContext -> [Located RdrName] -> SDoc
 badKindBndrs doc kvs
   = withHsDocContext doc $
-    hang (ptext (sLit "Unexpected kind variable") <> plural kvs
+    hang (text "Unexpected kind variable" <> plural kvs
                  <+> pprQuotedList kvs)
-       2 (ptext (sLit "Perhaps you intended to use PolyKinds"))
+       2 (text "Perhaps you intended to use PolyKinds")
 
 badKindSigErr :: HsDocContext -> LHsType RdrName -> TcM ()
 badKindSigErr doc (L loc ty)
   = setSrcSpan loc $ addErr $
     withHsDocContext doc $
-    hang (ptext (sLit "Illegal kind signature:") <+> quotes (ppr ty))
-       2 (ptext (sLit "Perhaps you intended to use KindSignatures"))
+    hang (text "Illegal kind signature:" <+> quotes (ppr ty))
+       2 (text "Perhaps you intended to use KindSignatures")
 
-dataKindsErr :: RnTyKiWhat -> HsType RdrName -> SDoc
-dataKindsErr what thing
-  = hang (ptext (sLit "Illegal") <+> pp_what <> colon <+> quotes (ppr thing))
-       2 (ptext (sLit "Perhaps you intended to use DataKinds"))
+dataKindsErr :: RnTyKiEnv -> HsType RdrName -> SDoc
+dataKindsErr env thing
+  = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))
+       2 (text "Perhaps you intended to use DataKinds")
   where
-    pp_what | isRnKindLevel what = ptext (sLit "kind")
-            | otherwise          = ptext (sLit "type")
+    pp_what | isRnKindLevel env = text "kind"
+            | otherwise          = text "type"
 
 inTypeDoc :: HsType RdrName -> SDoc
-inTypeDoc ty = ptext (sLit "In the type") <+> quotes (ppr ty)
+inTypeDoc ty = text "In the type" <+> quotes (ppr ty)
 
-warnUnusedForAlls :: SDoc -> [LHsTyVarBndr Name] -> FreeVars -> TcM ()
-warnUnusedForAlls in_doc bound_names used_names
-  = whenWOptM Opt_WarnUnusedMatches $
-    mapM_ add_warn bound_names
-  where
-    add_warn (L loc tv)
-      = unless (hsTyVarName tv `elemNameSet` used_names) $
-        addWarnAt loc $
-        vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv)
-             , in_doc ]
+warnUnusedForAll :: SDoc -> LHsTyVarBndr Name -> FreeVars -> TcM ()
+warnUnusedForAll in_doc (L loc tv) used_names
+  = whenWOptM Opt_WarnUnusedForalls $
+    unless (hsTyVarName tv `elemNameSet` used_names) $
+    addWarnAt (Reason Opt_WarnUnusedForalls) loc $
+    vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)
+         , in_doc ]
 
 opTyErr :: Outputable a => RdrName -> a -> SDoc
 opTyErr op overall_ty
-  = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty))
+  = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty))
          2 extra
   where
     extra | op == dot_tv_RDR
           = perhapsForallMsg
           | otherwise
-          = ptext (sLit "Use TypeOperators to allow operators in types")
+          = text "Use TypeOperators to allow operators in types"
 
 emptyNonSymsErr :: HsType RdrName -> SDoc
 emptyNonSymsErr overall_ty
@@ -1418,6 +1514,8 @@ extractHsTyRdrTyVars :: LHsType RdrName -> RnM FreeKiTyVars
 --                        or the free (sort, kind) variables of a HsKind
 -- It's used when making the for-alls explicit.
 -- Does not return any wildcards
+-- When the same name occurs multiple times in the types, only the first
+-- occurence is returned.
 -- See Note [Kind and type-variable binders]
 extractHsTyRdrTyVars ty
   = do { FKTV kis k_set tys t_set all <- extract_lty TypeLevel ty emptyFKTV
@@ -1425,13 +1523,25 @@ extractHsTyRdrTyVars ty
                       (nubL tys) t_set
                       (nubL all)) }
 
-extractHsTysRdrTyVars :: [LHsType RdrName] -> RnM FreeKiTyVars
+-- | Extracts free type and kind variables from types in a list.
+-- When the same name occurs multiple times in the types, only the first
+-- occurence is returned and the rest is filtered out.
 -- See Note [Kind and type-variable binders]
+extractHsTysRdrTyVars :: [LHsType RdrName] -> RnM FreeKiTyVars
 extractHsTysRdrTyVars tys
-  = do { FKTV kis k_set tys t_set all <- extract_ltys TypeLevel tys emptyFKTV
-       ; return (FKTV (nubL kis) k_set
-                      (nubL tys) t_set
-                      (nubL all)) }
+  = rmDupsInRdrTyVars <$> extractHsTysRdrTyVarsDups tys
+
+-- | Extracts free type and kind variables from types in a list.
+-- When the same name occurs multiple times in the types, all occurences
+-- are returned.
+extractHsTysRdrTyVarsDups :: [LHsType RdrName] -> RnM FreeKiTyVars
+extractHsTysRdrTyVarsDups tys
+  = extract_ltys TypeLevel tys emptyFKTV
+
+-- | Removes multiple occurences of the same name from FreeKiTyVars.
+rmDupsInRdrTyVars :: FreeKiTyVars -> FreeKiTyVars
+rmDupsInRdrTyVars (FKTV kis k_set tys t_set all)
+  = FKTV (nubL kis) k_set (nubL tys) t_set (nubL all)
 
 extractRdrKindSigVars :: LFamilyResultSig RdrName -> RnM [Located RdrName]
 extractRdrKindSigVars (L _ resultSig)
@@ -1445,11 +1555,11 @@ extractDataDefnKindVars :: HsDataDefn RdrName -> RnM [Located RdrName]
 -- Eg    data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
 -- Here k should scope over the whole definition
 extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
-                                    , dd_cons = cons, dd_derivs = derivs })
+                                    , dd_cons = cons, dd_derivs = L _ derivs })
   = (nubL . freeKiTyVarsKindVars) <$>
     (extract_lctxt TypeLevel ctxt =<<
      extract_mb extract_lkind ksig =<<
-     extract_mb (extract_sig_tys . unLoc) derivs =<<
+     extract_sig_tys (concatMap (unLoc . deriv_clause_tys . unLoc) derivs) =<<
      foldrM (extract_con . unLoc) emptyFKTV cons)
   where
     extract_con (ConDeclGADT { }) acc = return acc
@@ -1498,6 +1608,7 @@ extract_lty t_or_k (L _ ty) acc
       HsListTy ty               -> extract_lty t_or_k ty acc
       HsPArrTy ty               -> extract_lty t_or_k ty acc
       HsTupleTy _ tys           -> extract_ltys t_or_k tys acc
+      HsSumTy tys               -> extract_ltys t_or_k tys acc
       HsFunTy ty1 ty2           -> extract_lty t_or_k ty1 =<<
                                    extract_lty t_or_k ty2 acc
       HsIParamTy _ ty           -> extract_lty t_or_k ty acc
@@ -1525,12 +1636,13 @@ extract_lty t_or_k (L _ ty) acc
       HsWildCardTy {}           -> return acc
 
 extract_apps :: TypeOrKind
-             -> [HsAppType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars
+             -> [LHsAppType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars
 extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys
 
-extract_app :: TypeOrKind -> HsAppType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
-extract_app t_or_k (HsAppInfix tv)  acc = extract_tv t_or_k tv acc
-extract_app t_or_k (HsAppPrefix ty) acc = extract_lty t_or_k ty acc
+extract_app :: TypeOrKind -> LHsAppType RdrName -> FreeKiTyVars
+            -> RnM FreeKiTyVars
+extract_app t_or_k (L _ (HsAppInfix tv))  acc = extract_tv t_or_k tv acc
+extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc
 
 extract_hs_tv_bndrs :: [LHsTyVarBndr RdrName] -> FreeKiTyVars
                     -> FreeKiTyVars -> RnM FreeKiTyVars