Refactor visible type application.
[ghc.git] / compiler / rename / RnSource.hs
index d6cb2c8..df729dc 100644 (file)
@@ -32,6 +32,7 @@ import HscTypes         ( Warnings(..), plusWarns )
 import Class            ( FunDep )
 import PrelNames        ( applicativeClassName, pureAName, thenAName
                         , monadClassName, returnMName, thenMName
+                        , monadFailClassName, failMName, failMName_preMFP
                         , semigroupClassName, sappendName
                         , monoidClassName, mappendName
                         )
@@ -46,7 +47,7 @@ import FastString
 import SrcLoc
 import DynFlags
 import HscTypes         ( HscEnv, hsc_dflags )
-import ListSetOps       ( findDupsEq, removeDups )
+import ListSetOps       ( findDupsEq, removeDups, equivClasses )
 import Digraph          ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
 import qualified GHC.LanguageExtensions as LangExt
 
@@ -54,9 +55,6 @@ import Control.Monad
 import Data.List ( sortBy )
 import Maybes( orElse, mapMaybe )
 import qualified Data.Set as Set ( difference, fromList, toList, null )
-#if __GLASGOW_HASKELL__ < 709
-import Data.Traversable (traverse)
-#endif
 
 {-
 @rnSourceDecl@ `renames' declarations.
@@ -154,7 +152,13 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
    -- (F) Rename Value declarations right-hand sides
    traceRn (text "Start rnmono") ;
    let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
-   (rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set new_lhs ;
+   is_boot <- tcIsHsBootOrSig ;
+   (rn_val_decls, bind_dus) <- if is_boot
+    -- For an hs-boot, use tc_bndrs (which collects how we're renamed
+    -- signatures), since val_bndr_set is empty (there are no x = ...
+    -- bindings in an hs-boot.)
+    then rnTopBindsBoot tc_bndrs new_lhs
+    else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ;
    traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
 
    -- (G) Rename Fixity and deprecations
@@ -289,7 +293,7 @@ rnSrcFixityDecls bndr_set fix_decls
                     -- this lookup will fail if the definition isn't local
         do names <- lookupLocalTcNames sig_ctxt what rdr_name
            return [ L name_loc name | (_, name) <- names ]
-    what = ptext (sLit "fixity signature")
+    what = text "fixity signature"
 
 {-
 *********************************************************
@@ -328,7 +332,7 @@ rnSrcWarnDecls bndr_set decls'
                                 rdr_names
           ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
 
-   what = ptext (sLit "deprecation")
+   what = text "deprecation"
 
    warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns)
                                                decls
@@ -343,8 +347,8 @@ findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (
 dupWarnDecl :: Located RdrName -> RdrName -> SDoc
 -- Located RdrName -> DeprecDecl RdrName -> SDoc
 dupWarnDecl (L loc _) rdr_name
-  = vcat [ptext (sLit "Multiple warning declarations for") <+> quotes (ppr rdr_name),
-          ptext (sLit "also at ") <+> ppr loc]
+  = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),
+          text "also at " <+> ppr loc]
 
 {-
 *********************************************************
@@ -476,6 +480,9 @@ checkCanonicalInstances cls poly_ty mbinds = do
     whenWOptM Opt_WarnNonCanonicalMonadInstances
         checkCanonicalMonadInstances
 
+    whenWOptM Opt_WarnNonCanonicalMonadFailInstances
+        checkCanonicalMonadFailInstances
+
     whenWOptM Opt_WarnNonCanonicalMonoidInstances
         checkCanonicalMonoidInstances
 
@@ -499,10 +506,12 @@ checkCanonicalInstances cls poly_ty mbinds = do
               case mbind of
                   FunBind { fun_id = L _ name, fun_matches = mg }
                       | name == pureAName, isAliasMG mg == Just returnMName
-                      -> addWarnNonCanonicalMethod1 "pure" "return"
+                      -> addWarnNonCanonicalMethod1
+                            Opt_WarnNonCanonicalMonadInstances "pure" "return"
 
                       | name == thenAName, isAliasMG mg == Just thenMName
-                      -> addWarnNonCanonicalMethod1 "(*>)" "(>>)"
+                      -> addWarnNonCanonicalMethod1
+                            Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"
 
                   _ -> return ()
 
@@ -511,11 +520,50 @@ checkCanonicalInstances cls poly_ty mbinds = do
               case mbind of
                   FunBind { fun_id = L _ name, fun_matches = mg }
                       | name == returnMName, isAliasMG mg /= Just pureAName
-                      -> addWarnNonCanonicalMethod2 "return" "pure"
+                      -> addWarnNonCanonicalMethod2
+                            Opt_WarnNonCanonicalMonadInstances "return" "pure"
 
                       | name == thenMName, isAliasMG mg /= Just thenAName
-                      -> addWarnNonCanonicalMethod2 "(>>)" "(*>)"
+                      -> addWarnNonCanonicalMethod2
+                            Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"
+
+                  _ -> return ()
+
+      | otherwise = return ()
+
+    -- | Warn about unsound/non-canonical 'Monad'/'MonadFail' instance
+    -- declarations. Specifically, the following conditions are verified:
+    --
+    -- In 'Monad' instances declarations:
+    --
+    --  * If 'fail' is overridden it must be canonical
+    --    (i.e. @fail = Control.Monad.Fail.fail@)
+    --
+    -- In 'MonadFail' instance declarations:
+    --
+    --  * Warn if 'fail' is defined backwards
+    --    (i.e. @fail = Control.Monad.fail@).
+    --
+    checkCanonicalMonadFailInstances
+      | cls == monadFailClassName  = do
+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
+              case mbind of
+                  FunBind { fun_id = L _ name, fun_matches = mg }
+                      | name == failMName, isAliasMG mg == Just failMName_preMFP
+                      -> addWarnNonCanonicalMethod1
+                            Opt_WarnNonCanonicalMonadFailInstances "fail"
+                            "Control.Monad.fail"
+
+                  _ -> return ()
 
+      | cls == monadClassName  = do
+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
+              case mbind of
+                  FunBind { fun_id = L _ name, fun_matches = mg }
+                      | name == failMName_preMFP, isAliasMG mg /= Just failMName
+                      -> addWarnNonCanonicalMethod2
+                            Opt_WarnNonCanonicalMonadFailInstances "fail"
+                            "Control.Monad.Fail.fail"
                   _ -> return ()
 
       | otherwise = return ()
@@ -539,7 +587,8 @@ checkCanonicalInstances cls poly_ty mbinds = do
               case mbind of
                   FunBind { fun_id = L _ name, fun_matches = mg }
                       | name == sappendName, isAliasMG mg == Just mappendName
-                      -> addWarnNonCanonicalMethod1 "(<>)" "mappend"
+                      -> addWarnNonCanonicalMethod1
+                            Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"
 
                   _ -> return ()
 
@@ -548,7 +597,8 @@ checkCanonicalInstances cls poly_ty mbinds = do
               case mbind of
                   FunBind { fun_id = L _ name, fun_matches = mg }
                       | name == mappendName, isAliasMG mg /= Just sappendName
-                      -> addWarnNonCanonicalMethod2NoDefault "mappend" "(<>)"
+                      -> addWarnNonCanonicalMethod2NoDefault
+                            Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"
 
                   _ -> return ()
 
@@ -564,8 +614,9 @@ checkCanonicalInstances cls poly_ty mbinds = do
     isAliasMG _ = Nothing
 
     -- got "lhs = rhs" but expected something different
-    addWarnNonCanonicalMethod1 lhs rhs = do
-        addWarn $ vcat [ text "Noncanonical" <+>
+    addWarnNonCanonicalMethod1 flag lhs rhs = do
+        addWarn (Reason flag) $ vcat
+                       [ text "Noncanonical" <+>
                          quotes (text (lhs ++ " = " ++ rhs)) <+>
                          text "definition detected"
                        , instDeclCtxt1 poly_ty
@@ -575,8 +626,9 @@ checkCanonicalInstances cls poly_ty mbinds = do
                        ]
 
     -- expected "lhs = rhs" but got something else
-    addWarnNonCanonicalMethod2 lhs rhs = do
-        addWarn $ vcat [ text "Noncanonical" <+>
+    addWarnNonCanonicalMethod2 flag lhs rhs = do
+        addWarn (Reason flag) $ vcat
+                       [ text "Noncanonical" <+>
                          quotes (text lhs) <+>
                          text "definition detected"
                        , instDeclCtxt1 poly_ty
@@ -586,8 +638,9 @@ checkCanonicalInstances cls poly_ty mbinds = do
                        ]
 
     -- like above, but method has no default impl
-    addWarnNonCanonicalMethod2NoDefault lhs rhs = do
-        addWarn $ vcat [ text "Noncanonical" <+>
+    addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do
+        addWarn (Reason flag) $ vcat
+                       [ text "Noncanonical" <+>
                          quotes (text lhs) <+>
                          text "definition detected"
                        , instDeclCtxt1 poly_ty
@@ -598,11 +651,10 @@ checkCanonicalInstances cls poly_ty mbinds = do
     -- stolen from TcInstDcls
     instDeclCtxt1 :: LHsSigType Name -> SDoc
     instDeclCtxt1 hs_inst_ty
-      | (_, _, head_ty) <- splitLHsInstDeclTy hs_inst_ty
-      = inst_decl_ctxt (ppr head_ty)
+      = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
 
     inst_decl_ctxt :: SDoc -> SDoc
-    inst_decl_ctxt doc = hang (ptext (sLit "in the instance declaration for"))
+    inst_decl_ctxt doc = hang (text "in the instance declaration for")
                          2 (quotes doc <> text ".")
 
 
@@ -668,10 +720,14 @@ rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
                      []             -> pprPanic "rnFamInstDecl" (ppr tycon)
                      (L loc _ : []) -> loc
                      (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
-       ; tv_rdr_names <- extractHsTysRdrTyVars pats
 
+       ; pat_kity_vars_with_dups <- extractHsTysRdrTyVarsDups pats
+             -- Use the "...Dups" form because it's needed
+             -- below to report unsed binder on the LHS
        ; var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) $
-                      freeKiTyVarsAllVars tv_rdr_names
+                      freeKiTyVarsAllVars $
+                      rmDupsInRdrTyVars pat_kity_vars_with_dups
+
              -- All the free vars of the family patterns
              -- with a sensible binding location
        ; ((pats', payload'), fvs)
@@ -679,6 +735,19 @@ rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
                  do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats
                     ; (payload', rhs_fvs) <- rnPayload doc payload
 
+                       -- Report unused binders on the LHS
+                       -- See Note [Unused type variables in family instances]
+                    ; let groups :: [[Located RdrName]]
+                          groups = equivClasses cmpLocated $
+                                   freeKiTyVarsAllVars pat_kity_vars_with_dups
+                    ; tv_nms_dups <- mapM (lookupOccRn . unLoc) $
+                                     [ tv | (tv:_:_) <- groups ]
+                          -- Add to the used variables any variables that
+                          -- appear *more than once* on the LHS
+                          -- e.g.   F a Int a = Bool
+                    ; let tv_nms_used = extendNameSetList rhs_fvs tv_nms_dups
+                    ; warnUnusedTypePatterns var_names tv_nms_used
+
                          -- See Note [Renaming associated types]
                     ; let bad_tvs = case mb_cls of
                                       Nothing           -> []
@@ -691,9 +760,17 @@ rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
                     ; unless (null bad_tvs) (badAssocRhs bad_tvs)
                     ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
 
-       ; let all_fvs = fvs `addOneFV` unLoc tycon'
+       ; let anon_wcs = concatMap collectAnonWildCards pats'
+             all_ibs  = anon_wcs ++ 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
+                        -- Note [Wildcards in family instances]
+             all_fvs  = fvs `addOneFV` unLoc tycon'
+
        ; return (tycon',
-                 HsIB { hsib_body = pats', hsib_vars = var_names },
+                 HsIB { hsib_body = pats'
+                      , hsib_vars = all_ibs },
                  payload',
                  all_fvs) }
              -- type instance => use, hence addOneFV
@@ -724,7 +801,7 @@ rnTyFamDefltEqn :: Name
 rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
                               , tfe_pats  = tyvars
                               , tfe_rhs   = rhs })
-  = bindHsQTyVars ctx (Just cls) [] tyvars $ \ tyvars' ->
+  = bindHsQTyVars ctx Nothing (Just cls) [] tyvars $ \ tyvars' ->
     do { tycon'      <- lookupFamInstName (Just cls) tycon
        ; (rhs', fvs) <- rnLHsType ctx rhs
        ; return (TyFamEqn { tfe_tycon = tycon'
@@ -771,7 +848,46 @@ rnATInstDecls rnFun cls tv_ns at_insts
   = rnList (rnFun (Just (cls, tv_ns))) at_insts
     -- See Note [Renaming associated types]
 
-{-
+{- Note [Wildcards in family instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Wild cards can be used in type/data family instance declarations to indicate
+that the name of a type variable doesn't matter. Each wild card will be
+replaced with a new unique type variable. For instance:
+
+    type family F a b :: *
+    type instance F Int _ = Int
+
+is the same as
+
+    type family F a b :: *
+    type instance F Int b = Int
+
+This is implemented as follows: during renaming anonymous wild cards
+'_' are given freshly generated names. These names are collected after
+renaming (rnFamInstDecl) and used to make new type variables during
+type checking (tc_fam_ty_pats). One should not confuse these wild
+cards with the ones from partial type signatures. The latter generate
+fresh meta-variables whereas the former generate fresh skolems.
+
+Note [Unused type variables in family instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the flag -fwarn-unused-type-patterns is on, the compiler reports warnings
+about unused type variables. (rnFamInstDecl) A type variable is considered
+used
+ * when it is either occurs on the RHS of the family instance, or
+   e.g.   type instance F a b = a    -- a is used on the RHS
+
+ * it occurs multiple times in the patterns on the LHS
+   e.g.   type instance F a a = Int  -- a appears more than once on LHS
+
+As usual, the warnings are not reported for for type variables with names
+beginning with an underscore.
+
+Extra-constraints wild cards are not supported in type/data family
+instance declarations.
+
+Relevant tickets: #3699, #10586, #10982 and #11451.
+
 Note [Renaming associated types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Check that the RHS of the decl mentions only type variables
@@ -818,8 +934,8 @@ rnSrcDerivDecl (DerivDecl ty overlap)
 
 standaloneDerivErr :: SDoc
 standaloneDerivErr
-  = hang (ptext (sLit "Illegal standalone deriving declaration"))
-       2 (ptext (sLit "Use StandaloneDeriving to enable this extension"))
+  = hang (text "Illegal standalone deriving declaration")
+       2 (text "Use StandaloneDeriving to enable this extension")
 
 {-
 *********************************************************
@@ -908,6 +1024,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 (HsVar (L _ v)) | v `notElem` foralls = Nothing
     check other                           = Just other  -- Failure
 
@@ -931,21 +1048,21 @@ validRuleLhs foralls lhs
 
 badRuleVar :: FastString -> Name -> SDoc
 badRuleVar name var
-  = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
-         ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+>
-                ptext (sLit "does not appear on left hand side")]
+  = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,
+         text "Forall'd variable" <+> quotes (ppr var) <+>
+                text "does not appear on left hand side"]
 
 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
 badRuleLhsErr name lhs bad_e
-  = sep [ptext (sLit "Rule") <+> pprRuleName name <> colon,
+  = sep [text "Rule" <+> pprRuleName name <> colon,
          nest 4 (vcat [err,
-                       ptext (sLit "in left-hand side:") <+> ppr lhs])]
+                       text "in left-hand side:" <+> ppr lhs])]
     $$
-    ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
+    text "LHS must be of form (f e1 .. en) where f is not forall'd"
   where
     err = case bad_e of
-            HsUnboundVar occ -> ptext (sLit "Not in scope:") <+> ppr occ
-            _ -> ptext (sLit "Illegal expression:") <+> ppr bad_e
+            HsUnboundVar occ -> text "Not in scope:" <+> ppr occ
+            _ -> text "Illegal expression:" <+> ppr bad_e
 
 {-
 *********************************************************
@@ -965,8 +1082,8 @@ rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _)))
        }
 rnHsVectDecl (HsVect _ _var _rhs)
   = failWith $ vcat
-               [ ptext (sLit "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma")
-               , ptext (sLit "must be an identifier")
+               [ text "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma"
+               , text "must be an identifier"
                ]
 rnHsVectDecl (HsNoVect s var)
   = do { var' <- lookupLocatedTopBndrRn var           -- only applies to local (not imported) names
@@ -1065,7 +1182,7 @@ See also Note [Grouping of type and class declarations] in TcTyClsDecls.
 
 rnTyClDecls :: [TyClGroup RdrName]
             -> RnM ([TyClGroup Name], FreeVars)
--- Rename the declarations and do depedency analysis on them
+-- Rename the declarations and do dependency analysis on them
 rnTyClDecls tycl_ds
   = do { ds_w_fvs       <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat tycl_ds)
        ; let decl_names = mkNameSet (map (tcdName . unLoc . fst) ds_w_fvs)
@@ -1133,7 +1250,7 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
        ; kvs <- freeKiTyVarsKindVars <$> extractHsTyRdrTyVars rhs
        ; let doc = TySynCtx tycon
        ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
-       ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing kvs tyvars $
+       ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing Nothing kvs tyvars $
                                     \ tyvars' ->
                                     do { (rhs', fvs) <- rnTySyn doc rhs
                                        ; return ((tyvars', rhs'), fvs) }
@@ -1147,7 +1264,7 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn
        ; kvs <- extractDataDefnKindVars defn
        ; let doc = TyDataCtx tycon
        ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
-       ; ((tyvars', defn'), fvs) <- bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' ->
+       ; ((tyvars', defn'), fvs) <- bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' ->
                                     do { (defn', fvs) <- rnDataDefn doc defn
                                        ; return ((tyvars', defn'), fvs) }
        ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
@@ -1164,7 +1281,7 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
 
         -- Tyvars scope over superclass context and method signatures
         ; ((tyvars', context', fds', ats'), stuff_fvs)
-            <- bindHsQTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do
+            <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' -> do
                   -- Checks for distinct tyvars
              { (context', cxt_fvs) <- rnContext cls_doc context
              ; fds'  <- rnFds fds
@@ -1316,8 +1433,8 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
 
 badGadtStupidTheta :: HsDocContext -> SDoc
 badGadtStupidTheta _
-  = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
-          ptext (sLit "(You can put a context on each contructor, though.)")]
+  = vcat [text "No context is allowed on a GADT-style data declaration",
+          text "(You can put a context on each contructor, though.)"]
 
 rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested
                         --             inside an *class decl* for cls
@@ -1330,7 +1447,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
   = do { tycon' <- lookupLocatedTopBndrRn tycon
        ; kvs <- extractRdrKindSigVars res_sig
        ; ((tyvars', res_sig', injectivity'), fv1) <-
-            bindHsQTyVars doc mb_cls kvs tyvars $
+            bindHsQTyVars doc Nothing mb_cls kvs tyvars $
             \ tyvars'@(HsQTvs { hsq_implicit = rn_kvs }) ->
             do { let rn_sig = rnFamResultSig doc rn_kvs
                ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
@@ -1576,9 +1693,9 @@ modules), we get better error messages, too.
 ---------------
 badAssocRhs :: [Name] -> RnM ()
 badAssocRhs ns
-  = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions")
+  = addErr (hang (text "The RHS of an associated type declaration mentions"
                   <+> pprWithCommas (quotes . ppr) ns)
-               2 (ptext (sLit "All such variables must be bound on the LHS")))
+               2 (text "All such variables must be bound on the LHS"))
 
 -----------------
 rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
@@ -1594,7 +1711,8 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
         ; mb_doc'      <- rnMbLHsDoc mb_doc
         ; (kvs, qtvs') <- get_con_qtvs (hsConDeclArgTys details)
 
-        ; bindHsQTyVars doc Nothing kvs qtvs' $ \new_tyvars -> do
+        ; bindHsQTyVars doc (Just $ inHsDocContext doc) Nothing kvs qtvs' $
+          \new_tyvars -> do
         { (new_context, fvs1) <- case mcxt of
                              Nothing   -> return (Nothing,emptyFVs)
                              Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt
@@ -1606,8 +1724,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
              , text "qtvs:" <+> ppr qtvs
              , text "qtvs':" <+> ppr qtvs' ])
         ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
-        ; warnUnusedForAlls (inHsDocContext doc) (hsQTvExplicit new_tyvars) all_fvs
-        ; let new_tyvars' = case qtvs of
+              new_tyvars' = case qtvs of
                 Nothing -> Nothing
                 Just _ -> Just new_tyvars
         ; return (decl { con_name = new_name, con_qvars = new_tyvars'
@@ -1657,7 +1774,7 @@ rnConDeclDetails _ doc (InfixCon ty1 ty2)
 
 rnConDeclDetails con doc (RecCon (L l fields))
   = do  { fls <- lookupConstructorFields con
-        ; (new_fields, fvs) <- rnConDeclFields fls doc fields
+        ; (new_fields, fvs) <- rnConDeclFields doc fls fields
                 -- No need to check for duplicate fields
                 -- since that is done by RnNames.extendGlobalRdrEnvRn
         ; return (RecCon (L l new_fields), fvs) }
@@ -1776,8 +1893,8 @@ add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
 
        ; return (gp, Just (splice, ds)) }
   where
-    badImplicitSplice = ptext (sLit "Parse error: naked expression at top level")
-                     $$ ptext (sLit "Perhaps you intended to use TemplateHaskell")
+    badImplicitSplice = text "Parse error: naked expression at top level"
+                     $$ text "Perhaps you intended to use TemplateHaskell"
 
 -- Class declarations: pull out the fixity signatures to the top
 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds