More explicit foralls (GHC Proposal 0007)

Allow the user to explicitly bind type/kind variables in type and data
family instances (including associated instances), closed type family
equations, and RULES pragmas. Follows the specification of GHC
Proposal 0007, also fixes #2600. Advised by Richard Eisenberg.

This modifies the Template Haskell AST -- old code may break!

Other Changes:
- convert HsRule to a record
- make rnHsSigWcType more general
- add repMaybe to DsMeta

Includes submodule update for Haddock.

Test Plan: validate

Reviewers: goldfire, bgamari, alanz

Subscribers: simonpj, RyanGlScott, goldfire, rwbarton,
             thomie, mpickering, carter

GHC Trac Issues: #2600, #14268

Differential Revision: https://phabricator.haskell.org/D4894

6 files changed, 126 insertions, 77 deletions

diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index 7cd5c55245..60dead089b 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -958,7 +958,7 @@ renameSig _ (IdSig _ x)
 renameSig ctxt sig@(TypeSig _ vs ty)
   = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
         ; let doc = TypeSigCtx (ppr_sig_bndrs vs)
-        ; (new_ty, fvs) <- rnHsSigWcType doc ty
+        ; (new_ty, fvs) <- rnHsSigWcType BindUnlessForall doc ty
         ; return (TypeSig noExt new_vs new_ty, fvs) }
 
 renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index ae2bdf7a2b..46ac6b8724 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -167,10 +167,10 @@ rnExpr (HsApp x fun arg)
        ; (arg',fvArg) <- rnLExpr arg
        ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }
 
-rnExpr (HsAppType arg fun)
+rnExpr (HsAppType x fun arg)
   = do { (fun',fvFun) <- rnLExpr fun
        ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
-       ; return (HsAppType arg' fun', fvFun `plusFV` fvArg) }
+       ; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) }
 
 rnExpr (OpApp _ e1 op e2)
   = do  { (e1', fv_e1) <- rnLExpr e1
@@ -310,11 +310,11 @@ rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
                             , rupd_flds = rbinds' }
                  , fvExpr `plusFV` fvRbinds) }
 
-rnExpr (ExprWithTySig pty expr)
-  = do  { (pty', fvTy)    <- rnHsSigWcType ExprWithTySigCtx pty
+rnExpr (ExprWithTySig _ expr pty)
+  = do  { (pty', fvTy)    <- rnHsSigWcType BindUnlessForall ExprWithTySigCtx pty
         ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
                              rnLExpr expr
-        ; return (ExprWithTySig pty' expr', fvExpr `plusFV` fvTy) }
+        ; return (ExprWithTySig noExt expr' pty', fvExpr `plusFV` fvTy) }
 
 rnExpr (HsIf x _ p b1 b2)
   = do { (p', fvP) <- rnLExpr p
@@ -1820,7 +1820,7 @@ isStrictPattern (L _ pat) =
     AsPat _ _ p     -> isStrictPattern p
     ParPat _ p      -> isStrictPattern p
     ViewPat _ _ p   -> isStrictPattern p
-    SigPat _ p      -> isStrictPattern p
+    SigPat _ p _    -> isStrictPattern p
     BangPat{}       -> True
     ListPat{}       -> True
     TuplePat{}      -> True
@@ -1944,7 +1944,7 @@ isReturnApp monad_names (L _ e) = case e of
   _otherwise -> Nothing
  where
   is_var f (L _ (HsPar _ e)) = is_var f e
-  is_var f (L _ (HsAppType _ e)) = is_var f e
+  is_var f (L _ (HsAppType _ e _)) = is_var f e
   is_var f (L _ (HsVar _ (L _ r))) = f r
        -- TODO: I don't know how to get this right for rebindable syntax
   is_var _ _ = False
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index 6195309cab..a80a6982eb 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -213,7 +213,7 @@ matchNameMaker ctxt = LamMk report_unused
                       _                     -> True
 
 rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn)
-rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped PatCtx sig)
+rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig)
 
 newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)
 newPatLName name_maker rdr_name@(L loc _)
