Print which warning-flag controls an emitted warning
[ghc.git] / compiler / rename / RnEnv.hs
index 57b427b..0ecd85e 100644 (file)
@@ -4,7 +4,7 @@
 \section[RnEnv]{Environment manipulation for the renamer monad}
 -}
 
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, MultiWayIf #-}
 
 module RnEnv (
         newTopSrcBinder,
@@ -13,7 +13,7 @@ module RnEnv (
         lookupLocalOccRn_maybe, lookupInfoOccRn,
         lookupLocalOccThLvl_maybe,
         lookupTypeOccRn, lookupKindOccRn,
-        lookupGlobalOccRn, lookupGlobalOccRn_maybe,
+        lookupGlobalOccRn, lookupGlobalOccRnExport, lookupGlobalOccRn_maybe,
         lookupOccRn_overloaded, lookupGlobalOccRn_overloaded,
         reportUnboundName, unknownNameSuggestions,
         addNameClashErrRn,
@@ -21,7 +21,8 @@ module RnEnv (
         HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
         lookupSigCtxtOccRn,
 
-        lookupFixityRn, lookupTyFixityRn,
+        lookupFixityRn, lookupFixityRn_help,
+        lookupFieldFixityRn, lookupTyFixityRn,
         lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName,
         lookupConstructorFields,
         lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse,
@@ -37,9 +38,10 @@ module RnEnv (
         extendTyVarEnvFVRn,
 
         checkDupRdrNames, checkShadowedRdrNames,
-        checkDupNames, checkDupAndShadowedNames, checkTupSize,
+        checkDupNames, checkDupAndShadowedNames, dupNamesErr,
+        checkTupSize,
         addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
-        warnUnusedMatches,
+        warnUnusedMatches, warnUnusedTypePatterns,
         warnUnusedTopBinds, warnUnusedLocalBinds,
         mkFieldEnv,
         dataTcOccs, kindSigErr, perhapsForallMsg, unknownSubordinateErr,
@@ -57,6 +59,7 @@ import HscTypes
 import TcEnv
 import TcRnMonad
 import RdrHsSyn         ( setRdrNameSpace )
+import TysWiredIn       ( starKindTyConName, unicodeStarKindTyConName )
 import Name
 import NameSet
 import NameEnv
@@ -81,6 +84,7 @@ import Data.List
 import Data.Function    ( on )
 import ListSetOps       ( minusList )
 import Constants        ( mAX_TUPLE_SIZE )
+import qualified GHC.LanguageExtensions as LangExt
 
 {-
 *********************************************************
@@ -300,7 +304,7 @@ lookupTopBndrRn_maybe rdr_name
            -- See Note [Type and class operator definitions]
           let occ = rdrNameOcc rdr_name
         ; when (isTcOcc occ && isSymOcc occ)
-               (do { op_ok <- xoptM Opt_TypeOperators
+               (do { op_ok <- xoptM LangExt.TypeOperators
                    ; unless op_ok (addErr (opDeclErr rdr_name)) })
 
         ; env <- getGlobalRdrEnv
@@ -369,26 +373,26 @@ lookupExactOcc_either name
            gres -> return (Left (sameNameErr gres))   -- Ugh!  See Note [Template Haskell ambiguity]
        }
   where
-    exact_nm_err = hang (ptext (sLit "The exact Name") <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))
-                      2 (vcat [ ptext (sLit "Probable cause: you used a unique Template Haskell name (NameU), ")
-                              , ptext (sLit "perhaps via newName, but did not bind it")
-                              , ptext (sLit "If that's it, then -ddump-splices might be useful") ])
+    exact_nm_err = hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))
+                      2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), "
+                              , text "perhaps via newName, but did not bind it"
+                              , text "If that's it, then -ddump-splices might be useful" ])
 
 sameNameErr :: [GlobalRdrElt] -> MsgDoc
 sameNameErr [] = panic "addSameNameErr: empty list"
 sameNameErr gres@(_ : _)
-  = hang (ptext (sLit "Same exact name in multiple name-spaces:"))
+  = hang (text "Same exact name in multiple name-spaces:")
        2 (vcat (map pp_one sorted_names) $$ th_hint)
   where
     sorted_names = sortWith nameSrcLoc (map gre_name gres)
     pp_one name
       = hang (pprNameSpace (occNameSpace (getOccName name))
               <+> quotes (ppr name) <> comma)
-           2 (ptext (sLit "declared at:") <+> ppr (nameSrcLoc name))
+           2 (text "declared at:" <+> ppr (nameSrcLoc name))
 
-    th_hint = vcat [ ptext (sLit "Probable cause: you bound a unique Template Haskell name (NameU),")
-                   , ptext (sLit "perhaps via newName, in different name-spaces.")
-                   , ptext (sLit "If that's it, then -ddump-splices might be useful") ]
+    th_hint = vcat [ text "Probable cause: you bound a unique Template Haskell name (NameU),"
+                   , text "perhaps via newName, in different name-spaces."
+                   , text "If that's it, then -ddump-splices might be useful" ]
 
 
 -----------------------------------------------
