summaryrefslogtreecommitdiff
path: root/compiler/GHC/Tc
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Tc')
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs56
-rw-r--r--compiler/GHC/Tc/Errors/Types.hs74
-rw-r--r--compiler/GHC/Tc/Gen/Export.hs8
-rw-r--r--compiler/GHC/Tc/Gen/Head.hs5
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs21
5 files changed, 147 insertions, 17 deletions
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index c6da9f1b9b..ffabf0f69c 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -1,10 +1,60 @@
+{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage
-module GHC.Tc.Errors.Ppr where
+module GHC.Tc.Errors.Ppr (
+ ) where
+
+import GHC.Prelude
import GHC.Tc.Errors.Types
import GHC.Types.Error
+import GHC.Driver.Flags
+import GHC.Hs
+import GHC.Utils.Outputable
instance Diagnostic TcRnMessage where
- diagnosticMessage (TcRnUnknownMessage m) = diagnosticMessage m
- diagnosticReason (TcRnUnknownMessage m) = diagnosticReason m
+ diagnosticMessage = \case
+ TcRnUnknownMessage m
+ -> diagnosticMessage m
+ TcRnImplicitLift id_or_name errInfo
+ -> mkDecorated [text "The variable" <+> quotes (ppr id_or_name) <+>
+ text "is implicitly lifted in the TH quotation"
+ , getErrInfo errInfo
+ ]
+ TcRnUnusedPatternBinds bind
+ -> mkDecorated [hang (text "This pattern-binding binds no variables:") 2 (ppr bind)]
+ TcRnDodgyImports name
+ -> mkDecorated [dodgy_msg (text "import") name (dodgy_msg_insert name :: IE GhcPs)]
+ TcRnDodgyExports name
+ -> mkDecorated [dodgy_msg (text "export") name (dodgy_msg_insert name :: IE GhcRn)]
+ TcRnMissingImportList ie
+ -> mkDecorated [ text "The import item" <+> quotes (ppr ie) <+>
+ text "does not have an explicit import list"
+ ]
+ diagnosticReason = \case
+ TcRnUnknownMessage m
+ -> diagnosticReason m
+ TcRnImplicitLift{}
+ -> WarningWithFlag Opt_WarnImplicitLift
+ TcRnUnusedPatternBinds{}
+ -> WarningWithFlag Opt_WarnUnusedPatternBinds
+ TcRnDodgyImports{}
+ -> WarningWithFlag Opt_WarnDodgyImports
+ TcRnDodgyExports{}
+ -> WarningWithFlag Opt_WarnDodgyExports
+ TcRnMissingImportList{}
+ -> WarningWithFlag Opt_WarnMissingImportList
+
+dodgy_msg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc
+dodgy_msg kind tc ie
+ = sep [ text "The" <+> kind <+> text "item"
+ <+> quotes (ppr ie)
+ <+> text "suggests that",
+ quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",
+ text "but it has none" ]
+
+dodgy_msg_insert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)
+dodgy_msg_insert tc = IEThingAll noAnn ii
+ where
+ ii :: LIEWrappedName (IdP (GhcPass p))
+ ii = noLocA (IEName $ noLocA tc)
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 1241735191..6da4cd6613 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -1,12 +1,78 @@
+{-# LANGUAGE GADTs #-}
module GHC.Tc.Errors.Types (
-- * Main types
TcRnMessage(..)
+ , ErrInfo(..)
) where
+import GHC.Hs
import GHC.Types.Error
+import GHC.Types.Name (Name)
+import GHC.Types.Name.Reader
+import GHC.Utils.Outputable
+import Data.Typeable
+
+-- The majority of TcRn messages come with extra context about the error,
+-- and this newtype captures it.
+newtype ErrInfo = ErrInfo { getErrInfo :: SDoc }
-- | An error which might arise during typechecking/renaming.
-data TcRnMessage
- = TcRnUnknownMessage !DiagnosticMessage
- -- ^ Simply rewraps a generic 'DiagnosticMessage'. More
- -- constructors will be added in the future (#18516).
+data TcRnMessage where
+ {-| Simply wraps a generic 'Diagnostic' message @a@. It can be used by plugins
+ to provide custom diagnostic messages originated during typechecking/renaming.
+ -}
+ TcRnUnknownMessage :: (Diagnostic a, Typeable a) => a -> TcRnMessage
+ {-| TcRnImplicitLift is a warning (controlled with -Wimplicit-lift) that occurs when
+ a Template Haskell quote implicitly uses 'lift'.
+
+ Example:
+ warning1 :: Lift t => t -> Q Exp
+ warning1 x = [| x |]
+
+ Test cases: th/T17804
+ -}
+ TcRnImplicitLift :: Outputable var => var -> !ErrInfo -> TcRnMessage
+ {-| TcRnUnusedPatternBinds is a warning (controlled with -Wunused-pattern-binds)
+ that occurs if a pattern binding binds no variables at all, unless it is a
+ lone wild-card pattern, or a banged pattern.
+
+ Example:
+ Just _ = rhs3 -- Warning: unused pattern binding
+ (_, _) = rhs4 -- Warning: unused pattern binding
+ _ = rhs3 -- No warning: lone wild-card pattern
+ !() = rhs4 -- No warning: banged pattern; behaves like seq
+
+ Test cases: rename/{T13646,T17c,T17e,T7085}
+ -}
+ TcRnUnusedPatternBinds :: HsBind GhcRn -> TcRnMessage
+ {-| TcRnDodgyImports is a warning (controlled with -Wdodgy-imports) that occurs when
+ a datatype 'T' is imported with all constructors, i.e. 'T(..)', but has been exported
+ abstractly, i.e. 'T'.
+
+ Test cases: rename/should_compile/T7167
+ -}
+ TcRnDodgyImports :: RdrName -> TcRnMessage
+ {-| TcRnDodgyExports is a warning (controlled by -Wdodgy-exports) that occurs when a datatype
+ 'T' is exported with all constructors, i.e. 'T(..)', but is it just a type synonym or a
+ type/data family.
+
+ Example:
+ module Foo (
+ T(..) -- Warning: T is a type synonym
+ , A(..) -- Warning: A is a type family
+ , C(..) -- Warning: C is a data family
+ ) where
+
+ type T = Int
+ type family A :: * -> *
+ data family C :: * -> *
+
+ Test cases: warnings/should_compile/DodgyExports01
+ -}
+ TcRnDodgyExports :: Name -> TcRnMessage
+ {-| TcRnMissingImportList is a warning (controlled by -Wmissing-import-lists) that occurs when
+ an import declaration does not explicitly list all the names brought into scope.
+
+ Test cases: rename/should_compile/T4489
+ -}
+ TcRnMissingImportList :: IE GhcPs -> TcRnMessage
diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs
index a874e04fd7..18924c39d5 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ b/compiler/GHC/Tc/Gen/Export.hs
@@ -10,6 +10,7 @@ import GHC.Prelude
import GHC.Hs
import GHC.Types.FieldLabel
import GHC.Builtin.Names
+import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcType
@@ -394,8 +395,7 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
addUsedKids (ieWrappedName rdr) gres
when (null gres) $
if isTyConName name
- then addDiagnostic (WarningWithFlag Opt_WarnDodgyExports)
- (dodgyExportWarn name)
+ then addTcRnDiagnostic (TcRnDodgyExports name)
else -- This occurs when you export T(..), but
-- only import T abstractly, or T is a synonym.
addErr (exportItemErr ie)
@@ -759,10 +759,6 @@ missingModuleExportWarn mod
text "is missing an export list"]
-dodgyExportWarn :: Name -> SDoc
-dodgyExportWarn item
- = dodgyMsg (text "export") item (dodgyMsgInsert item :: IE GhcRn)
-
exportErrCtxt :: Outputable o => String -> o -> SDoc
exportErrCtxt herald exp =
text "In the" <+> text (herald ++ ":") <+> ppr exp
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 1f0fce7f4e..b800583416 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -45,6 +45,7 @@ import GHC.Core.FamInstEnv ( FamInstEnvs )
import GHC.Core.UsageEnv ( unitUE )
import GHC.Rename.Env ( addUsedGRE )
import GHC.Rename.Utils ( addNameClashErrRn, unknownSubordinateErr )
+import GHC.Tc.Errors.Types
import GHC.Tc.Solver ( InferMode(..), simplifyInfer )
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Zonk ( hsLitType )
@@ -1136,9 +1137,7 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q))
[getRuntimeRep id_ty, id_ty]
-- Warning for implicit lift (#17804)
- ; addDiagnosticTc (WarningWithFlag Opt_WarnImplicitLift)
- (text "The variable" <+> quotes (ppr id) <+>
- text "is implicitly lifted in the TH quotation")
+ ; addDetailedDiagnostic (TcRnImplicitLift id)
-- Update the pending splices
; ps <- readMutVar ps_var
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index f1a5425b6f..730e666a2a 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -92,7 +92,7 @@ module GHC.Tc.Utils.Monad(
failWithTc, failWithTcM,
checkTc, checkTcM,
failIfTc, failIfTcM,
- warnIfFlag, warnIf, diagnosticTc, diagnosticTcM,
+ warnIfFlag, warnIf, diagnosticTc, diagnosticTcM, addDetailedDiagnostic, addTcRnDiagnostic,
addDiagnosticTc, addDiagnosticTcM, addDiagnostic, addDiagnosticAt, add_diagnostic,
mkErrInfo,
@@ -1548,6 +1548,25 @@ addDiagnosticTcM reason (env0, msg)
addDiagnostic :: DiagnosticReason -> SDoc -> TcRn ()
addDiagnostic reason msg = add_diagnostic reason msg Outputable.empty
+-- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage'
+-- given some additional context about the diagnostic.
+addDetailedDiagnostic :: (ErrInfo -> TcRnMessage) -> TcM ()
+addDetailedDiagnostic mkMsg = do
+ loc <- getSrcSpanM
+ printer <- getPrintUnqualified
+ dflags <- getDynFlags
+ env0 <- tcInitTidyEnv
+ ctxt <- getErrCtxt
+ err_info <- mkErrInfo env0 ctxt
+ reportDiagnostic (mkMsgEnvelope dflags loc printer (mkMsg (ErrInfo err_info)))
+
+addTcRnDiagnostic :: TcRnMessage -> TcM ()
+addTcRnDiagnostic msg = do
+ loc <- getSrcSpanM
+ printer <- getPrintUnqualified
+ dflags <- getDynFlags
+ reportDiagnostic (mkMsgEnvelope dflags loc printer msg)
+
-- | Display a diagnostic for a given source location.
addDiagnosticAt :: DiagnosticReason -> SrcSpan -> SDoc -> TcRn ()
addDiagnosticAt reason loc msg = add_diagnostic_at reason loc msg Outputable.empty
View Lorry Controller Status