{-# LANGUAGE LambdaCase #-}
{-# 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.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
  diagnosticMessage :: DsMessage -> DecoratedSDoc
diagnosticMessage = \case
    DsUnknownMessage a
m
      -> a -> DecoratedSDoc
forall a. Diagnostic a => a -> DecoratedSDoc
diagnosticMessage a
m
    DsMessage
DsEmptyEnumeration
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Enumeration is empty"
    DsIdentitiesFound Id
conv_fn Type
type_of_conv
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Call of" SDoc -> SDoc -> SDoc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
conv_fn SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
type_of_conv
                , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
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
                 -> [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Literal" SDoc -> SDoc -> SDoc
<+> Integer -> SDoc
integer Integer
i
                       SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is negative but" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc
                       SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"only supports positive numbers"
                         ]
               Just (MinBound Integer
minB, MaxBound Integer
maxB)
                 -> [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Literal" SDoc -> SDoc -> SDoc
<+> Integer -> SDoc
integer Integer
i
                                 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is out of the" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"range"
                                 SDoc -> SDoc -> SDoc
<+> Integer -> SDoc
integer Integer
minB SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
".." SDoc -> SDoc -> SDoc
<> Integer -> SDoc
integer Integer
maxB
                         ]
         in SDoc -> DecoratedSDoc
mkSimpleDecorated SDoc
msg
    DsRedundantBangPatterns HsMatchContext GhcRn
ctx SDoc
q
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
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 (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
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 (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
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 (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
           [ SDoc -> Int -> SDoc -> SDoc
hang
               (String -> SDoc
text String
"Pattern match checker ran into -fmax-pmcheck-models="
                 SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
limit
                 SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" limit, so")
               Int
2
               (  SDoc
bullet SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"Redundant clauses might not be reported at all"
               SDoc -> SDoc -> SDoc
$$ SDoc
bullet SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"Redundant clauses might be reported as inaccessible"
               SDoc -> SDoc -> SDoc
$$ SDoc
bullet SDoc -> SDoc -> SDoc
<+> String -> SDoc
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 (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           Bool
-> HsMatchContext GhcRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext Bool
False HsMatchContext GhcRn
kind (String -> SDoc
text String
"are non-exhaustive") (((SDoc -> SDoc) -> SDoc) -> SDoc)
-> ((SDoc -> SDoc) -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \SDoc -> SDoc
_ ->
             case [Id]
vars of -- See #11245
                  [] -> String -> SDoc
text String
"Guards do not cover entire pattern space"
                  [Id]
_  -> let us :: [SDoc]
us = (Nabla -> SDoc) -> [Nabla] -> [SDoc]
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 = [Type] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList ([Type] -> SDoc) -> [Type] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Id -> Type) -> [Id] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
vars
                        in  SDoc -> Int -> SDoc -> SDoc
hang
                              (String -> SDoc
text String
"Patterns of type" SDoc -> SDoc -> SDoc
<+> SDoc
pp_tys SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"not matched:")
                              Int
4
                              ([SDoc] -> SDoc
vcat (Int -> [SDoc] -> [SDoc]
forall a. Int -> [a] -> [a]
take Int
maxPatterns [SDoc]
us) SDoc -> SDoc -> SDoc
$$ Int -> [SDoc] -> SDoc
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 (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
              SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Top-level" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
desc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"aren't allowed:") Int
2 (HsBindLR GhcTc GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsBindLR GhcTc GhcTc
bind)
    DsUselessSpecialiseForClassMethodSelector Id
poly_id
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Ignoring useless SPECIALISE pragma for NOINLINE function:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
poly_id)
    DsUselessSpecialiseForNoInlineFunction Id
poly_id
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
          String -> SDoc
text String
"Ignoring useless SPECIALISE pragma for NOINLINE function:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
poly_id)
    DsMessage
DsMultiplicityCoercionsNotSupported
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
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 (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Orphan rule:" SDoc -> SDoc -> SDoc
<+> CoreRule -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreRule
rule
    DsRuleLhsTooComplicated CoreExpr
orig_lhs CoreExpr
lhs2
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"RULE left-hand side too complicated to desugar")
                      Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Optimised lhs:" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
lhs2
                              , String -> SDoc
text String
"Orig lhs:" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
orig_lhs])
    DsRuleIgnoredDueToConstructor DataCon
con
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
           [ String -> SDoc
text String
"A constructor," SDoc -> SDoc -> SDoc
<+> DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con SDoc -> SDoc -> SDoc
<>
               String -> SDoc
text String
", appears as outermost match in RULE lhs."
           , String -> SDoc
text String
"This rule will be ignored." ]
    DsRuleBindersNotBound [Id]
unbound [Id]
orig_bndrs CoreExpr
orig_lhs CoreExpr
lhs2
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat ((Id -> SDoc) -> [Id] -> [SDoc]
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 ([SDoc] -> SDoc
sep [ String -> SDoc
text String
"Forall'd" SDoc -> SDoc -> SDoc
<+> Id -> SDoc
pp_bndr Id
bndr
                       , String -> SDoc
text String
"is not bound in RULE lhs"])
                Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Orig bndrs:" SDoc -> SDoc -> SDoc
<+> [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
orig_bndrs
                        , String -> SDoc
text String
"Orig lhs:" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
orig_lhs
                        , String -> SDoc
text String
"optimised lhs:" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
lhs2 ])

           pp_bndr :: Id -> SDoc
pp_bndr Id
b
            | Id -> Bool
isTyVar Id
b = String -> SDoc
text String
"type variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b)
            | Id -> Bool
isEvVar Id
b = String -> SDoc
text String
"constraint"    SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
varType Id
b))
            | Bool
otherwise = String -> SDoc
text String
"variable"      SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b)
    DsMultipleConForNewtype [LocatedN Name]
names
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Multiple constructors for newtype:" SDoc -> SDoc -> SDoc
<+> [LocatedN Name] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [LocatedN Name]
names
    DsLazyPatCantBindVarsOfUnliftedType [Id]
unlifted_bndrs
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
          SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"A lazy (~) pattern cannot bind variables of unlifted type." SDoc -> SDoc -> SDoc
$$
                String -> SDoc
text String
"Unlifted variables:")
             Int
2 ([SDoc] -> SDoc
vcat ((Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\Id
id -> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
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" (HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
  (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr HsRecUpdField GhcRn
HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
  (GenLocated SrcSpanAnnA (HsExpr GhcRn))
fld)
             ThAbstractClosedTypeFamily LFamilyDecl GhcRn
decl
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"abstract closed type family" (GenLocated SrcSpanAnnA (FamilyDecl GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LFamilyDecl GhcRn
GenLocated SrcSpanAnnA (FamilyDecl GhcRn)
decl)
             ThForeignLabel CLabelString
cls
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Foreign label" (SDoc -> SDoc
doubleQuotes (CLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabelString
cls))
             ThForeignExport LForeignDecl GhcRn
decl
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Foreign export" (GenLocated SrcSpanAnnA (ForeignDecl GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LForeignDecl GhcRn
GenLocated SrcSpanAnnA (ForeignDecl GhcRn)
decl)
             ThRejectionReason
ThMinimalPragmas
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"MINIMAL pragmas" SDoc
empty
             ThRejectionReason
ThSCCPragmas
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"SCC pragmas" SDoc
empty
             ThRejectionReason
ThNoUserInline
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"NOUSERINLINE" SDoc
empty
             ThExoticFormOfType HsType GhcRn
ty
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Exotic form of type" (HsType GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcRn
ty)
             ThAmbiguousRecordSelectors HsExpr GhcRn
e
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Ambiguous record selectors" (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e)
             ThMonadComprehensionSyntax HsExpr GhcRn
e
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"monad comprehension and [: :]" (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e)
             ThCostCentres HsExpr GhcRn
e
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Cost centres" (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e)
             ThExpressionForm HsExpr GhcRn
e
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Expression form" (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
e)
             ThExoticStatement [Stmt GhcRn (LHsExpr GhcRn)]
other
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Exotic statement" ([Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Stmt GhcRn (LHsExpr GhcRn)]
[Stmt GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))]
other)
             ThExoticLiteral HsLit GhcRn
lit
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Exotic literal" (HsLit GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsLit GhcRn
lit)
             ThExoticPattern Pat GhcRn
pat
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Exotic pattern" (Pat GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat GhcRn
pat)
             ThGuardedLambdas Match GhcRn (LHsExpr GhcRn)
m
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Guarded lambdas" (Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn)) -> SDoc
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
Match (GhcPass idR) body -> SDoc
pprMatch Match GhcRn (LHsExpr GhcRn)
Match GhcRn (GenLocated SrcSpanAnnA (HsExpr GhcRn))
m)
             ThNegativeOverloadedPatterns Pat GhcRn
pat
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Negative overloaded patterns" (Pat GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat GhcRn
pat)
             ThRejectionReason
ThHaddockDocumentation
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Haddock documentation" SDoc
empty
             ThWarningAndDeprecationPragmas [LIdP GhcRn]
decl
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"WARNING and DEPRECATION pragmas" (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
                    String -> SDoc
text String
"Pragma for declaration of" SDoc -> SDoc -> SDoc
<+> [LocatedN Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LIdP GhcRn]
[LocatedN Name]
decl
             ThRejectionReason
ThSplicesWithinDeclBrackets
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Splices within declaration brackets" SDoc
empty
             ThRejectionReason
ThNonLinearDataCon
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Non-linear fields in data constructors" SDoc
empty
         where
           mkMsg :: String -> SDoc -> DecoratedSDoc
mkMsg String
what SDoc
doc =
             SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
               SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"not (yet) handled by Template Haskell") Int
2 SDoc
doc
    DsAggregatedViewExpressions [[LHsExpr GhcTc]]
views
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated ([SDoc] -> SDoc
vcat [SDoc]
msgs)
         where
           msgs :: [SDoc]