@@ -423,7 +427,7 @@ lookupInstDeclBndr cls what rdr
            Left err -> do { addErr err; return (mkUnboundNameRdr rdr) }
            Right nm -> return nm }
   where
-    doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls)
+    doc = what <+> text "of class" <+> quotes (ppr cls)
 
 
 -----------------------------------------------
@@ -431,7 +435,7 @@ lookupFamInstName :: Maybe Name -> Located RdrName -> RnM (Located Name)
 -- Used for TyData and TySynonym family instances only,
 -- See Note [Family instance binders]
 lookupFamInstName (Just cls) tc_rdr  -- Associated type; c.f RnBinds.rnMethodBind
-  = wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr
+  = wrapLocM (lookupInstDeclBndr cls (text "associated type")) tc_rdr
 lookupFamInstName Nothing tc_rdr     -- Family instance; tc_rdr is an *occurrence*
   = lookupLocatedOccRn tc_rdr
 
@@ -710,10 +714,13 @@ lookupOccRn rdr_name
 lookupKindOccRn :: RdrName -> RnM Name
 -- Looking up a name occurring in a kind
 lookupKindOccRn rdr_name
-  = do { mb_name <- lookupOccRn_maybe rdr_name
-       ; case mb_name of
-           Just name -> return name
-           Nothing   -> reportUnboundName rdr_name  }
+  = do { typeintype <- xoptM LangExt.TypeInType
+       ; if | typeintype           -> lookupTypeOccRn rdr_name
+      -- With -XNoTypeInType, treat any usage of * in kinds as in scope
+      -- this is a dirty hack, but then again so was the old * kind.
+            | is_star rdr_name     -> return starKindTyConName
+            | is_uni_star rdr_name -> return unicodeStarKindTyConName
+            | otherwise            -> lookupOccRn rdr_name }
 
 -- lookupPromotedOccRn looks up an optionally promoted RdrName.
 lookupTypeOccRn :: RdrName -> RnM Name
@@ -722,20 +729,22 @@ lookupTypeOccRn rdr_name
   = do { mb_name <- lookupOccRn_maybe rdr_name
        ; case mb_name of {
              Just name -> return name ;
-             Nothing   -> lookup_demoted rdr_name } }
+             Nothing   -> do { dflags <- getDynFlags
+                             ; lookup_demoted rdr_name dflags } } }
 
-lookup_demoted :: RdrName -> RnM Name
-lookup_demoted rdr_name
+lookup_demoted :: RdrName -> DynFlags -> RnM Name
+lookup_demoted rdr_name dflags
   | Just demoted_rdr <- demoteRdrName rdr_name
     -- Maybe it's the name of a *data* constructor
-  = do { data_kinds <- xoptM Opt_DataKinds
+  = do { data_kinds <- xoptM LangExt.DataKinds
        ; mb_demoted_name <- lookupOccRn_maybe demoted_rdr
        ; case mb_demoted_name of
-           Nothing -> reportUnboundName rdr_name
+           Nothing -> unboundNameX WL_Any rdr_name star_info
            Just demoted_name
              | data_kinds ->
              do { whenWOptM Opt_WarnUntickedPromotedConstructors $
-                  addWarn (untickedPromConstrWarn demoted_name)
+                  addWarn (Reason Opt_WarnUntickedPromotedConstructors)
+                          (untickedPromConstrWarn demoted_name)
                 ; return demoted_name }
              | otherwise  -> unboundNameX WL_Any rdr_name suggest_dk }
 
@@ -743,7 +752,7 @@ lookup_demoted rdr_name
   = reportUnboundName rdr_name
 
   where
-    suggest_dk = ptext (sLit "A data constructor of that name is in scope; did you mean DataKinds?")
+    suggest_dk = text "A data constructor of that name is in scope; did you mean DataKinds?"
     untickedPromConstrWarn name =
       text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot
       $$
@@ -752,6 +761,20 @@ lookup_demoted rdr_name
            , text "instead of"
            , quotes (ppr name) <> dot ]
 
+    star_info
+      | is_star rdr_name || is_uni_star rdr_name
+      = if xopt LangExt.TypeInType dflags
+        then text "NB: With TypeInType, you must import" <+>
+             ppr rdr_name <+> text "from Data.Kind"
+        else empty
+
+      | otherwise
+      = empty
+
+is_star, is_uni_star :: RdrName -> Bool
+is_star     = (fsLit "*" ==) . occNameFS . rdrNameOcc
+is_uni_star = (fsLit "★" ==) . occNameFS . rdrNameOcc
+
 {-
 Note [Demotion]
 ~~~~~~~~~~~~~~~
@@ -831,6 +854,27 @@ lookupGlobalOccRn rdr_name
            Nothing -> do { traceRn (text "lookupGlobalOccRn" <+> ppr rdr_name)
                          ; unboundName WL_Global rdr_name } }
 