@@ -393,7 +393,7 @@ rnPatAndThen mk (VarPat x (L l rdr)) = do { loc <- liftCps getSrcSpanM
      -- we need to bind pattern variables for view pattern expressions
      -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
 
-rnPatAndThen mk (SigPat sig pat )
+rnPatAndThen mk (SigPat x pat sig)
   -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is
   -- important to rename its type signature _before_ renaming the rest of the
   -- pattern, so that type variables are first bound by the _outermost_ pattern
@@ -405,7 +405,7 @@ rnPatAndThen mk (SigPat sig pat )
   -- ~~~~~~~~~~~~~~~^                   the same `a' then used here
   = do { sig' <- rnHsSigCps sig
        ; pat' <- rnLPatAndThen mk pat
-       ; return (SigPat sig' pat' ) }
+       ; return (SigPat x pat' sig' ) }
 
 rnPatAndThen mk (LitPat x lit)
   | HsString src s <- lit
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 9687e72a10..48739cdf69 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -50,7 +50,7 @@ import NameEnv
 import Avail
 import Outputable
 import Bag
-import BasicTypes       ( RuleName, pprRuleName )
+import BasicTypes       ( pprRuleName )
 import FastString
 import SrcLoc
 import DynFlags
@@ -67,6 +67,7 @@ import Control.Arrow ( first )
 import Data.List ( mapAccumL )
 import qualified Data.List.NonEmpty as NE
 import Data.List.NonEmpty ( NonEmpty(..) )
+import Data.Maybe ( isNothing, maybe, fromMaybe )
 import qualified Data.Set as Set ( difference, fromList, toList, null )
 
 {- | @rnSourceDecl@ "renames" declarations.
@@ -693,33 +694,41 @@ rnFamInstEqn :: HsDocContext
              -> RnM (FamInstEqn GhcRn rhs', FreeVars)
 rnFamInstEqn doc mb_cls rhs_kvars
     (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon
+                               , feqn_bndrs  = mb_bndrs
                                , feqn_pats   = pats
                                , feqn_fixity = fixity
                                , feqn_rhs    = payload }}) rn_payload
   = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
-       ; let loc = case pats of
-                     []             -> pprPanic "rnFamInstEqn" (ppr tycon)
-                     (L loc _ : []) -> loc
-                     (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
-
-             pat_kity_vars_with_dups = extractHsTysRdrTyVarsDups pats
-             pat_vars = freeKiTyVarsAllVars $
-                        rmDupsInRdrTyVars pat_kity_vars_with_dups
+       ; let pat_kity_vars_with_dups = extractHsTysRdrTyVarsDups pats
              -- Use the "...Dups" form because it's needed
              -- below to report unsed binder on the LHS
-       ; pat_var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) pat_vars
-
+       ; let pat_kity_vars = rmDupsInRdrTyVars pat_kity_vars_with_dups
+
+         -- all pat vars not explicitly bound (see extractHsTvBndrs)
+       ; let mb_imp_kity_vars = extractHsTvBndrs <$> mb_bndrs <*> pure pat_kity_vars
+             imp_vars = case mb_imp_kity_vars of
+                          -- kind vars are the only ones free if we have an explicit forall
+                          Just nbnd_kity_vars -> freeKiTyVarsKindVars nbnd_kity_vars
+                          -- all pattern vars are free otherwise
+                          Nothing             -> freeKiTyVarsAllVars pat_kity_vars
+       ; imp_var_names <- mapM (newTyVarNameRn mb_cls) imp_vars
+
+       ; let bndrs = fromMaybe [] mb_bndrs
+             bnd_vars = map hsLTyVarLocName bndrs
+             payload_kvars = filterOut (`elemRdr` (bnd_vars ++ imp_vars)) rhs_kvars
              -- Make sure to filter out the kind variables that were explicitly
              -- bound in the type patterns.
-       ; let payload_vars = filterOut (`elemRdr` pat_vars) rhs_kvars
-       ; payload_var_names <- mapM (newTyVarNameRn mb_cls) payload_vars
+       ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars
 
-       ; let all_var_names = pat_var_names ++ payload_var_names
+         -- all names not bound in an explict forall
+       ; let all_imp_var_names = imp_var_names ++ payload_kvar_names
 
              -- All the free vars of the family patterns
              -- with a sensible binding location
-       ; ((pats', payload'), fvs)
-              <- bindLocalNamesFV all_var_names $
+       ; ((bndrs', pats', payload'), fvs)
+              <- bindLocalNamesFV all_imp_var_names $
+                 bindLHsTyVarBndrs doc (Just $ inHsDocContext doc)
+                                   mb_cls bndrs $ \bndrs' ->
                  do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats
                     ; (payload', rhs_fvs) <- rn_payload doc payload
 
@@ -728,7 +737,7 @@ rnFamInstEqn doc mb_cls rhs_kvars
                     ; let groups :: [NonEmpty (Located RdrName)]
                           groups = equivClasses cmpLocated $
                                    freeKiTyVarsAllVars pat_kity_vars_with_dups
-                    ; tv_nms_dups <- mapM (lookupOccRn . unLoc) $
+                    ; nms_dups <- mapM (lookupOccRn . unLoc) $
                                      [ tv | (tv :| (_:_)) <- groups ]
                           -- Add to the used variables
                           --  a) any variables that appear *more than once* on the LHS
@@ -736,27 +745,27 @@ rnFamInstEqn doc mb_cls rhs_kvars
                           --  b) for associated instances, the variables
                           --     of the instance decl.  See
                           --     Note [Unused type variables in family instances]
-                    ; let tv_nms_used = extendNameSetList rhs_fvs $
-                                        inst_tvs ++ tv_nms_dups
+                    ; let nms_used = extendNameSetList rhs_fvs $
+                                        inst_tvs ++ nms_dups
                           inst_tvs = case mb_cls of
                                        Nothing            -> []
                                        Just (_, inst_tvs) -> inst_tvs
-                    ; warnUnusedTypePatterns pat_var_names tv_nms_used
+                          all_nms = all_imp_var_names
+                                      ++ map hsLTyVarName bndrs'
+                    ; warnUnusedTypePatterns all_nms nms_used
 
                          -- See Note [Renaming associated types]
-                    ; let bad_tvs = case mb_cls of
-                                      Nothing           -> []
-                                      Just (_,cls_tkvs) -> filter is_bad cls_tkvs
-                          var_name_set = mkNameSet all_var_names
-
+                    ; let bad_tvs = maybe [] (filter is_bad . snd) mb_cls
+                          var_name_set = mkNameSet (map hsLTyVarName bndrs'
+                                                    ++ all_imp_var_names)
                           is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs
-                                        && not (cls_tkv `elemNameSet` var_name_set)
+                                           && not (cls_tkv `elemNameSet` var_name_set)
                     ; unless (null bad_tvs) (badAssocRhs bad_tvs)
 
-                    ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
+                    ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) }
 
        ; let anon_wcs = concatMap collectAnonWildCards pats'
-             all_ibs  = anon_wcs ++ all_var_names
+             all_ibs  = anon_wcs ++ all_imp_var_names
                         -- all_ibs: include anonymous wildcards in the implicit
                         -- binders In a type pattern they behave just like any
                         -- other type variable except for being anoymous.  See
@@ -768,6 +777,7 @@ rnFamInstEqn doc mb_cls rhs_kvars
                       , hsib_body
                           = FamEqn { feqn_ext    = noExt
                                    , feqn_tycon  = tycon'
+                                   , feqn_bndrs  = bndrs' <$ mb_bndrs
                                    , feqn_pats   = pats'
                                    , feqn_fixity = fixity
                                    , feqn_rhs    = payload' } },
@@ -796,6 +806,7 @@ rnTyFamDefltEqn :: Name
                 -> TyFamDefltEqn GhcPs
                 -> RnM (TyFamDefltEqn GhcRn, FreeVars)
 rnTyFamDefltEqn cls (FamEqn { feqn_tycon  = tycon
+                            , feqn_bndrs  = bndrs
                             , feqn_pats   = tyvars
                             , feqn_fixity = fixity
                             , feqn_rhs    = rhs })
@@ -805,6 +816,8 @@ rnTyFamDefltEqn cls (FamEqn { feqn_tycon  = tycon
        ; (rhs', fvs) <- rnLHsType ctx rhs
        ; return (FamEqn { feqn_ext    = noExt
                         , feqn_tycon  = tycon'
+                        , feqn_bndrs  = ASSERT( isNothing bndrs )
+                                        Nothing
                         , feqn_pats   = tyvars'
                         , feqn_fixity = fixity
                         , feqn_rhs    = rhs' }, fvs) } }
@@ -959,7 +972,7 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap)
        ; (mds', ty', fvs)
            <- rnLDerivStrategy DerivDeclCtx mds $ \strat_tvs ppr_via_ty ->
               rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "instance" $
-              rnHsSigWcType DerivDeclCtx ty
+              rnHsSigWcType BindUnlessForall DerivDeclCtx ty
        ; return (DerivDecl noExt ty' mds' overlap, fvs) }
   where
     loc = getLoc $ hsib_body $ hswc_body ty
@@ -979,51 +992,75 @@ standaloneDerivErr
 -}
 
 rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
-rnHsRuleDecls (HsRules _ src rules)
+rnHsRuleDecls (HsRules { rds_src = src
+                       , rds_rules = rules })
   = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
-       ; return (HsRules noExt src rn_rules,fvs) }
+       ; return (HsRules { rds_ext = noExt
+                         , rds_src = src
+                         , rds_rules = rn_rules }, fvs) }
 rnHsRuleDecls (XRuleDecls _) = panic "rnHsRuleDecls"
 
 rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
-rnHsRuleDecl (HsRule _ rule_name act vars lhs rhs)
-  = do { let rdr_names_w_loc = map get_var vars
+rnHsRuleDecl (HsRule { rd_name = rule_name
+                     , rd_act  = act
+                     , rd_tyvs = tyvs
+                     , rd_tmvs = tmvs
+                     , rd_lhs  = lhs
+                     , rd_rhs  = rhs })
+  = do { let rdr_names_w_loc = map get_var tmvs
        ; checkDupRdrNames rdr_names_w_loc
        ; checkShadowedRdrNames rdr_names_w_loc
        ; names <- newLocalBndrsRn rdr_names_w_loc
-       ; bindHsRuleVars (snd $ unLoc rule_name) vars names $ \ vars' ->
+       ; let doc = RuleCtx (snd $ unLoc rule_name)
+       ; bindRuleTyVars doc in_rule tyvs $ \ tyvs' ->
+         bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->
     do { (lhs', fv_lhs') <- rnLExpr lhs
        ; (rhs', fv_rhs') <- rnLExpr rhs
        ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
-       ; return (HsRule (HsRuleRn fv_lhs' fv_rhs') rule_name act vars'
-                                                                     lhs' rhs',
-                 fv_lhs' `plusFV` fv_rhs') } }
+       ; return (HsRule { rd_ext  = HsRuleRn fv_lhs' fv_rhs'
+                        , rd_name = rule_name
+                        , rd_act  = act
+                        , rd_tyvs = tyvs'
+                        , rd_tmvs = tmvs'
+                        , rd_lhs  = lhs'
+                        , rd_rhs  = rhs' }, fv_lhs' `plusFV` fv_rhs') } }
   where
     get_var (L _ (RuleBndrSig _ v _)) = v
     get_var (L _ (RuleBndr _ v)) = v
     get_var (L _ (XRuleBndr _)) = panic "rnHsRuleDecl"
+    in_rule = text "in the rule" <+> pprFullRuleName rule_name
 rnHsRuleDecl (XRuleDecl _) = panic "rnHsRuleDecl"
 
-bindHsRuleVars :: RuleName -> [LRuleBndr GhcPs] -> [Name]
+bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs
+               -> [LRuleBndr GhcPs] -> [Name]
                -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
                -> RnM (a, FreeVars)
-bindHsRuleVars rule_name vars names thing_inside
+bindRuleTmVars doc tyvs vars names thing_inside
   = go vars names $ \ vars' ->
     bindLocalNamesFV names (thing_inside vars')
   where
-    doc = RuleCtx rule_name
-
     go (L l (RuleBndr _ (L loc _)) : vars) (n : ns) thing_inside
       = go vars ns $ \ vars' ->
         thing_inside (L l (RuleBndr noExt (L loc n)) : vars')
 
     go (L l (RuleBndrSig _ (L loc _) bsig) : vars) (n : ns) thing_inside
-      = rnHsSigWcTypeScoped doc bsig $ \ bsig' ->
+      = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' ->
         go vars ns $ \ vars' ->
         thing_inside (L l (RuleBndrSig noExt (L loc n) bsig') : vars')
 
     go [] [] thing_inside = thing_inside []
     go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
 
+    bind_free_tvs = case tyvs of Nothing -> AlwaysBind
+                                 Just _  -> NeverBind
+
+bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs]
+               -> (Maybe [LHsTyVarBndr GhcRn]  -> RnM (b, FreeVars))
+               -> RnM (b, FreeVars)
+bindRuleTyVars doc in_doc (Just bndrs) thing_inside
+  = bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just)
+bindRuleTyVars _ _ _ thing_inside = thing_inside Nothing
+
 {-
 Note [Rule LHS validity checking]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1062,7 +1099,7 @@ validRuleLhs foralls lhs
     check (OpApp _ e1 op e2)              = checkl op `mplus` checkl_e e1
                                                       `mplus` checkl_e e2
     check (HsApp _ e1 e2)                 = checkl e1 `mplus` checkl_e e2
-    check (HsAppType _ e)                 = checkl e
+    check (HsAppType _ e _)               = checkl e
     check (HsVar _ (L _ v)) | v `notElem` foralls = Nothing
     check other                           = Just other  -- Failure
 
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index 33f9329789..abdaaae7e2 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -12,7 +12,7 @@ module RnTypes (
         rnHsType, rnLHsType, rnLHsTypes, rnContext,
         rnHsKind, rnLHsKind,
         rnHsSigType, rnHsWcType,
-        rnHsSigWcType, rnHsSigWcTypeScoped,
+        HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped,
         rnLHsInstType,
         newTyVarNameRn, collectAnonWildCards,
         rnConDeclFields,
@@ -83,13 +83,29 @@ to break several loop.
 *********************************************************
 -}
 
-rnHsSigWcType :: HsDocContext -> LHsSigWcType GhcPs
-            -> RnM (LHsSigWcType GhcRn, FreeVars)
-rnHsSigWcType doc sig_ty
-  = rn_hs_sig_wc_type False doc sig_ty $ \sig_ty' ->
+data HsSigWcTypeScoping = AlwaysBind
+                          -- ^ Always bind any free tyvars of the given type,
+                          --   regardless of whether we have a forall at the top
+                        | BindUnlessForall
+                          -- ^ Unless there's forall at the top, do the same
+                          --   thing as 'AlwaysBind'
+                        | NeverBind
+                          -- ^ Never bind any free tyvars
+
+rnHsSigWcType :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs
+              -> RnM (LHsSigWcType GhcRn, FreeVars)
+rnHsSigWcType scoping doc sig_ty
+  = rn_hs_sig_wc_type scoping doc sig_ty $ \sig_ty' ->
     return (sig_ty', emptyFVs)
 
-rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs
+rnHsSigWcTypeScoped :: HsSigWcTypeScoping
+                       -- AlwaysBind: for pattern type sigs and rules we /do/ want
+                       --             to bring those type variables into scope, even
+                       --             if there's a forall at the top which usually
+                       --             stops that happening
+                       -- e.g  \ (x :: forall a. a-> b) -> e
+                       -- Here we do bring 'b' into scope
+                    -> HsDocContext -> LHsSigWcType GhcPs
                     -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
                     -> RnM (a, FreeVars)
 -- Used for
@@ -97,33 +113,26 @@ rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs
 --   - Pattern type signatures
 -- Wildcards are allowed
 -- type signatures on binders only allowed with ScopedTypeVariables
-rnHsSigWcTypeScoped ctx sig_ty thing_inside
+rnHsSigWcTypeScoped scoping ctx sig_ty thing_inside
   = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
        ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)
-       ; rn_hs_sig_wc_type True ctx sig_ty thing_inside
+       ; rn_hs_sig_wc_type scoping ctx sig_ty thing_inside
        }
-    -- True: for pattern type sigs and rules we /do/ want
-    --       to bring those type variables into scope, even
-    --       if there's a forall at the top which usually
-    --       stops that happening
-    -- e.g  \ (x :: forall a. a-> b) -> e
-    -- Here we do bring 'b' into scope
-
-rn_hs_sig_wc_type :: Bool   -- True <=> always bind any free tyvars of the
-                            --          type, regardless of whether it has
-                            --          a forall at the top
-                  -> HsDocContext
-                  -> LHsSigWcType GhcPs
+
+rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs
                   -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
                   -> RnM (a, FreeVars)
 -- rn_hs_sig_wc_type is used for source-language type signatures
-rn_hs_sig_wc_type always_bind_free_tvs ctxt
+rn_hs_sig_wc_type scoping ctxt
                   (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
                   thing_inside
   = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty
        ; (tv_rdrs, nwc_rdrs') <- partition_nwcs free_vars
        ; let nwc_rdrs = nubL nwc_rdrs'
-             bind_free_tvs = always_bind_free_tvs || not (isLHsForAllTy hs_ty)
+             bind_free_tvs = case scoping of
+                               AlwaysBind       -> True
+                               BindUnlessForall -> not (isLHsForAllTy hs_ty)
+                               NeverBind        -> False
        ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars ->
     do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
        ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' }
diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs
index 0451e288be..2f27720ee5 100644
--- a/compiler/rename/RnUtils.hs
+++ b/compiler/rename/RnUtils.hs
@@ -244,11 +244,14 @@ warnUnused1 flag fld_env name
   = when (reportable name occ) $
     addUnusedWarning flag
                      occ (nameSrcSpan name)
-                     (text "Defined but not used")
+                     (text $ "Defined but not used" ++ opt_str)
   where
     occ = case lookupNameEnv fld_env name of
               Just (fl, _) -> mkVarOccFS fl
               Nothing      -> nameOccName name
+    opt_str = case flag of
+                Opt_WarnUnusedTypePatterns -> " on the right hand side"
+                _ -> ""
 
 warnUnusedGRE :: GlobalRdrElt -> RnM ()
 warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })