{-# 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
  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 HsMatchContext GhcTc
ctx SDoc
q
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ HsMatchContext GhcTc -> SDoc -> String -> SDoc
pprEqn HsMatchContext GhcTc
ctx SDoc
q String
"has redundant bang"
    DsOverlappingPatterns HsMatchContext GhcTc
ctx SDoc
q
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ HsMatchContext GhcTc -> SDoc -> String -> SDoc
pprEqn HsMatchContext GhcTc
ctx SDoc
q String
"is redundant"
    DsInaccessibleRhs HsMatchContext GhcTc
ctx SDoc
q
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ HsMatchContext GhcTc -> SDoc -> String -> SDoc
pprEqn HsMatchContext GhcTc
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 HsMatchContext GhcTc
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 GhcTc -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext Bool
False HsMatchContext GhcTc
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)
    DsMessage
DsMultiplicityCoercionsNotSupported
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
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 (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 (GhcPass 'Renamed) (GhcPass 'Renamed)
fld
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Ambiguous record updates" (HsFieldBind
  (GenLocated
     (SrcAnn NoEpAnns) (AmbiguousFieldOcc (GhcPass 'Renamed)))
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr HsRecUpdField (GhcPass 'Renamed) (GhcPass 'Renamed)
HsFieldBind
  (GenLocated
     (SrcAnn NoEpAnns) (AmbiguousFieldOcc (GhcPass 'Renamed)))
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
fld)
             ThAbstractClosedTypeFamily LFamilyDecl (GhcPass 'Renamed)
decl
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"abstract closed type family" (GenLocated SrcSpanAnnA (FamilyDecl (GhcPass 'Renamed)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LFamilyDecl (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (FamilyDecl (GhcPass 'Renamed))
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 (GhcPass 'Renamed)
decl
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Foreign export" (GenLocated SrcSpanAnnA (ForeignDecl (GhcPass 'Renamed)) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LForeignDecl (GhcPass 'Renamed)
GenLocated SrcSpanAnnA (ForeignDecl (GhcPass 'Renamed))
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 (GhcPass 'Renamed)
ty
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Exotic form of type" (HsType (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType (GhcPass 'Renamed)
ty)
             ThAmbiguousRecordSelectors HsExpr (GhcPass 'Renamed)
e
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Ambiguous record selectors" (HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
e)
             ThMonadComprehensionSyntax HsExpr (GhcPass 'Renamed)
e
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"monad comprehension and [: :]" (HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
e)
             ThCostCentres HsExpr (GhcPass 'Renamed)
e
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Cost centres" (HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
e)
             ThExpressionForm HsExpr (GhcPass 'Renamed)
e
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Expression form" (HsExpr (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr (GhcPass 'Renamed)
e)
             ThExoticStatement [Stmt (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))]
other
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Exotic statement" ([Stmt
   (GhcPass 'Renamed)
   (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))]
-> SDoc
forall a. Outputable a => a -> SDoc
ppr [Stmt (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))]
[Stmt
   (GhcPass 'Renamed)
   (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))]
other)
             ThExoticLiteral HsLit (GhcPass 'Renamed)
lit
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Exotic literal" (HsLit (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsLit (GhcPass 'Renamed)
lit)
             ThExoticPattern Pat (GhcPass 'Renamed)
pat
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Exotic pattern" (Pat (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat (GhcPass 'Renamed)
pat)
             ThGuardedLambdas Match (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
m
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Guarded lambdas" (Match
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
-> SDoc
forall (idR :: Pass) body.
(OutputableBndrId idR, Outputable body) =>
Match (GhcPass idR) body -> SDoc
pprMatch Match (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))
Match
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (HsExpr (GhcPass 'Renamed)))
m)
             ThNegativeOverloadedPatterns Pat (GhcPass 'Renamed)
pat
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Negative overloaded patterns" (Pat (GhcPass 'Renamed) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat (GhcPass 'Renamed)
pat)
             ThRejectionReason
ThHaddockDocumentation
               -> String -> SDoc -> DecoratedSDoc
mkMsg String
"Haddock documentation" SDoc
forall doc. IsOutput doc => doc
empty
             ThWarningAndDeprecationPragmas [LIdP (GhcPass 'Renamed)]
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 (GhcPass 'Renamed)]
[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")
                ]

  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 HsMatchContext GhcTc
_ (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
    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 (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
    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 = 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 :: HsMatchContext GhcTc -> SDoc -> String -> SDoc
pprEqn :: HsMatchContext GhcTc -> SDoc -> String -> SDoc
pprEqn HsMatchContext GhcTc
ctx SDoc
q String
txt = Bool
-> HsMatchContext GhcTc -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext Bool
True HsMatchContext GhcTc
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 GhcTc -> SDoc
forall p. HsMatchContext p -> SDoc
matchSeparator HsMatchContext GhcTc
ctx SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"...")

pprContext :: Bool -> HsMatchContext GhcTc -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext :: Bool
-> HsMatchContext GhcTc -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
pprContext Bool
singular HsMatchContext GhcTc
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 HsMatchContext GhcTc
kind of
             FunRhs { mc_fun :: forall p. HsMatchContext p -> LIdP (NoGhcTc p)
mc_fun = L SrcSpanAnnN
_ Name
fun }
                  -> (HsMatchContext GhcTc -> SDoc
forall p.
(Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) =>
HsMatchContext p -> SDoc
pprMatchContext HsMatchContext GhcTc
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)
             HsMatchContext GhcTc
_    -> (HsMatchContext GhcTc -> SDoc
forall p.
(Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) =>
HsMatchContext p -> SDoc
pprMatchContext HsMatchContext GhcTc
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