+-- like lookupGlobalOccRn but suggests adding 'type' keyword
+-- to export type constructors mistaken for data constructors
+lookupGlobalOccRnExport :: RdrName -> RnM Name
+lookupGlobalOccRnExport rdr_name
+  = do { mb_name <- lookupGlobalOccRn_maybe rdr_name
+       ; case mb_name of
+           Just n  -> return n
+           Nothing -> do { env <- getGlobalRdrEnv
+                         ; let tycon = setOccNameSpace tcClsName (rdrNameOcc rdr_name)
+                               msg = case lookupOccEnv env tycon of
+                                   Just (gre : _) -> make_msg gre
+                                   _              -> Outputable.empty
+                               make_msg gre = hang
+                                   (hsep [text "Note: use",
+                                       quotes (text "type"),
+                                       text "keyword to export type constructor",
+                                       quotes (ppr (gre_name gre))])
+                                   2 (vcat [pprNameProvenance gre,
+                                       text "(requires TypeOperators extension)"])
+                         ; unboundNameX WL_Global rdr_name msg } }
+
 lookupInfoOccRn :: RdrName -> RnM [Name]
 -- lookupInfoOccRn is intended for use in GHCi's ":info" command
 -- It finds all the GREs that RdrName could mean, not complaining
@@ -891,8 +935,10 @@ lookupGlobalOccRn_overloaded overload_ok rdr_name
                 []    -> return Nothing
                 [gre] | isRecFldGRE gre
                          -> do { addUsedGRE True gre
-                               ; let fld_occ :: FieldOcc Name
-                                     fld_occ = FieldOcc rdr_name (gre_name gre)
+                               ; let
+                                   fld_occ :: FieldOcc Name
+                                   fld_occ
+                                     = FieldOcc (noLoc rdr_name) (gre_name gre)
                                ; return (Just (Right [fld_occ])) }
                       | otherwise
                          -> do { addUsedGRE True gre
@@ -900,7 +946,10 @@ lookupGlobalOccRn_overloaded overload_ok rdr_name
                 gres  | all isRecFldGRE gres && overload_ok
                             -- Don't record usage for ambiguous selectors
                             -- until we know which is meant
-                         -> return (Just (Right (map (FieldOcc rdr_name . gre_name) gres)))
+                         -> return
+                             (Just (Right
+                                     (map (FieldOcc (noLoc rdr_name) . gre_name)
+                                           gres)))
                 gres     -> do { addNameClashErrRn rdr_name gres
                                ; return (Just (Left (gre_name (head gres)))) } }
 
@@ -1020,33 +1069,34 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss })
                    -- See Note [Handling of deprecations]
          do { iface <- loadInterfaceForName doc name
             ; case lookupImpDeprec iface gre of
-                Just txt -> addWarn (mk_msg imp_spec txt)
+                Just txt -> addWarn (Reason Opt_WarnWarningsDeprecations)
+                                   (mk_msg imp_spec txt)
                 Nothing  -> return () } }
   | otherwise
   = return ()
   where
     occ = greOccName gre
     name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name
-    doc = ptext (sLit "The name") <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly")
+    doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly")
 
     mk_msg imp_spec txt
