{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module GHC.HsToCore.Errors.Ppr where
import GHC.Core.Predicate (isEvVar)
import GHC.Core.Type
import GHC.Driver.Flags
import GHC.Hs
import GHC.HsToCore.Errors.Types
import GHC.Prelude
import GHC.Types.Basic (pprRuleName)
import GHC.Types.Error
import GHC.Types.Error.Codes ( constructorCode )
import GHC.Types.Id (idType)
import GHC.Types.SrcLoc
import GHC.Utils.Misc
import GHC.Utils.Outputable
import qualified GHC.LanguageExtensions as LangExt
import GHC.HsToCore.Pmc.Ppr
instance Diagnostic DsMessage where
type DiagnosticOpts DsMessage = NoDiagnosticOpts
defaultDiagnosticOpts :: DiagnosticOpts DsMessage
defaultDiagnosticOpts = NoDiagnosticOpts
NoDiagnosticOpts
diagnosticMessage :: DiagnosticOpts DsMessage -> DsMessage -> DecoratedSDoc
diagnosticMessage DiagnosticOpts DsMessage
_ = \case
DsUnknownMessage (UnknownDiagnostic @e a
m)
-> forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage (forall a. Diagnostic a => DiagnosticOpts a
defaultDiagnosticOpts @e) a
m
DsMessage
DsEmptyEnumeration
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => String -> doc
text String
"Enumeration is empty"
DsIdentitiesFound Id
conv_fn Type
type_of_conv
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$
forall doc. IsDoc doc => [doc] -> doc
vcat [ forall doc. IsLine doc => String -> doc
text String
"Call of" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Id
conv_fn forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Type
type_of_conv
, Int -> SDoc -> SDoc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => String -> doc
text String
"can probably be omitted"
]
DsOverflowedLiterals Integer
i Name
tc Maybe (MinBound, MaxBound)
bounds NegLiteralExtEnabled
_possiblyUsingNegativeLiterals
-> let msg :: SDoc
msg = case Maybe (MinBound, MaxBound)
bounds of
Maybe (MinBound, MaxBound)
Nothing
-> forall doc. IsDoc doc => [doc] -> doc
vcat [ forall doc. IsLine doc => String -> doc
text String
"Literal" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => Integer -> doc
integer Integer
i
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"is negative but" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Name
tc
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"only supports positive numbers"
]
Just (MinBound Integer
minB, MaxBound Integer
maxB)
-> forall doc. IsDoc doc => [doc] -> doc
vcat [ forall doc. IsLine doc => String -> doc
text String
"Literal" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => Integer -> doc
integer Integer
i
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"is out of the" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Name
tc forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"range"
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => Integer -> doc
integer Integer
minB forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text String
".." forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => Integer -> doc
integer Integer
maxB
]
in SDoc -> DecoratedSDoc
mkSimpleDecorated SDoc
msg
DsRedundantBangPatterns HsMatchContext GhcRn
ctx SDoc
q
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$ HsMatchContext GhcRn -> SDoc -> String -> SDoc
pprEqn HsMatchContext GhcRn
ctx SDoc
q String
"has redundant bang"
DsOverlappingPatterns HsMatchContext GhcRn
ctx SDoc
q
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$ HsMatchContext GhcRn -> SDoc -> String -> SDoc
pprEqn HsMatchContext GhcRn
ctx SDoc
q String
"is redundant"
DsInaccessibleRhs HsMatchContext GhcRn
ctx SDoc
q
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$ HsMatchContext GhcRn -> SDoc -> String -> SDoc
pprEqn HsMatchContext GhcRn
ctx SDoc
q String
"has inaccessible right hand side"
DsMaxPmCheckModelsReached Int
limit
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$ forall doc. IsDoc doc => [doc] -> doc
vcat
[ SDoc -> Int -> SDoc -> SDoc
hang
(forall doc. IsLine doc => String -> doc
text String
"Pattern match checker ran into -fmax-pmcheck-models="
forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => Int -> doc
int Int
limit
forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text String
" limit, so")
Int
2
( SDoc
bullet forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"Redundant clauses might not be reported at all"
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
bullet forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"Redundant clauses might be reported as inaccessible"
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
bullet forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"Patterns reported as unmatched might actually be matched")
]
DsNonExhaustivePatterns HsMatchContext GhcRn
kind ExhaustivityCheckType
_flag Int
maxPatterns [Id]
vars [Nabla]
nablas
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$
Bool
-> HsMatchContext GhcRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext Bool
False HsMatchContext GhcRn
kind (forall doc. IsLine doc => String -> doc
text String
"are non-exhaustive") forall a b. (a -> b) -> a -> b
$ \SDoc -> SDoc
_ ->
case [Id]
vars of
[] -> forall doc. IsLine doc => String -> doc
text String
"Guards do not cover entire pattern space"
[Id]
_ -> let us :: [SDoc]
us = forall a b. (a -> b) -> [a] -> [b]
map (\Nabla
nabla -> Nabla -> [Id] -> SDoc
pprUncovered Nabla
nabla [Id]
vars) [Nabla]
nablas
pp_tys :: SDoc
pp_tys = forall a. Outputable a => [a] -> SDoc
pprQuotedList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
vars
in SDoc -> Int -> SDoc -> SDoc
hang
(forall doc. IsLine doc => String -> doc
text String
"Patterns of type" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pp_tys forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"not matched:")
Int
4
(forall doc. IsDoc doc => [doc] -> doc
vcat (forall a. Int -> [a] -> [a]
take Int
maxPatterns [SDoc]
us) forall doc. IsDoc doc => doc -> doc -> doc
$$ forall a. Int -> [a] -> SDoc
dots Int
maxPatterns [SDoc]
us)
DsTopLevelBindsNotAllowed BindsType
bindsType HsBindLR GhcTc GhcTc
bind
-> let desc :: String
desc = case BindsType
bindsType of
BindsType
UnliftedTypeBinds -> String
"bindings for unlifted types"
BindsType
StrictBinds -> String
"strict bindings"
in SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"Top-level" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
desc forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"aren't allowed:") Int
2 (forall a. Outputable a => a -> SDoc
ppr HsBindLR GhcTc GhcTc
bind)
DsUselessSpecialiseForClassMethodSelector Id
poly_id
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$
forall doc. IsLine doc => String -> doc
text String
"Ignoring useless SPECIALISE pragma for class selector:" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Id
poly_id)
DsUselessSpecialiseForNoInlineFunction Id
poly_id
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$
forall doc. IsLine doc => String -> doc
text String
"Ignoring useless SPECIALISE pragma for NOINLINE function:" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Id
poly_id)
DsMessage
DsMultiplicityCoercionsNotSupported
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => String -> doc
text String
"GHC bug #19517: GHC currently does not support programs using GADTs or type families to witness equality of multiplicities"
DsOrphanRule CoreRule
rule
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => String -> doc
text String
"Orphan rule:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr CoreRule
rule
DsRuleLhsTooComplicated CoreExpr
orig_lhs CoreExpr
lhs2
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"RULE left-hand side too complicated to desugar")
Int
2 (forall doc. IsDoc doc => [doc] -> doc
vcat [ forall doc. IsLine doc => String -> doc
text String
"Optimised lhs:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr CoreExpr
lhs2
, forall doc. IsLine doc => String -> doc
text String
"Orig lhs:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr CoreExpr
orig_lhs])
DsRuleIgnoredDueToConstructor DataCon
con
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$ forall doc. IsDoc doc => [doc] -> doc
vcat
[ forall doc. IsLine doc => String -> doc
text String
"A constructor," forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr DataCon
con forall doc. IsLine doc => doc -> doc -> doc
<>
forall doc. IsLine doc => String -> doc
text String
", appears as outermost match in RULE lhs."
, forall doc. IsLine doc => String -> doc
text String
"This rule will be ignored." ]
DsRuleBindersNotBound [Id]
unbound [Id]
orig_bndrs CoreExpr
orig_lhs CoreExpr
lhs2
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$ forall doc. IsDoc doc => [doc] -> doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map Id -> SDoc
pp_dead [Id]
unbound)
where
pp_dead :: Id -> SDoc
pp_dead Id
bndr =
SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => [doc] -> doc
sep [ forall doc. IsLine doc => String -> doc
text String
"Forall'd" forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
pp_bndr Id
bndr
, forall doc. IsLine doc => String -> doc
text String
"is not bound in RULE lhs"])
Int
2 (forall doc. IsDoc doc => [doc] -> doc
vcat [ forall doc. IsLine doc => String -> doc
text String
"Orig bndrs:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [Id]
orig_bndrs
, forall doc. IsLine doc => String -> doc
text String
"Orig lhs:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr CoreExpr
orig_lhs
, forall doc. IsLine doc => String -> doc
text String
"optimised lhs:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr CoreExpr
lhs2 ])
pp_bndr :: Id -> SDoc
pp_bndr Id
b
| Id -> Bool
isTyVar Id
b = forall doc. IsLine doc => String -> doc
text String
"type variable" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Id
b)
| Id -> Bool
isEvVar Id
b = forall doc. IsLine doc => String -> doc
text String
"constraint" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr (Id -> Type
varType Id
b))
| Bool
otherwise = forall doc. IsLine doc => String -> doc
text String
"variable" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Id
b)
DsLazyPatCantBindVarsOfUnliftedType [Id]
unlifted_bndrs
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"A lazy (~) pattern cannot bind variables of unlifted type." forall doc. IsDoc doc => doc -> doc -> doc
$$
forall doc. IsLine doc => String -> doc
text String
"Unlifted variables:")
Int
2 (forall doc. IsDoc doc => [doc] -> doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (\Id
id -> forall a. Outputable a => a -> SDoc
ppr Id
id forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
id)) [Id]
unlifted_bndrs))
DsNotYetHandledByTH ThRejectionReason
reason
-> case ThRejectionReason
reason of
ThAmbiguousRecordUpdates HsRecUpdField GhcRn
fld
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"Ambiguous record updates" (forall a. Outputable a => a -> SDoc
ppr HsRecUpdField GhcRn
fld)
ThAbstractClosedTypeFamily LFamilyDecl GhcRn
decl
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"abstract closed type family" (forall a. Outputable a => a -> SDoc
ppr LFamilyDecl GhcRn
decl)
ThForeignLabel CLabelString
cls
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"Foreign label" (forall doc. IsLine doc => doc -> doc
doubleQuotes (forall a. Outputable a => a -> SDoc
ppr CLabelString
cls))
ThForeignExport LForeignDecl GhcRn
decl
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"Foreign export" (forall a. Outputable a => a -> SDoc
ppr LForeignDecl GhcRn
decl)
ThRejectionReason
ThMinimalPragmas
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"MINIMAL pragmas" forall doc. IsOutput doc => doc
empty
ThRejectionReason
ThSCCPragmas
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"SCC pragmas" forall doc. IsOutput doc => doc
empty
ThRejectionReason
ThNoUserInline
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"NOUSERINLINE" forall doc. IsOutput doc => doc
empty
ThExoticFormOfType HsType GhcRn
ty
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"Exotic form of type" (forall a. Outputable a => a -> SDoc
ppr HsType GhcRn
ty)
ThAmbiguousRecordSelectors HsExpr GhcRn
e
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"Ambiguous record selectors" (forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e)
ThMonadComprehensionSyntax HsExpr GhcRn
e
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"monad comprehension and [: :]" (forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e)
ThCostCentres HsExpr GhcRn
e
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"Cost centres" (forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e)
ThExpressionForm HsExpr GhcRn
e
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"Expression form" (forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e)
ThExoticStatement [Stmt GhcRn (LHsExpr GhcRn)]
other
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"Exotic statement" (forall a. Outputable a => a -> SDoc
ppr [Stmt GhcRn (LHsExpr GhcRn)]
other)
ThExoticLiteral HsLit GhcRn
lit
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"Exotic literal" (forall a. Outputable a => a -> SDoc
ppr HsLit GhcRn
lit)
ThExoticPattern Pat GhcRn
pat
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"Exotic pattern" (forall a. Outputable a => a -> SDoc
ppr Pat GhcRn
pat)
ThGuardedLambdas Match GhcRn (LHsExpr GhcRn)
m
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"Guarded lambdas" (forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
Match (GhcPass idR) body -> SDoc
pprMatch Match GhcRn (LHsExpr GhcRn)
m)
ThNegativeOverloadedPatterns Pat GhcRn
pat
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"Negative overloaded patterns" (forall a. Outputable a => a -> SDoc
ppr Pat GhcRn
pat)
ThRejectionReason
ThHaddockDocumentation
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"Haddock documentation" forall doc. IsOutput doc => doc
empty
ThWarningAndDeprecationPragmas [LIdP GhcRn]
decl
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"WARNING and DEPRECATION pragmas" forall a b. (a -> b) -> a -> b
$
forall doc. IsLine doc => String -> doc
text String
"Pragma for declaration of" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr [LIdP GhcRn]
decl
ThRejectionReason
ThSplicesWithinDeclBrackets
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"Splices within declaration brackets" forall doc. IsOutput doc => doc
empty
ThRejectionReason
ThNonLinearDataCon
-> String -> SDoc -> DecoratedSDoc
mkMsg String
"Non-linear fields in data constructors" forall doc. IsOutput doc => doc
empty
where
mkMsg :: String -> SDoc -> DecoratedSDoc
mkMsg String
what SDoc
doc =
SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
what forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"not (yet) handled by Template Haskell") Int
2 SDoc
doc
DsAggregatedViewExpressions [[LHsExpr GhcTc]]
views
-> SDoc -> DecoratedSDoc
mkSimpleDecorated (forall doc. IsDoc doc => [doc] -> doc
vcat [SDoc]
msgs)
where
msgs :: [SDoc]
msgs = forall a b. (a -> b) -> [a] -> [b]
map (\[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
g -> forall doc. IsLine doc => String -> doc
text String
"Putting these view expressions into the same case:" forall doc. IsLine doc => doc -> doc -> doc
<+> (forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
g)) [[LHsExpr GhcTc]]
views
DsUnbangedStrictPatterns HsBindLR GhcTc GhcTc
bind
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"Pattern bindings containing unlifted types should use" forall doc. IsDoc doc => doc -> doc -> doc
$$
forall doc. IsLine doc => String -> doc
text String
"an outermost bang pattern:")
Int
2 (forall a. Outputable a => a -> SDoc
ppr HsBindLR GhcTc GhcTc
bind)
DsCannotMixPolyAndUnliftedBindings HsBindLR GhcTc GhcTc
bind
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"You can't mix polymorphic and unlifted bindings:")
Int
2 (forall a. Outputable a => a -> SDoc
ppr HsBindLR GhcTc GhcTc
bind)
DsWrongDoBind LHsExpr GhcTc
_rhs Type
elt_ty
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$ Type -> SDoc
badMonadBind Type
elt_ty
DsUnusedDoBind LHsExpr GhcTc
_rhs Type
elt_ty
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$ Type -> SDoc
badMonadBind Type
elt_ty
DsRecBindsNotAllowedForUnliftedTys [LHsBindLR GhcTc GhcTc]
binds
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"Recursive bindings for unlifted types aren't allowed:")
Int
2 (forall doc. IsDoc doc => [doc] -> doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [LHsBindLR GhcTc GhcTc]
binds))
DsRuleMightInlineFirst CLabelString
rule_name Id
lhs_id Activation
_
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"Rule" forall doc. IsLine doc => doc -> doc -> doc
<+> CLabelString -> SDoc
pprRuleName CLabelString
rule_name
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"may never fire")
Int
2 (forall doc. IsLine doc => String -> doc
text String
"because" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Id
lhs_id)
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"might inline first")
]
DsAnotherRuleMightFireFirst CLabelString
rule_name CLabelString
bad_rule Id
lhs_id
-> SDoc -> DecoratedSDoc
mkSimpleDecorated forall a b. (a -> b) -> a -> b
$
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"Rule" forall doc. IsLine doc => doc -> doc -> doc
<+> CLabelString -> SDoc
pprRuleName CLabelString
rule_name
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"may never fire")
Int
2 (forall doc. IsLine doc => String -> doc
text String
"because rule" forall doc. IsLine doc => doc -> doc -> doc
<+> CLabelString -> SDoc
pprRuleName CLabelString
bad_rule
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"for"forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Id
lhs_id)
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"might fire first")
]
diagnosticReason :: DsMessage -> DiagnosticReason
diagnosticReason = \case
DsUnknownMessage UnknownDiagnostic
m -> forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason UnknownDiagnostic
m
DsMessage
DsEmptyEnumeration -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnEmptyEnumerations
DsIdentitiesFound{} -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnIdentities
DsOverflowedLiterals{} -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnOverflowedLiterals
DsRedundantBangPatterns{} -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnRedundantBangPatterns
DsOverlappingPatterns{} -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnOverlappingPatterns
DsInaccessibleRhs{} -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnOverlappingPatterns
DsMaxPmCheckModelsReached{} -> DiagnosticReason
WarningWithoutFlag
DsNonExhaustivePatterns HsMatchContext GhcRn
_ (ExhaustivityCheckType Maybe WarningFlag
mb_flag) Int
_ [Id]
_ [Nabla]
_
-> forall b a. b -> (a -> b) -> Maybe a -> b
maybe DiagnosticReason
WarningWithoutFlag WarningFlag -> DiagnosticReason
WarningWithFlag Maybe WarningFlag
mb_flag
DsTopLevelBindsNotAllowed{} -> DiagnosticReason
ErrorWithoutFlag
DsUselessSpecialiseForClassMethodSelector{} -> DiagnosticReason
WarningWithoutFlag
DsUselessSpecialiseForNoInlineFunction{} -> DiagnosticReason
WarningWithoutFlag
DsMultiplicityCoercionsNotSupported{} -> DiagnosticReason
ErrorWithoutFlag
DsOrphanRule{} -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnOrphans
DsRuleLhsTooComplicated{} -> DiagnosticReason
WarningWithoutFlag
DsRuleIgnoredDueToConstructor{} -> DiagnosticReason
WarningWithoutFlag
DsRuleBindersNotBound{} -> DiagnosticReason
WarningWithoutFlag
DsLazyPatCantBindVarsOfUnliftedType{} -> DiagnosticReason
ErrorWithoutFlag
DsNotYetHandledByTH{} -> DiagnosticReason
ErrorWithoutFlag
DsAggregatedViewExpressions{} -> DiagnosticReason
WarningWithoutFlag
DsUnbangedStrictPatterns{} -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnUnbangedStrictPatterns
DsCannotMixPolyAndUnliftedBindings{} -> DiagnosticReason
ErrorWithoutFlag
DsWrongDoBind{} -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnWrongDoBind
DsUnusedDoBind{} -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnUnusedDoBind
DsRecBindsNotAllowedForUnliftedTys{} -> DiagnosticReason
ErrorWithoutFlag
DsRuleMightInlineFirst{} -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnInlineRuleShadowing
DsAnotherRuleMightFireFirst{} -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnInlineRuleShadowing
diagnosticHints :: DsMessage -> [GhcHint]
diagnosticHints = \case
DsUnknownMessage UnknownDiagnostic
m -> forall a. Diagnostic a => a -> [GhcHint]
diagnosticHints UnknownDiagnostic
m
DsMessage
DsEmptyEnumeration -> [GhcHint]
noHints
DsIdentitiesFound{} -> [GhcHint]
noHints
DsOverflowedLiterals Integer
i Name
_tc Maybe (MinBound, MaxBound)
bounds NegLiteralExtEnabled
usingNegLiterals
-> case (Maybe (MinBound, MaxBound)
bounds, NegLiteralExtEnabled
usingNegLiterals) of
(Just (MinBound Integer
minB, MaxBound Integer
_), NegLiteralExtEnabled
NotUsingNegLiterals)
| Integer
minB forall a. Eq a => a -> a -> Bool
== -Integer
i
, Integer
i forall a. Ord a => a -> a -> Bool
> Integer
0
-> [ SDoc -> Extension -> GhcHint
suggestExtensionWithInfo (forall doc. IsLine doc => String -> doc
text String
"If you are trying to write a large negative literal")
Extension
LangExt.NegativeLiterals ]
(Maybe (MinBound, MaxBound), NegLiteralExtEnabled)
_ -> [GhcHint]
noHints
DsRedundantBangPatterns{} -> [GhcHint]
noHints
DsOverlappingPatterns{} -> [GhcHint]
noHints
DsInaccessibleRhs{} -> [GhcHint]
noHints
DsMaxPmCheckModelsReached{} -> [GhcHint
SuggestIncreaseMaxPmCheckModels]
DsNonExhaustivePatterns{} -> [GhcHint]
noHints
DsTopLevelBindsNotAllowed{} -> [GhcHint]
noHints
DsUselessSpecialiseForClassMethodSelector{} -> [GhcHint]
noHints
DsUselessSpecialiseForNoInlineFunction{} -> [GhcHint]
noHints
DsMessage
DsMultiplicityCoercionsNotSupported -> [GhcHint]
noHints
DsOrphanRule{} -> [GhcHint]
noHints
DsRuleLhsTooComplicated{} -> [GhcHint]
noHints
DsRuleIgnoredDueToConstructor{} -> [GhcHint]
noHints
DsRuleBindersNotBound{} -> [GhcHint]
noHints
DsLazyPatCantBindVarsOfUnliftedType{} -> [GhcHint]
noHints
DsNotYetHandledByTH{} -> [GhcHint]
noHints
DsAggregatedViewExpressions{} -> [GhcHint]
noHints
DsUnbangedStrictPatterns{} -> [GhcHint]
noHints
DsCannotMixPolyAndUnliftedBindings{} -> [AvailableBindings -> GhcHint
SuggestAddTypeSignatures AvailableBindings
UnnamedBinding]
DsWrongDoBind LHsExpr GhcTc
rhs Type
_ -> [LHsExpr GhcTc -> GhcHint
SuggestBindToWildcard LHsExpr GhcTc
rhs]
DsUnusedDoBind LHsExpr GhcTc
rhs Type
_ -> [LHsExpr GhcTc -> GhcHint
SuggestBindToWildcard LHsExpr GhcTc
rhs]
DsRecBindsNotAllowedForUnliftedTys{} -> [GhcHint]
noHints
DsRuleMightInlineFirst CLabelString
_ Id
lhs_id Activation
rule_act -> [Id -> Activation -> GhcHint
SuggestAddInlineOrNoInlinePragma Id
lhs_id Activation
rule_act]
DsAnotherRuleMightFireFirst CLabelString
_ CLabelString
bad_rule Id
_ -> [CLabelString -> GhcHint
SuggestAddPhaseToCompetingRule CLabelString
bad_rule]
diagnosticCode :: DsMessage -> Maybe DiagnosticCode
diagnosticCode = forall diag.
(Generic diag, GDiagnosticCode (Rep diag)) =>
diag -> Maybe DiagnosticCode
constructorCode
badMonadBind :: Type -> SDoc
badMonadBind :: Type -> SDoc
badMonadBind Type
elt_ty
= SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => String -> doc
text String
"A do-notation statement discarded a result of type")
Int
2 (SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Type
elt_ty))
pprEqn :: HsMatchContext GhcRn -> SDoc -> String -> SDoc
pprEqn :: HsMatchContext GhcRn -> SDoc -> String -> SDoc
pprEqn HsMatchContext GhcRn
ctx SDoc
q String
txt = Bool
-> HsMatchContext GhcRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext Bool
True HsMatchContext GhcRn
ctx (forall doc. IsLine doc => String -> doc
text String
txt) forall a b. (a -> b) -> a -> b
$ \SDoc -> SDoc
f ->
SDoc -> SDoc
f (SDoc
q forall doc. IsLine doc => doc -> doc -> doc
<+> forall p. HsMatchContext p -> SDoc
matchSeparator HsMatchContext GhcRn
ctx forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => String -> doc
text String
"...")
pprContext :: Bool -> HsMatchContext GhcRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext :: Bool
-> HsMatchContext GhcRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext Bool
singular HsMatchContext GhcRn
kind SDoc
msg (SDoc -> SDoc) -> SDoc
rest_of_msg_fun
= forall doc. IsDoc doc => [doc] -> doc
vcat [forall doc. IsLine doc => String -> doc
text String
txt forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
msg,
forall doc. IsLine doc => [doc] -> doc
sep [ forall doc. IsLine doc => String -> doc
text String
"In" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
ppr_match forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => Char -> doc
char Char
':'
, Int -> SDoc -> SDoc
nest Int
4 ((SDoc -> SDoc) -> SDoc
rest_of_msg_fun SDoc -> SDoc
pref)]]
where
txt :: String
txt | Bool
singular = String
"Pattern match"
| Bool
otherwise = String
"Pattern match(es)"
(SDoc
ppr_match, SDoc -> SDoc
pref)
= case HsMatchContext GhcRn
kind of
FunRhs { mc_fun :: forall p. HsMatchContext p -> LIdP (NoGhcTc p)
mc_fun = L SrcSpanAnnN
_ Name
fun }
-> (forall p.
(Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) =>
HsMatchContext p -> SDoc
pprMatchContext HsMatchContext GhcRn
kind, \ SDoc
pp -> forall a. Outputable a => a -> SDoc
ppr Name
fun forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pp)
HsMatchContext GhcRn
_ -> (forall p.
(Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) =>
HsMatchContext p -> SDoc
pprMatchContext HsMatchContext GhcRn
kind, \ SDoc
pp -> SDoc
pp)
dots :: Int -> [a] -> SDoc
dots :: forall a. Int -> [a] -> SDoc
dots Int
maxPatterns [a]
qs
| [a]
qs forall a. [a] -> Int -> Bool
`lengthExceeds` Int
maxPatterns = forall doc. IsLine doc => String -> doc
text String
"..."
| Bool
otherwise = forall doc. IsOutput doc => doc
empty