{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage

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 -- See #11245
                  [] -> 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 -- Note [Suggest NegativeLiterals]
            , 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

{-
Note [Suggest NegativeLiterals]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If you write
  x :: Int8
  x = -128
it'll parse as (negate 128), and overflow.  In this case, suggest NegativeLiterals.
We get an erroneous suggestion for
  x = 128
but perhaps that does not matter too much.
-}

--
-- Helper functions
--

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))

-- Print a single clause (for redundant/with-inaccessible-rhs)
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