-      = sep [ sep [ ptext (sLit "In the use of")
+      = sep [ sep [ text "In the use of"
                     <+> pprNonVarNameSpace (occNameSpace occ)
                     <+> quotes (ppr occ)
                   , parens imp_msg <> colon ]
             , ppr txt ]
       where
         imp_mod  = importSpecModule imp_spec
-        imp_msg  = ptext (sLit "imported from") <+> ppr imp_mod <> extra
+        imp_msg  = text "imported from" <+> ppr imp_mod <> extra
         extra | imp_mod == moduleName name_mod = Outputable.empty
-              | otherwise = ptext (sLit ", but defined in") <+> ppr name_mod
+              | otherwise = text ", but defined in" <+> ppr name_mod
 
 lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt
 lookupImpDeprec iface gre
-  = mi_warn_fn iface (gre_name gre) `mplus`  -- Bleat if the thing,
+  = mi_warn_fn iface (greOccName gre) `mplus`  -- Bleat if the thing,
     case gre_par gre of                      -- or its parent, is warn'd
-       ParentIs  p              -> mi_warn_fn iface p
-       FldParent { par_is = p } -> mi_warn_fn iface p
+       ParentIs  p              -> mi_warn_fn iface (nameOccName p)
+       FldParent { par_is = p } -> mi_warn_fn iface (nameOccName p)
        NoParent                 -> Nothing
        PatternSynonym           -> Nothing
 
@@ -1124,7 +1174,7 @@ lookupQualifiedNameGHCi rdr_name
       = do { traceRn (text "lookupQualifedNameGHCi: off" <+> ppr rdr_name)
            ; return [] }
 
-    doc = ptext (sLit "Need to find") <+> ppr rdr_name
+    doc = text "Need to find" <+> ppr rdr_name
 
 {-
 Note [Looking up signature names]
@@ -1230,7 +1280,7 @@ lookupBindGroupOcc ctxt what rdr_name
     lookup_cls_op cls
       = lookupSubBndrOcc True cls doc rdr_name
       where
-        doc = ptext (sLit "method of class") <+> quotes (ppr cls)
+        doc = text "method of class" <+> quotes (ppr cls)
 
     lookup_top keep_me
       = do { env <- getGlobalRdrEnv
@@ -1249,17 +1299,17 @@ lookupBindGroupOcc ctxt what rdr_name
                Nothing                         -> bale_out_with Outputable.empty }
 
     bale_out_with msg
-        = return (Left (sep [ ptext (sLit "The") <+> what
-                                <+> ptext (sLit "for") <+> quotes (ppr rdr_name)
-                           , nest 2 $ ptext (sLit "lacks an accompanying binding")]
+        = return (Left (sep [ text "The" <+> what
+                                <+> text "for" <+> quotes (ppr rdr_name)
+                           , nest 2 $ text "lacks an accompanying binding"]
                        $$ nest 2 msg))
 
-    local_msg = parens $ ptext (sLit "The")  <+> what <+> ptext (sLit "must be given where")
-                           <+> quotes (ppr rdr_name) <+> ptext (sLit "is declared")
+    local_msg = parens $ text "The"  <+> what <+> ptext (sLit "must be given where")
+                           <+> quotes (ppr rdr_name) <+> text "is declared"
 
 
 ---------------
-lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [Name]
+lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)]
 -- GHC extension: look up both the tycon and data con or variable.
 -- Used for top-level fixity signatures and deprecations.
 -- Complain if neither is in scope.
@@ -1270,7 +1320,8 @@ lookupLocalTcNames ctxt what rdr_name
        ; when (null names) $ addErr (head errs) -- Bleat about one only
        ; return names }
   where
-    lookup = lookupBindGroupOcc ctxt what
+    lookup rdr = do { name <- lookupBindGroupOcc ctxt what rdr
+                    ; return (fmap ((,) rdr) name) }
 
 dataTcOccs :: RdrName -> [RdrName]
 -- Return both the given name and the same name promoted to the TcClsName
@@ -1373,9 +1424,26 @@ lookupFixity is a bit strange.
 -}
 
 lookupFixityRn :: Name -> RnM Fixity
-lookupFixityRn name
+lookupFixityRn name = lookupFixityRn' name (nameOccName name)
+
+lookupFixityRn' :: Name -> OccName -> RnM Fixity
+lookupFixityRn' name = fmap snd . lookupFixityRn_help' name
+
+-- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity'
+-- in a local environment or from an interface file. Otherwise, it returns
+-- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without
+-- user-supplied fixity declarations).
+lookupFixityRn_help :: Name
+                    -> RnM (Bool, Fixity)
+lookupFixityRn_help name =
+    lookupFixityRn_help' name (nameOccName name)
+
+lookupFixityRn_help' :: Name
+                     -> OccName
+                     -> RnM (Bool, Fixity)
+lookupFixityRn_help' name occ
   | isUnboundName name
-  = return (Fixity minPrecedence InfixL)
+  = return (False, Fixity (show minPrecedence) minPrecedence InfixL)
     -- Minimise errors from ubound names; eg
     --    a>0 `foo` b>0
     -- where 'foo' is not in scope, should not give an error (Trac #7937)
@@ -1383,14 +1451,14 @@ lookupFixityRn name
   | otherwise
   = do { local_fix_env <- getFixityEnv
        ; case lookupNameEnv local_fix_env name of {
-           Just (FixItem _ fix) -> return fix ;
+           Just (FixItem _ fix) -> return (True, fix) ;
            Nothing ->
 
     do { this_mod <- getModule
        ; if nameIsLocalOrFrom this_mod name
                -- Local (and interactive) names are all in the
                -- fixity env, and don't have entries in the HPT
-         then return defaultFixity
+         then return (False, defaultFixity)
          else lookup_imported } } }
   where
     lookup_imported
@@ -1411,16 +1479,62 @@ lookupFixityRn name
       -- loadInterfaceForName will find B.hi even if B is a hidden module,
       -- and that's what we want.
       = do { iface <- loadInterfaceForName doc name
-           ; traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+>
-                      vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)])
-           ; return (mi_fix_fn iface (nameOccName name)) }
-
-    doc = ptext (sLit "Checking fixity for") <+> ppr name
+           ; let mb_fix = mi_fix_fn iface occ
+           ; let msg = case mb_fix of
+                            Nothing ->
+                                  text "looking up name" <+> ppr name
+                              <+> text "in iface, but found no fixity for it."
+                              <+> text "Using default fixity instead."
+                            Just f ->
+                                  text "looking up name in iface and found:"
+                              <+> vcat [ppr name, ppr f]
+           ; traceRn (text "lookupFixityRn_either:" <+> msg)
+           ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix)  }
+
+    doc = text "Checking fixity for" <+> ppr name
 
 ---------------
 lookupTyFixityRn :: Located Name -> RnM Fixity
 lookupTyFixityRn (L _ n) = lookupFixityRn n
 
