{-# 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
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
  diagnosticMessage :: DiagnosticOpts DsMessage -> DsMessage -> DecoratedSDoc
diagnosticMessage DiagnosticOpts DsMessage
opts = \case
    DsUnknownMessage (UnknownDiagnostic DiagnosticOpts DsMessage -> DiagnosticOpts a
f a
m)
      -> DiagnosticOpts a -> a -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage (DiagnosticOpts DsMessage -> DiagnosticOpts a
f DiagnosticOpts DsMessage
opts) a
m
    DsMessage
DsEmptyEnumeration
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Call of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
conv_fn SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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
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
                 -> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Literal" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Integer -> SDoc
forall doc. IsLine doc => Integer -> doc
integer Integer
i
                       SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is negative but" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc
                       SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"only supports positive numbers"
                         ]
               Just (MinBound Integer
minB, MaxBound Integer
maxB)
                 -> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Literal" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Integer -> SDoc
forall doc. IsLine doc => Integer -> doc
integer Integer
i
                                 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is out of the" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"range"
                                 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Integer -> SDoc
forall doc. IsLine doc => Integer -> doc
integer Integer
minB SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
".." SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Integer -> SDoc
forall doc. IsLine doc => Integer -> doc
integer Integer
maxB
                         ]
         in SDoc -> DecoratedSDoc
mkSimpleDecorated SDoc
msg
    DsRedundantBangPatterns HsMatchContextRn
ctx SDoc
q
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ HsMatchContextRn -> SDoc -> String -> SDoc
pprEqn HsMatchContextRn
ctx SDoc
q String
"has redundant bang"
    DsOverlappingPatterns HsMatchContextRn
ctx SDoc
q
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ HsMatchContextRn -> SDoc -> String -> SDoc
pprEqn HsMatchContextRn
ctx SDoc
q String
"is redundant"
    DsInaccessibleRhs HsMatchContextRn
ctx SDoc
q
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ HsMatchContextRn -> SDoc -> String -> SDoc
pprEqn HsMatchContextRn
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
forall doc. IsDoc doc => [doc] -> doc
vcat
           [ SDoc -> Int -> SDoc -> SDoc
hang
               (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Pattern match checker ran into -fmax-pmcheck-models="
                 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
limit
                 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" limit, so")
               Int
2
               (  SDoc
bullet SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Redundant clauses might not be reported at all"
               SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
bullet SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Redundant clauses might be reported as inaccessible"
               SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
bullet SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Patterns reported as unmatched might actually be matched")
           ]
    DsNonExhaustivePatterns HsMatchContextRn
kind ExhaustivityCheckType
_flag Int
maxPatterns [Id]
vars [Nabla]
nablas
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           Bool
-> HsMatchContextRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext Bool
False HsMatchContextRn
kind (String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
text String
"Patterns of type" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pp_tys SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"not matched:")
                              Int
4
                              ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (Int -> [SDoc] -> [SDoc]
forall a. Int -> [a] -> [a]
take Int
maxPatterns [SDoc]
us) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ 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
forall doc. IsLine doc => String -> doc
text String
"Top-level" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
desc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
text String
"Ignoring useless SPECIALISE pragma for class selector:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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
forall doc. IsLine doc => String -> doc
text String
"Ignoring useless SPECIALISE pragma for NOINLINE function:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
poly_id)
    DsOrphanRule CoreRule
rule
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Orphan rule:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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
forall doc. IsLine doc => String -> doc
text String
"RULE left-hand side too complicated to desugar")
                      Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Optimised lhs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
lhs2
                              , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Orig lhs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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
forall doc. IsDoc doc => [doc] -> doc
vcat
           [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"A constructor," SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
               String -> SDoc
forall doc. IsLine doc => String -> doc
text String
", appears as outermost match in RULE lhs."
           , String -> SDoc
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 (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Forall'd" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
pp_bndr Id
bndr
                       , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is not bound in RULE lhs"])
                Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Orig bndrs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
orig_bndrs
                        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Orig lhs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
orig_lhs
                        , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"optimised lhs:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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
forall doc. IsLine doc => String -> doc
text String
"type variable" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b)
            | Id -> Bool
isEvVar Id
b = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"constraint"    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
varType Id
b))
            | Bool
otherwise = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"variable"      SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
b)
    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
forall doc. IsLine doc => String -> doc
text String
"A lazy (~) pattern cannot bind variables of unlifted type." SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Unlifted variables:")
             Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> 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 GhcRn
fld
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Ambiguous record updates" (HsFieldBind
  (GenLocated SrcSpanAnnA (FieldOcc GhcRn))
  (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr HsRecUpdField GhcRn GhcRn
HsFieldBind
  (GenLocated SrcSpanAnnA (FieldOcc 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
forall doc. IsLine doc => doc -> doc
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
forall doc. IsOutput doc => doc
empty
             ThRejectionReason
ThSCCPragmas
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"SCC pragmas" SDoc
forall doc. IsOutput doc => doc
empty
             ThRejectionReason
ThNoUserInline
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"NOUSERINLINE" SDoc
forall doc. IsOutput doc => doc
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
forall doc. IsOutput doc => doc
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
forall doc. IsLine doc => String -> doc
text String
"Pragma for declaration of" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [GenLocated SrcSpanAnnN Name] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LIdP GhcRn]
[GenLocated SrcSpanAnnN Name]
decl
             ThRejectionReason
ThSplicesWithinDeclBrackets
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Splices within declaration brackets" SDoc
forall doc. IsOutput doc => doc
empty
             ThRejectionReason
ThNonLinearDataCon
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Non-linear fields in data constructors" SDoc
forall doc. IsOutput doc => doc
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
forall doc. IsLine doc => String -> doc
text String
what SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
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 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
forall doc. IsLine doc => String -> doc
text String
"Putting these view expressions into the same case:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ([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
forall doc. IsLine doc => String -> doc
text String
"Pattern bindings containing unlifted types should use" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                 String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
text String
"Recursive bindings for unlifted types aren't allowed:")
              Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Rule" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CLabelString -> SDoc
pprRuleName CLabelString
rule_name
                          SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"may never fire")
                       Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"because" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
lhs_id)
                          SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Rule" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CLabelString -> SDoc
pprRuleName CLabelString
rule_name
                          SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"may never fire")
                       Int
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"because rule" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CLabelString -> SDoc
pprRuleName CLabelString
bad_rule
                          SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"for"SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
lhs_id)
                          SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"might fire first")
                ]
    DsIncompleteRecordSelector Name
name [ConLike]
cons Int
maxCons -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
      SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Selecting the record field" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
              SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"may fail for the following constructors:")
           Int
2
           ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
            (ConLike -> SDoc) -> [ConLike] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int -> [ConLike] -> [ConLike]
forall a. Int -> [a] -> [a]
take Int
maxCons [ConLike]
cons) [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"..." | [ConLike] -> Int -> Bool
forall a. [a] -> Int -> Bool
lengthExceeds [ConLike]
cons Int
maxCons ])

  diagnosticReason :: DsMessage -> DiagnosticReason
diagnosticReason = \case
    DsUnknownMessage UnknownDiagnostic (DiagnosticOpts DsMessage)
m          -> UnknownDiagnostic NoDiagnosticOpts -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason UnknownDiagnostic NoDiagnosticOpts
UnknownDiagnostic (DiagnosticOpts DsMessage)
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 HsMatchContextRn
_ (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
    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
    DsIncompleteRecordSelector{}                -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnIncompleteRecordSelectors

  diagnosticHints :: DsMessage -> [GhcHint]
diagnosticHints = \case
    DsUnknownMessage UnknownDiagnostic (DiagnosticOpts DsMessage)
m          -> UnknownDiagnostic NoDiagnosticOpts -> [GhcHint]
forall a. Diagnostic a => a -> [GhcHint]
diagnosticHints UnknownDiagnostic NoDiagnosticOpts
UnknownDiagnostic (DiagnosticOpts DsMessage)
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
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
    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]
    DsIncompleteRecordSelector{}                -> [GhcHint]
noHints

  diagnosticCode :: DsMessage -> Maybe DiagnosticCode
diagnosticCode = DsMessage -> Maybe 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 (String -> SDoc
forall doc. IsLine doc => String -> doc
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 :: HsMatchContextRn -> SDoc -> String -> SDoc
pprEqn :: HsMatchContextRn -> SDoc -> String -> SDoc
pprEqn HsMatchContextRn
ctx SDoc
q String
txt = Bool
-> HsMatchContextRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext Bool
True HsMatchContextRn
ctx (String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => doc -> doc -> doc
<+> HsMatchContext (GenLocated SrcSpanAnnN Name) -> SDoc
forall fn. HsMatchContext fn -> SDoc
matchSeparator HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
ctx SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"...")

pprContext :: Bool -> HsMatchContextRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext :: Bool
-> HsMatchContextRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext Bool
singular HsMatchContextRn
kind SDoc
msg (SDoc -> SDoc) -> SDoc
rest_of_msg_fun
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
txt SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
msg,
          [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"In" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
ppr_match SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
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 HsMatchContextRn
kind of
             FunRhs { mc_fun :: forall fn. HsMatchContext fn -> fn
mc_fun = L SrcSpanAnnN
_ Name
fun }
                  -> (HsMatchContext (GenLocated SrcSpanAnnN Name) -> SDoc
forall fn. Outputable fn => HsMatchContext fn -> SDoc
pprMatchContext HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
kind, \ SDoc
pp -> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
fun SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pp)
             HsMatchContextRn
_    -> (HsMatchContext (GenLocated SrcSpanAnnN Name) -> SDoc
forall fn. Outputable fn => HsMatchContext fn -> SDoc
pprMatchContext HsMatchContextRn
HsMatchContext (GenLocated SrcSpanAnnN Name)
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
forall doc. IsLine doc => String -> doc
text String
"..."
    | Bool
otherwise                      = SDoc
forall doc. IsOutput doc => doc
empty