msgs = ([GenLocated SrcSpanAnnA (HsExpr GhcTc)] -> SDoc)
-> [[GenLocated SrcSpanAnnA (HsExpr GhcTc)]] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\[GenLocated SrcSpanAnnA (HsExpr GhcTc)]
g -> String -> SDoc
text String
"Putting these view expressions into the same case:" SDoc -> SDoc -> SDoc
<+> ([GenLocated SrcSpanAnnA (HsExpr GhcTc)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GenLocated SrcSpanAnnA (HsExpr GhcTc)]
g)) [[LHsExpr GhcTc]]
[[GenLocated SrcSpanAnnA (HsExpr GhcTc)]]
views
    DsUnbangedStrictPatterns HsBindLR GhcTc GhcTc
bind
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Pattern bindings containing unlifted types should use" SDoc -> SDoc -> SDoc
$$
                 String -> SDoc
text String
"an outermost bang pattern:")
              Int
2 (HsBindLR GhcTc GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsBindLR GhcTc GhcTc
bind)
    DsCannotMixPolyAndUnliftedBindings HsBindLR GhcTc GhcTc
bind
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"You can't mix polymorphic and unlifted bindings:")
              Int
2 (HsBindLR GhcTc GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsBindLR GhcTc GhcTc
bind)
    DsWrongDoBind LHsExpr GhcTc
_rhs Type
elt_ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ Type -> SDoc
badMonadBind Type
elt_ty
    DsUnusedDoBind LHsExpr GhcTc
_rhs Type
elt_ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ Type -> SDoc
badMonadBind Type
elt_ty
    DsRecBindsNotAllowedForUnliftedTys [LHsBindLR GhcTc GhcTc]
binds
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Recursive bindings for unlifted types aren't allowed:")
              Int
2 ([SDoc] -> SDoc
vcat ((GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> SDoc)
-> [GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc) -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LHsBindLR GhcTc GhcTc]
[GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)]
binds))
    DsRuleMightInlineFirst CLabelString
rule_name Id
lhs_id Activation
_
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Rule" SDoc -> SDoc -> SDoc
<+> CLabelString -> SDoc
pprRuleName CLabelString
rule_name
                          SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"may never fire")
                       Int
2 (String -> SDoc
text String
"because" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
lhs_id)
                          SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"might inline first")
                ]
    DsAnotherRuleMightFireFirst CLabelString
rule_name CLabelString
bad_rule Id
lhs_id
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Rule" SDoc -> SDoc -> SDoc
<+> CLabelString -> SDoc
pprRuleName CLabelString
rule_name
                          SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"may never fire")
                       Int
2 (String -> SDoc
text String
"because rule" SDoc -> SDoc -> SDoc
<+> CLabelString -> SDoc
pprRuleName CLabelString
bad_rule
                          SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"for"SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
lhs_id)
                          SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"might fire first")
                ]

  diagnosticReason :: DsMessage -> DiagnosticReason
diagnosticReason = \case
    DsUnknownMessage a
m          -> a -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason a
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]
_
      -> DiagnosticReason
-> (WarningFlag -> DiagnosticReason)
-> Maybe WarningFlag
-> DiagnosticReason
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
    DsMultipleConForNewtype{}                   -> DiagnosticReason
ErrorWithoutFlag
    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 a
m          -> a -> [GhcHint]
forall a. Diagnostic a => a -> [GhcHint]
diagnosticHints a
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 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== -Integer
i -- Note [Suggest NegativeLiterals]
            , Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0
            -> [ SDoc -> Extension -> GhcHint
suggestExtensionWithInfo (String -> SDoc
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
    DsMultipleConForNewtype{}                   -> [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]

{-
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 (String -> SDoc
text String
"A do-notation statement discarded a result of type")
       Int
2 (SDoc -> SDoc
quotes (Type -> SDoc
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 (String -> SDoc
text String
txt) (((SDoc -> SDoc) -> SDoc) -> SDoc)
-> ((SDoc -> SDoc) -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \SDoc -> SDoc
f ->
  SDoc -> SDoc
f (SDoc
q SDoc -> SDoc -> SDoc
<+> HsMatchContext GhcRn -> SDoc
forall p. HsMatchContext p -> SDoc
matchSeparator HsMatchContext GhcRn
ctx SDoc -> SDoc -> SDoc
<+> String -> SDoc
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
  = [SDoc] -> SDoc
vcat [String -> SDoc
text String
txt SDoc -> SDoc -> SDoc
<+> SDoc
msg,
          [SDoc] -> SDoc
sep [ String -> SDoc
text String
"In" SDoc -> SDoc -> SDoc
<+> SDoc
ppr_match SDoc -> SDoc -> SDoc
<> Char -> SDoc
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 }
                  -> (HsMatchContext GhcRn -> SDoc
forall p.
(Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) =>
HsMatchContext p -> SDoc
pprMatchContext HsMatchContext GhcRn
kind, \ SDoc
pp -> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
fun SDoc -> SDoc -> SDoc
<+> SDoc
pp)
             HsMatchContext GhcRn
_    -> (HsMatchContext GhcRn -> SDoc
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 [a] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
maxPatterns = String -> SDoc
text String
"..."
    | Bool
otherwise                      = SDoc
empty