+-- | Look up the fixity of a (possibly ambiguous) occurrence of a record field
+-- selector.  We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as
+-- the field label, which might be different to the 'OccName' of the selector
+-- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are
+-- multiple possible selectors with different fixities, generate an error.
+lookupFieldFixityRn :: AmbiguousFieldOcc Name -> RnM Fixity
+lookupFieldFixityRn (Unambiguous (L _ rdr) n)
+  = lookupFixityRn' n (rdrNameOcc rdr)
+lookupFieldFixityRn (Ambiguous   (L _ rdr) _) = get_ambiguous_fixity rdr
+  where
+    get_ambiguous_fixity :: RdrName -> RnM Fixity
+    get_ambiguous_fixity rdr_name = do
+      traceRn $ text "get_ambiguous_fixity" <+> ppr rdr_name
+      rdr_env <- getGlobalRdrEnv
+      let elts =  lookupGRE_RdrName rdr_name rdr_env
+
+      fixities <- groupBy ((==) `on` snd) . zip elts
+                  <$> mapM lookup_gre_fixity elts
+
+      case fixities of
+        -- There should always be at least one fixity.
+        -- Something's very wrong if there are no fixity candidates, so panic
+        [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName"
+        [ (_, fix):_ ] -> return fix
+        ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)
+                  >> return (Fixity(show minPrecedence) minPrecedence InfixL)
+
+    lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre)
+
+    ambiguous_fixity_err rn ambigs
+      = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn)
+             , hang (text "Conflicts: ") 2 . vcat .
+               map format_ambig $ concat ambigs ]
+
+    format_ambig (elt, fix) = hang (ppr fix)
+                                 2 (pprNameProvenance elt)
+
+
 {-
 ************************************************************************
 *                                                                      *
@@ -1467,27 +1581,29 @@ lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars)
 -- case we desugar directly rather than calling an existing function
 -- Hence the (Maybe (SyntaxExpr Name)) return type
 lookupIfThenElse
-  = do { rebindable_on <- xoptM Opt_RebindableSyntax
+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
        ; if not rebindable_on
          then return (Nothing, emptyFVs)
          else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))
-                 ; return (Just (HsVar (noLoc ite)), unitFV ite) } }
+                 ; return ( Just (mkRnSyntaxExpr ite)
+                          , unitFV ite ) } }
 
 lookupSyntaxName :: Name                                -- The standard name
                  -> RnM (SyntaxExpr Name, FreeVars)     -- Possibly a non-standard name
 lookupSyntaxName std_name
-  = do { rebindable_on <- xoptM Opt_RebindableSyntax
+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
        ; if not rebindable_on then
-           return (HsVar (noLoc std_name), emptyFVs)
+           return (mkRnSyntaxExpr std_name, emptyFVs)
          else
             -- Get the similarly named thing from the local environment
            do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name))
-              ; return (HsVar (noLoc usr_name), unitFV usr_name) } }
+              ; return (mkRnSyntaxExpr usr_name, unitFV usr_name) } }
 
 lookupSyntaxNames :: [Name]                          -- Standard names
                   -> RnM ([HsExpr Name], FreeVars)   -- See comments with HsExpr.ReboundNames
+   -- this works with CmdTop, which wants HsExprs, not SyntaxExprs
 lookupSyntaxNames std_names
-  = do { rebindable_on <- xoptM Opt_RebindableSyntax
+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
        ; if not rebindable_on then
              return (map (HsVar . noLoc) std_names, emptyFVs)
         else
@@ -1613,7 +1729,7 @@ checkShadowedOccs (global_env,local_env) get_loc_occ ns
     check_shadow n
         | startsWithUnderscore occ = return ()  -- Do not report shadowing for "_x"
                                                 -- See Trac #3262
-        | Just n <- mb_local = complain [ptext (sLit "bound at") <+> ppr (nameSrcLoc n)]
+        | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)]
         | otherwise = do { gres' <- filterM is_shadowed_gre gres
                          ; complain (map pprNameProvenance gres') }
         where
@@ -1624,14 +1740,17 @@ checkShadowedOccs (global_env,local_env) get_loc_occ ns
                 -- we don't find any GREs that are in scope qualified-only
 
           complain []      = return ()
-          complain pp_locs = addWarnAt loc (shadowedNameWarn occ pp_locs)
+          complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing)
+                                       loc
+                                       (shadowedNameWarn occ pp_locs)
 
     is_shadowed_gre :: GlobalRdrElt -> RnM Bool
         -- Returns False for record selectors that are shadowed, when
         -- punning or wild-cards are on (cf Trac #2723)
     is_shadowed_gre gre | isRecFldGRE gre
         = do { dflags <- getDynFlags
-             ; return $ not (xopt Opt_RecordPuns dflags || xopt Opt_RecordWildCards dflags) }
+             ; return $ not (xopt LangExt.RecordPuns dflags
+                             || xopt LangExt.RecordWildCards dflags) }
     is_shadowed_gre _other = return True
 
 {-
@@ -1670,7 +1789,7 @@ unboundNameX where_look rdr_name extra
 
 unknownNameErr :: SDoc -> RdrName -> SDoc
 unknownNameErr what rdr_name
-  = vcat [ hang (ptext (sLit "Not in scope:"))
+  = vcat [ hang (text "Not in scope:")
               2 (what <+> quotes (ppr rdr_name))
          , extra ]
   where
@@ -1704,7 +1823,7 @@ similarNameSuggestions where_look dflags global_env
   = case suggest of
       []  -> Outputable.empty
       [p] -> perhaps <+> pp_item p
-      ps  -> sep [ perhaps <+> ptext (sLit "one of these:")
+      ps  -> sep [ perhaps <+> text "one of these:"
                  , nest 2 (pprWithCommas pp_item ps) ]
   where
     all_possibilities :: [(String, (RdrName, HowInScope))]
@@ -1714,15 +1833,15 @@ similarNameSuggestions where_look dflags global_env
        ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]
 
     suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities
-    perhaps = ptext (sLit "Perhaps you meant")
+    perhaps = text "Perhaps you meant"
 
     pp_item :: (RdrName, HowInScope) -> SDoc
     pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined
         where loc' = case loc of
                      UnhelpfulSpan l -> parens (ppr l)
-                     RealSrcSpan l -> parens (ptext (sLit "line") <+> int (srcSpanStartLine l))
+                     RealSrcSpan l -> parens (text "line" <+> int (srcSpanStartLine l))
     pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+>   -- Imported
-                              parens (ptext (sLit "imported from") <+> ppr (is_mod is))
+                              parens (text "imported from" <+> ppr (is_mod is))
 
     pp_ns :: RdrName -> SDoc
     pp_ns rdr | ns /= tried_ns = pprNameSpace ns
@@ -1820,42 +1939,42 @@ importSuggestions _dflags imports rdr_name
   | null interesting_imports
   , Just name <- mod_name
   = hsep
-      [ ptext (sLit "No module named")
+      [ text "No module named"
       , quotes (ppr name)
-      , ptext (sLit "is imported.")
+      , text "is imported."
       ]
   | is_qualified
   , null helpful_imports
   , [(mod,_)] <- interesting_imports
   = hsep
-      [ ptext (sLit "Module")
+      [ text "Module"
       , quotes (ppr mod)
-      , ptext (sLit "does not export")
+      , text "does not export"
       , quotes (ppr occ_name) <> dot
       ]
   | is_qualified
   , null helpful_imports
   , mods <- map fst interesting_imports
   = hsep
-      [ ptext (sLit "Neither")
+      [ text "Neither"
       , quotedListWithNor (map ppr mods)
-      , ptext (sLit "exports")
+      , text "exports"
       , quotes (ppr occ_name) <> dot
       ]
   | [(mod,imv)] <- helpful_imports_non_hiding
   = fsep
-      [ ptext (sLit "Perhaps you want to add")
+      [ text "Perhaps you want to add"
       , quotes (ppr occ_name)
-      , ptext (sLit "to the import list")
-      , ptext (sLit "in the import of")
+      , text "to the import list"
+      , text "in the import of"
       , quotes (ppr mod)
       , parens (ppr (imv_span imv)) <> dot
       ]
   | not (null helpful_imports_non_hiding)
   = fsep
-      [ ptext (sLit "Perhaps you want to add")
+      [ text "Perhaps you want to add"
       , quotes (ppr occ_name)
-      , ptext (sLit "to one of these import lists:")
+      , text "to one of these import lists:"
       ]
     $$
     nest 2 (vcat
@@ -1864,19 +1983,19 @@ importSuggestions _dflags imports rdr_name
         ])
   | [(mod,imv)] <- helpful_imports_hiding
   = fsep
-      [ ptext (sLit "Perhaps you want to remove")
+      [ text "Perhaps you want to remove"
       , quotes (ppr occ_name)
-      , ptext (sLit "from the explicit hiding list")
-      , ptext (sLit "in the import of")
+      , text "from the explicit hiding list"
+      , text "in the import of"
       , quotes (ppr mod)
       , parens (ppr (imv_span imv)) <> dot
       ]
   | not (null helpful_imports_hiding)
   = fsep
-      [ ptext (sLit "Perhaps you want to remove")
+      [ text "Perhaps you want to remove"
       , quotes (ppr occ_name)
-      , ptext (sLit "from the hiding clauses")
-      , ptext (sLit "in one of these imports:")
+      , text "from the hiding clauses"
+      , text "in one of these imports:"
       ]
     $$
     nest 2 (vcat
@@ -1980,9 +2099,11 @@ warnUnusedTopBinds gres
                                else                 gres
          warnUnusedGREs gres'
 
-warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> FreeVars -> RnM ()
-warnUnusedLocalBinds = check_unused Opt_WarnUnusedLocalBinds
-warnUnusedMatches    = check_unused Opt_WarnUnusedMatches
+warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns
+  :: [Name] -> FreeVars -> RnM ()
+warnUnusedLocalBinds   = check_unused Opt_WarnUnusedLocalBinds
+warnUnusedMatches      = check_unused Opt_WarnUnusedMatches
+warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns
 
 check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()
 check_unused flag bound_names used_names
@@ -2001,8 +2122,9 @@ warnUnusedLocals names = do
 warnUnusedLocal :: NameEnv (FieldLabelString, Name) -> Name -> RnM ()
 warnUnusedLocal fld_env name
   = when (reportable name) $
-    addUnusedWarning occ (nameSrcSpan name)
-                     (ptext (sLit "Defined but not used"))
+    addUnusedWarning Opt_WarnUnusedLocalBinds
+                     occ (nameSrcSpan name)
+                     (text "Defined but not used")
   where
     occ = case lookupNameEnv fld_env name of
               Just (fl, _) -> mkVarOccFS fl
@@ -2015,11 +2137,11 @@ warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })
   | otherwise = when (reportable name) (mapM_ warn is)
   where
     occ = greOccName gre
-    warn spec = addUnusedWarning occ span msg
+    warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg
         where
            span = importSpecLoc spec
            pp_mod = quotes (ppr (importSpecModule spec))
-           msg = ptext (sLit "Imported from") <+> pp_mod <+> ptext (sLit "but not used")
+           msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used")
 
 -- | Make a map from selector names to field labels and parent tycon
 -- names, to be used when reporting unused record fields.
@@ -2037,9 +2159,9 @@ reportable name
                                   -- from Data.Tuple
   | otherwise = not (startsWithUnderscore (nameOccName name))
 
-addUnusedWarning :: OccName -> SrcSpan -> SDoc -> RnM ()
-addUnusedWarning occ span msg
-  = addWarnAt span $
+addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()
+addUnusedWarning flag occ span msg
+  = addWarnAt (Reason flag) span $
     sep [msg <> colon,
          nest 2 $ pprNonVarNameSpace (occNameSpace occ)
                         <+> quotes (ppr occ)]
@@ -2050,12 +2172,12 @@ addNameClashErrRn rdr_name gres
                -- If there are two or more *local* defns, we'll have reported
   = return ()  -- that already, and we don't want an error cascade
   | otherwise
-  = addErr (vcat [ptext (sLit "Ambiguous occurrence") <+> quotes (ppr rdr_name),
-                  ptext (sLit "It could refer to") <+> vcat (msg1 : msgs)])
+  = addErr (vcat [text "Ambiguous occurrence" <+> quotes (ppr rdr_name),
+                  text "It could refer to" <+> vcat (msg1 : msgs)])
   where
     (np1:nps) = gres
     msg1 = ptext  (sLit "either") <+> mk_ref np1
-    msgs = [ptext (sLit "    or") <+> mk_ref np | np <- nps]
+    msgs = [text "    or" <+> mk_ref np | np <- nps]
     mk_ref gre = sep [nom <> comma, pprNameProvenance gre]
       where nom = case gre_par gre of
                     FldParent { par_lbl = Just lbl } -> text "the field" <+> quotes (ppr lbl)
@@ -2063,57 +2185,57 @@ addNameClashErrRn rdr_name gres
 
 shadowedNameWarn :: OccName -> [SDoc] -> SDoc
 shadowedNameWarn occ shadowed_locs
-  = sep [ptext (sLit "This binding for") <+> quotes (ppr occ)
-            <+> ptext (sLit "shadows the existing binding") <> plural shadowed_locs,
+  = sep [text "This binding for" <+> quotes (ppr occ)
+            <+> text "shadows the existing binding" <> plural shadowed_locs,
          nest 2 (vcat shadowed_locs)]
 
 perhapsForallMsg :: SDoc
 perhapsForallMsg
-  = vcat [ ptext (sLit "Perhaps you intended to use ExplicitForAll or similar flag")
-         , ptext (sLit "to enable explicit-forall syntax: forall <tvs>. <type>")]
+  = vcat [ text "Perhaps you intended to use ExplicitForAll or similar flag"
+         , text "to enable explicit-forall syntax: forall <tvs>. <type>"]
 
 unknownSubordinateErr :: SDoc -> RdrName -> SDoc
 unknownSubordinateErr doc op    -- Doc is "method of class" or
                                 -- "field of constructor"
-  = quotes (ppr op) <+> ptext (sLit "is not a (visible)") <+> doc
+  = quotes (ppr op) <+> text "is not a (visible)" <+> doc
 
 badOrigBinding :: RdrName -> SDoc
 badOrigBinding name
-  = ptext (sLit "Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name)
+  = text "Illegal binding of built-in syntax:" <+> ppr (rdrNameOcc name)
         -- The rdrNameOcc is because we don't want to print Prelude.(,)
 
 dupNamesErr :: Outputable n => (n -> SrcSpan) -> [n] -> RnM ()
 dupNamesErr get_loc names
   = addErrAt big_loc $
-    vcat [ptext (sLit "Conflicting definitions for") <+> quotes (ppr (head names)),
+    vcat [text "Conflicting definitions for" <+> quotes (ppr (head names)),
           locations]
   where
     locs      = map get_loc names
     big_loc   = foldr1 combineSrcSpans locs
-    locations = ptext (sLit "Bound at:") <+> vcat (map ppr (sort locs))
+    locations = text "Bound at:" <+> vcat (map ppr (sort locs))
 
 kindSigErr :: Outputable a => a -> SDoc
 kindSigErr thing
-  = hang (ptext (sLit "Illegal kind signature for") <+> quotes (ppr thing))
-       2 (ptext (sLit "Perhaps you intended to use KindSignatures"))
+  = hang (text "Illegal kind signature for" <+> quotes (ppr thing))
+       2 (text "Perhaps you intended to use KindSignatures")
 
 badQualBndrErr :: RdrName -> SDoc
 badQualBndrErr rdr_name
-  = ptext (sLit "Qualified name in binding position:") <+> ppr rdr_name
+  = text "Qualified name in binding position:" <+> ppr rdr_name
 
 opDeclErr :: RdrName -> SDoc
 opDeclErr n
-  = hang (ptext (sLit "Illegal declaration of a type or class operator") <+> quotes (ppr n))
-       2 (ptext (sLit "Use TypeOperators to declare operators in type and declarations"))
+  = hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n))
+       2 (text "Use TypeOperators to declare operators in type and declarations")
 
 checkTupSize :: Int -> RnM ()
 checkTupSize tup_size
   | tup_size <= mAX_TUPLE_SIZE
   = return ()
   | otherwise
-  = addErr (sep [ptext (sLit "A") <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),
-                 nest 2 (parens (ptext (sLit "max size is") <+> int mAX_TUPLE_SIZE)),
-                 nest 2 (ptext (sLit "Workaround: use nested tuples or define a data type"))])
+  = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),
+                 nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),
+                 nest 2 (text "Workaround: use nested tuples or define a data type")])
 
 {-
 ************************************************************************
@@ -2123,6 +2245,8 @@ checkTupSize tup_size
 ************************************************************************
 -}
 
+-- AZ:TODO: Change these all to be Name instead of RdrName.
+--          Merge TcType.UserTypeContext in to it.
 data HsDocContext
   = TypeSigCtx SDoc
   | PatCtx
@@ -2135,7 +2259,7 @@ data HsDocContext
   | TySynCtx (Located RdrName)
   | TyFamilyCtx (Located RdrName)
   | FamPatCtx (Located RdrName)    -- The patterns of a type/data family instance
-  | ConDeclCtx [Located RdrName]
+  | ConDeclCtx [Located Name]
   | ClassDeclCtx (Located RdrName)
   | ExprWithTySigCtx
   | TypBrCtx
@@ -2150,7 +2274,7 @@ withHsDocContext :: HsDocContext -> SDoc -> SDoc
 withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt
 
 inHsDocContext :: HsDocContext -> SDoc
-inHsDocContext ctxt = ptext (sLit "In") <+> pprHsDocContext ctxt
+inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt
 
 pprHsDocContext :: HsDocContext -> SDoc
 pprHsDocContext (GenericCtx doc)      = doc
@@ -2173,10 +2297,10 @@ pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr
 pprHsDocContext ClassInstanceCtx      = text "TcSplice.reifyInstances"
 
 pprHsDocContext (ForeignDeclCtx name)
-   = ptext (sLit "the foreign declaration for") <+> quotes (ppr name)
+   = text "the foreign declaration for" <+> quotes (ppr name)
 pprHsDocContext (ConDeclCtx [name])
    = text "the definition of data constructor" <+> quotes (ppr name)
 pprHsDocContext (ConDeclCtx names)
    = text "the definition of data constructors" <+> interpp'SP names
 pprHsDocContext (VectDeclCtx tycon)
-   = ptext (sLit "the VECTORISE pragma for type constructor") <+> quotes (ppr tycon)
+   = text "the VECTORISE pragma for type constructor" <+> quotes (ppr tycon)