{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic TcRnMessage

module GHC.Tc.Errors.Ppr
  ( pprTypeDoesNotHaveFixedRuntimeRep
  , pprScopeError
  --
  , tidySkolemInfo
  , tidySkolemInfoAnon
  --
  , withHsDocContext
  , pprHsDocContext
  , inHsDocContext
  )
  where

import GHC.Prelude

import GHC.Builtin.Names

import GHC.Core.Coercion
import GHC.Core.Unify     ( tcMatchTys )
import GHC.Core.TyCon
import GHC.Core.Class
import GHC.Core.DataCon
import GHC.Core.Coercion.Axiom (coAxiomTyCon, coAxiomSingleBranch)
import GHC.Core.ConLike
import GHC.Core.FamInstEnv (famInstAxiom)
import GHC.Core.InstEnv
import GHC.Core.TyCo.Rep (Type(..))
import GHC.Core.TyCo.Ppr (pprWithExplicitKindsWhen,
                          pprSourceTyCon, pprTyVars, pprWithTYPE)
import GHC.Core.PatSyn ( patSynName, pprPatSynType )
import GHC.Core.Predicate
import GHC.Core.Type

import GHC.Driver.Flags

import GHC.Hs

import GHC.Tc.Errors.Types
import GHC.Tc.Types.Constraint
import {-# SOURCE #-} GHC.Tc.Types (getLclEnvLoc)
import GHC.Tc.Types.Origin
import GHC.Tc.Types.Rank (Rank(..))
import GHC.Tc.Utils.TcType
import GHC.Types.Error
import GHC.Types.FieldLabel (flIsOverloaded)
import GHC.Types.Hint (UntickedPromotedThing(..), pprUntickedConstructor, isBareSymbol)
import GHC.Types.Hint.Ppr () -- Outputable GhcHint
import GHC.Types.Basic
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Name.Reader ( GreName(..), pprNameProvenance
                             , RdrName, rdrNameOcc, greMangledName )
import GHC.Types.Name.Set
import GHC.Types.SrcLoc
import GHC.Types.TyThing
import GHC.Types.Unique.Set ( nonDetEltsUniqSet )
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Var.Env

import GHC.Unit.State (pprWithUnitState, UnitState)
import GHC.Unit.Module

import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Data.List.SetOps ( nubOrdBy )
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic

import qualified GHC.LanguageExtensions as LangExt

import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import Data.Function (on)
import Data.List ( groupBy, sortBy, tails
                 , partition, unfoldr )
import Data.Ord ( comparing )
import Data.Bifunctor
import GHC.Types.Name.Env


instance Diagnostic TcRnMessage where
  diagnosticMessage :: TcRnMessage -> DecoratedSDoc
diagnosticMessage = \case
    TcRnUnknownMessage a
m
      -> a -> DecoratedSDoc
forall a. Diagnostic a => a -> DecoratedSDoc
diagnosticMessage a
m
    TcRnMessageWithInfo UnitState
unit_state TcRnMessageDetailed
msg_with_info
      -> case TcRnMessageDetailed
msg_with_info of
           TcRnMessageDetailed ErrInfo
err_info TcRnMessage
msg
             -> UnitState -> ErrInfo -> DecoratedSDoc -> DecoratedSDoc
messageWithInfoDiagnosticMessage UnitState
unit_state ErrInfo
err_info (TcRnMessage -> DecoratedSDoc
forall a. Diagnostic a => a -> DecoratedSDoc
diagnosticMessage TcRnMessage
msg)
    TcRnSolverReport [SolverReportWithCtxt]
msgs DiagnosticReason
_ [GhcHint]
_
      -> [SDoc] -> DecoratedSDoc
mkDecorated ([SDoc] -> DecoratedSDoc) -> [SDoc] -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           (SolverReportWithCtxt -> SDoc) -> [SolverReportWithCtxt] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map SolverReportWithCtxt -> SDoc
pprSolverReportWithCtxt [SolverReportWithCtxt]
msgs
    TcRnRedundantConstraints [TcTyVar]
redundants (SkolemInfoAnon
info, Bool
show_info)
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
         String -> SDoc
text String
"Redundant constraint" SDoc -> SDoc -> SDoc
<> [TcTyVar] -> SDoc
forall a. [a] -> SDoc
plural [TcTyVar]
redundants SDoc -> SDoc -> SDoc
<> SDoc
colon
           SDoc -> SDoc -> SDoc
<+> [TcTyVar] -> SDoc
pprEvVarTheta [TcTyVar]
redundants
         SDoc -> SDoc -> SDoc
$$ if Bool
show_info then String -> SDoc
text String
"In" SDoc -> SDoc -> SDoc
<+> SkolemInfoAnon -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfoAnon
info else SDoc
empty
    TcRnInaccessibleCode Implication
implic NonEmpty SolverReportWithCtxt
contras
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
         SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Inaccessible code in")
           Int
2 (SkolemInfoAnon -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Implication -> SkolemInfoAnon
ic_info Implication
implic))
         SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat ((SolverReportWithCtxt -> SDoc) -> [SolverReportWithCtxt] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map SolverReportWithCtxt -> SDoc
pprSolverReportWithCtxt (NonEmpty SolverReportWithCtxt -> [SolverReportWithCtxt]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty SolverReportWithCtxt
contras))
    TcRnTypeDoesNotHaveFixedRuntimeRep Type
ty FixedRuntimeRepProvenance
prov (ErrInfo SDoc
extra SDoc
supplementary)
      -> [SDoc] -> DecoratedSDoc
mkDecorated [Type -> FixedRuntimeRepProvenance -> SDoc
pprTypeDoesNotHaveFixedRuntimeRep Type
ty FixedRuntimeRepProvenance
prov, SDoc
extra, SDoc
supplementary]
    TcRnImplicitLift var
id_or_name ErrInfo{SDoc
errInfoContext :: SDoc
errInfoSupplementary :: SDoc
errInfoContext :: ErrInfo -> SDoc
errInfoSupplementary :: ErrInfo -> SDoc
..}
      -> [SDoc] -> DecoratedSDoc
mkDecorated ([SDoc] -> DecoratedSDoc) -> [SDoc] -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           ( String -> SDoc
text String
"The variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (var -> SDoc
forall a. Outputable a => a -> SDoc
ppr var
id_or_name) SDoc -> SDoc -> SDoc
<+>
             String -> SDoc
text String
"is implicitly lifted in the TH quotation"
           ) SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [SDoc
errInfoContext, SDoc
errInfoSupplementary]
    TcRnUnusedPatternBinds HsBind GhcRn
bind
      -> [SDoc] -> DecoratedSDoc
mkDecorated [SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"This pattern-binding binds no variables:") Int
2 (HsBind GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsBind GhcRn
bind)]
    TcRnDodgyImports RdrName
name
      -> [SDoc] -> DecoratedSDoc
mkDecorated [SDoc -> RdrName -> IE GhcPs -> SDoc
forall a b. (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc
dodgy_msg (String -> SDoc
text String
"import") RdrName
name (IdP GhcPs -> IE GhcPs
forall (p :: Pass). IdP (GhcPass p) -> IE (GhcPass p)
dodgy_msg_insert IdP GhcPs
RdrName
name :: IE GhcPs)]
    TcRnDodgyExports Name
name
      -> [SDoc] -> DecoratedSDoc
mkDecorated [SDoc -> Name -> IE GhcRn -> SDoc
forall a b. (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc
dodgy_msg (String -> SDoc
text String
"export") Name
name (IdP GhcRn -> IE GhcRn
forall (p :: Pass). IdP (GhcPass p) -> IE (GhcPass p)
dodgy_msg_insert IdP GhcRn
Name
name :: IE GhcRn)]
    TcRnMissingImportList IE GhcPs
ie
      -> [SDoc] -> DecoratedSDoc
mkDecorated [ String -> SDoc
text String
"The import item" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (IE GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr IE GhcPs
ie) SDoc -> SDoc -> SDoc
<+>
                       String -> SDoc
text String
"does not have an explicit import list"
                     ]
    TcRnMessage
TcRnUnsafeDueToPlugin
      -> [SDoc] -> DecoratedSDoc
mkDecorated [String -> SDoc
text String
"Use of plugins makes the module unsafe"]
    TcRnModMissingRealSrcSpan Module
mod
      -> [SDoc] -> DecoratedSDoc
mkDecorated [String -> SDoc
text String
"Module does not have a RealSrcSpan:" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod]
    TcRnIdNotExportedFromModuleSig Name
name Module
mod
      -> [SDoc] -> DecoratedSDoc
mkDecorated [ String -> SDoc
text String
"The identifier" SDoc -> SDoc -> SDoc
<+> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
name) SDoc -> SDoc -> SDoc
<+>
                       String -> SDoc
text String
"does not exist in the signature for" SDoc -> SDoc -> SDoc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod
                     ]
    TcRnIdNotExportedFromLocalSig Name
name
      -> [SDoc] -> DecoratedSDoc
mkDecorated [ String -> SDoc
text String
"The identifier" SDoc -> SDoc -> SDoc
<+> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
name) SDoc -> SDoc -> SDoc
<+>
                       String -> SDoc
text String
"does not exist in the local signature."
                     ]
    TcRnShadowedName OccName
occ ShadowedNameProvenance
provenance
      -> let shadowed_locs :: [SDoc]
shadowed_locs = case ShadowedNameProvenance
provenance of
               ShadowedNameProvenanceLocal SrcLoc
n     -> [String -> SDoc
text String
"bound at" SDoc -> SDoc -> SDoc
<+> SrcLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcLoc
n]
               ShadowedNameProvenanceGlobal [GlobalRdrElt]
gres -> (GlobalRdrElt -> SDoc) -> [GlobalRdrElt] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GlobalRdrElt -> SDoc
pprNameProvenance [GlobalRdrElt]
gres
         in SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
            [SDoc] -> SDoc
sep [String -> SDoc
text String
"This binding for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ)
             SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"shadows the existing binding" SDoc -> SDoc -> SDoc
<> [SDoc] -> SDoc
forall a. [a] -> SDoc
plural [SDoc]
shadowed_locs,
                   Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat [SDoc]
shadowed_locs)]
    TcRnDuplicateWarningDecls LocatedN RdrName
d RdrName
rdr_name
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Multiple warning declarations for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
rdr_name),
                 String -> SDoc
text String
"also at " SDoc -> SDoc -> SDoc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LocatedN RdrName -> SrcSpan
forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA LocatedN RdrName
d)]
    TcRnSimplifierTooManyIterations Cts
simples IntWithInf
limit WantedConstraints
wc
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"solveWanteds: too many iterations"
                   SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (String -> SDoc
text String
"limit =" SDoc -> SDoc -> SDoc
<+> IntWithInf -> SDoc
forall a. Outputable a => a -> SDoc
ppr IntWithInf
limit))
                Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Unsolved:" SDoc -> SDoc -> SDoc
<+> WantedConstraints -> SDoc
forall a. Outputable a => a -> SDoc
ppr WantedConstraints
wc
                        , String -> SDoc
text String
"Simples:"  SDoc -> SDoc -> SDoc
<+> Cts -> SDoc
forall a. Outputable a => a -> SDoc
ppr Cts
simples
                        ])
    TcRnIllegalPatSynDecl LIdP GhcPs
rdrname
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Illegal pattern synonym declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LocatedN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LIdP GhcPs
LocatedN RdrName
rdrname))
              Int
2 (String -> SDoc
text String
"Pattern synonym declarations are only valid at top level")
    TcRnLinearPatSyn Type
ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Pattern synonyms do not support linear fields (GHC #18806):") Int
2 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
    TcRnMessage
TcRnEmptyRecordUpdate
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Empty record update"
    TcRnIllegalFieldPunning Located RdrName
fld
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Illegal use of punning for field" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located RdrName
fld)
    TcRnIllegalWildcardsInRecord RecordFieldPart
fld_part
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Illegal `..' in record" SDoc -> SDoc -> SDoc
<+> RecordFieldPart -> SDoc
pprRecordFieldPart RecordFieldPart
fld_part
    TcRnIllegalWildcardInType Maybe Name
mb_name BadAnonWildcardContext
bad Maybe HsDocContext
mb_ctxt
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [ SDoc
main_msg, SDoc
context_msg ]
      where
        main_msg :: SDoc
        main_msg :: SDoc
main_msg = case BadAnonWildcardContext
bad of
          BadAnonWildcardContext
WildcardNotLastInConstraint ->
            SDoc -> Int -> SDoc -> SDoc
hang SDoc
notAllowed Int
2 SDoc
constraint_hint_msg
          ExtraConstraintWildcardNotAllowed SoleExtraConstraintWildcardAllowed
allow_sole ->
            case SoleExtraConstraintWildcardAllowed
allow_sole of
              SoleExtraConstraintWildcardAllowed
SoleExtraConstraintWildcardNotAllowed ->
                SDoc
notAllowed
              SoleExtraConstraintWildcardAllowed
SoleExtraConstraintWildcardAllowed ->
                SDoc -> Int -> SDoc -> SDoc
hang SDoc
notAllowed Int
2 SDoc
sole_msg
          BadAnonWildcardContext
WildcardsNotAllowedAtAll ->
            SDoc
notAllowed
        context_msg :: SDoc
        context_msg :: SDoc
context_msg = case Maybe HsDocContext
mb_ctxt of
          Just HsDocContext
ctxt -> Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"in" SDoc -> SDoc -> SDoc
<+> HsDocContext -> SDoc
pprHsDocContext HsDocContext
ctxt)
          Maybe HsDocContext
_         -> SDoc
empty
        notAllowed, what, wildcard, how :: SDoc
        notAllowed :: SDoc
notAllowed = SDoc
what SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
wildcard SDoc -> SDoc -> SDoc
<+> SDoc
how
        wildcard :: SDoc
wildcard = case Maybe Name
mb_name of
          Maybe Name
Nothing   -> SDoc
pprAnonWildCard
          Just Name
name -> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
        what :: SDoc
what
          | Just Name
_ <- Maybe Name
mb_name
          = String -> SDoc
text String
"Named wildcard"
          | ExtraConstraintWildcardNotAllowed {} <- BadAnonWildcardContext
bad
          = String -> SDoc
text String
"Extra-constraint wildcard"
          | Bool
otherwise
          = String -> SDoc
text String
"Wildcard"
        how :: SDoc
how = case BadAnonWildcardContext
bad of
          BadAnonWildcardContext
WildcardNotLastInConstraint
            -> String -> SDoc
text String
"not allowed in a constraint"
          BadAnonWildcardContext
_ -> String -> SDoc
text String
"not allowed"
        constraint_hint_msg :: SDoc
        constraint_hint_msg :: SDoc
constraint_hint_msg
          | Just Name
_ <- Maybe Name
mb_name
          = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Extra-constraint wildcards must be anonymous"
                 , Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"e.g  f :: (Eq a, _) => blah") ]
          | Bool
otherwise
          = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"except as the last top-level constraint of a type signature"
                 , Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"e.g  f :: (Eq a, _) => blah") ]
        sole_msg :: SDoc
        sole_msg :: SDoc
sole_msg =
          [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"except as the sole constraint"
               , Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"e.g., deriving instance _ => Eq (Foo a)") ]
    TcRnDuplicateFieldName RecordFieldPart
fld_part NonEmpty RdrName
dups
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
hsep [String -> SDoc
text String
"duplicate field name",
                 SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (NonEmpty RdrName -> RdrName
forall a. NonEmpty a -> a
NE.head NonEmpty RdrName
dups)),
                 String -> SDoc
text String
"in record", RecordFieldPart -> SDoc
pprRecordFieldPart RecordFieldPart
fld_part]
    TcRnIllegalViewPattern Pat GhcPs
pat
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [String -> SDoc
text String
"Illegal view pattern: " SDoc -> SDoc -> SDoc
<+> Pat GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat GhcPs
pat]
    TcRnCharLiteralOutOfRange Char
c
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"character literal out of range: '\\" SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
c  SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'\''
    TcRnIllegalWildcardsInConstructor Name
con
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Illegal `..' notation for constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
con)
                , Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"The constructor has no labelled fields") ]
    TcRnIgnoringAnnotations [LAnnDecl GhcRn]
anns
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Ignoring ANN annotation" SDoc -> SDoc -> SDoc
<> [GenLocated SrcSpanAnnA (AnnDecl GhcRn)] -> SDoc
forall a. [a] -> SDoc
plural [LAnnDecl GhcRn]
[GenLocated SrcSpanAnnA (AnnDecl GhcRn)]
anns SDoc -> SDoc -> SDoc
<> SDoc
comma
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi"
    TcRnMessage
TcRnAnnotationInSafeHaskell
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Annotations are not compatible with Safe Haskell."
                , String -> SDoc
text String
"See https://gitlab.haskell.org/ghc/ghc/issues/10826" ]
    TcRnInvalidTypeApplication Type
fun_ty LHsWcType GhcRn
hs_ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Cannot apply expression of type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
fun_ty) SDoc -> SDoc -> SDoc
$$
           String -> SDoc
text String
"to a visible type argument" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsType GhcRn))
hs_ty)
    TcRnMessage
TcRnTagToEnumMissingValArg
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"tagToEnum# must appear applied to one value argument"
    TcRnTagToEnumUnspecifiedResTy Type
ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Bad call to tagToEnum# at type" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
              Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Specify the type by giving a type signature"
                      , String -> SDoc
text String
"e.g. (tagToEnum# x) :: Bool" ])
    TcRnTagToEnumResTyNotAnEnum Type
ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Bad call to tagToEnum# at type" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
              Int
2 (String -> SDoc
text String
"Result type must be an enumeration type")
    TcRnMessage
TcRnArrowIfThenElsePredDependsOnResultTy
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Predicate type of `ifThenElse' depends on result type"
    TcRnMessage
TcRnIllegalHsBootFileDecl
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Illegal declarations in an hs-boot file"
    TcRnRecursivePatternSynonym LHsBinds GhcRn
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 pattern synonym definition with following bindings:")
               Int
2 ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (HsBind GhcRn) -> SDoc)
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpanAnnA (HsBind GhcRn) -> SDoc
forall a idR.
CollectPass GhcRn =>
GenLocated (SrcSpanAnn' a) (HsBindLR GhcRn idR) -> SDoc
pprLBind ([GenLocated SrcSpanAnnA (HsBind GhcRn)] -> [SDoc])
-> (LHsBinds GhcRn -> [GenLocated SrcSpanAnnA (HsBind GhcRn)])
-> LHsBinds GhcRn
-> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsBinds GhcRn -> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
Bag (GenLocated SrcSpanAnnA (HsBind GhcRn))
-> [GenLocated SrcSpanAnnA (HsBind GhcRn)]
forall a. Bag a -> [a]
bagToList (LHsBinds GhcRn -> [SDoc]) -> LHsBinds GhcRn -> [SDoc]
forall a b. (a -> b) -> a -> b
$ LHsBinds GhcRn
binds)
          where
            pprLoc :: a -> SDoc
pprLoc a
loc = SDoc -> SDoc
parens (String -> SDoc
text String
"defined at" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
loc)
            pprLBind :: CollectPass GhcRn => GenLocated (SrcSpanAnn' a) (HsBindLR GhcRn idR) -> SDoc
            pprLBind :: forall a idR.
CollectPass GhcRn =>
GenLocated (SrcSpanAnn' a) (HsBindLR GhcRn idR) -> SDoc
pprLBind (L SrcSpanAnn' a
loc HsBindLR GhcRn idR
bind) = (Name -> SDoc) -> [Name] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CollectFlag GhcRn -> HsBindLR GhcRn idR -> [IdP GhcRn]
forall p idR.
CollectPass p =>
CollectFlag p -> HsBindLR p idR -> [IdP p]
collectHsBindBinders CollectFlag GhcRn
forall p. CollectFlag p
CollNoDictBinders HsBindLR GhcRn idR
bind)
                                        SDoc -> SDoc -> SDoc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
pprLoc (SrcSpanAnn' a -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
loc)
    TcRnPartialTypeSigTyVarMismatch Name
n1 Name
n2 Name
fn_name LHsSigWcType GhcRn
hs_ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Couldn't match" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n1)
                   SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"with" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n2))
                Int
2 (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"both bound by the partial type signature:")
                        Int
2 (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
fn_name SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
hs_ty))
    TcRnPartialTypeSigBadQuantifier Name
n Name
fn_name Maybe Type
m_unif_ty LHsSigWcType GhcRn
hs_ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Can't quantify over" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n))
                Int
2 ([SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"bound by the partial type signature:")
                             Int
2 (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
fn_name SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
-> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigWcType GhcRn
HsWildCardBndrs GhcRn (GenLocated SrcSpanAnnA (HsSigType GhcRn))
hs_ty)
                        , SDoc
extra ])
      where
        extra :: SDoc
extra | Just Type
rhs_ty <- Maybe Type
m_unif_ty
              = [SDoc] -> SDoc
sep [ SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n), String -> SDoc
text String
"should really be", SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
rhs_ty) ]
              | Bool
otherwise
              = SDoc
empty
    TcRnMissingSignature MissingSignature
what Exported
_ Bool
_ ->
      SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
      case MissingSignature
what of
        MissingPatSynSig PatSyn
p ->
          SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Pattern synonym with no type signature:")
            Int
2 (String -> SDoc
text String
"pattern" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. NamedThing a => a -> SDoc
pprPrefixName (PatSyn -> Name
patSynName PatSyn
p) SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> PatSyn -> SDoc
pprPatSynType PatSyn
p)
        MissingTopLevelBindingSig Name
name Type
ty ->
          SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Top-level binding with no type signature:")
            Int
2 (Name -> SDoc
forall a. NamedThing a => a -> SDoc
pprPrefixName Name
name SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprSigmaType Type
ty)
        MissingTyConKindSig TyCon
tc Bool
cusks_enabled ->
          SDoc -> Int -> SDoc -> SDoc
hang SDoc
msg
            Int
2 (String -> SDoc
text String
"type" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. NamedThing a => a -> SDoc
pprPrefixName (TyCon -> Name
tyConName TyCon
tc) SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprKind (TyCon -> Type
tyConKind TyCon
tc))
          where
            msg :: SDoc
msg | Bool
cusks_enabled
                = String -> SDoc
text String
"Top-level type constructor with no standalone kind signature or CUSK:"
                | Bool
otherwise
                = String -> SDoc
text String
"Top-level type constructor with no standalone kind signature:"

    TcRnPolymorphicBinderMissingSig Name
n Type
ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
sep [ String -> SDoc
text String
"Polymorphic local binding with no type signature:"
               , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
forall a. NamedThing a => a -> SDoc
pprPrefixName Name
n SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty ]
    TcRnOverloadedSig TcIdSigInfo
sig
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Overloaded signature conflicts with monomorphism restriction")
              Int
2 (TcIdSigInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcIdSigInfo
sig)
    TcRnTupleConstraintInst Class
_
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"You can't specify an instance for a tuple constraint"
    TcRnAbstractClassInst Class
clas
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Cannot define instance for abstract class" SDoc -> SDoc -> SDoc
<+>
           SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
clas))
    TcRnNoClassInstHead Type
tau
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Instance head is not headed by a class:") Int
2 (Type -> SDoc
pprType Type
tau)
    TcRnUserTypeError Type
ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (Type -> SDoc
pprUserTypeErrorTy Type
ty)
    TcRnConstraintInKind Type
ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Illegal constraint in a kind:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprType Type
ty
    TcRnUnboxedTupleOrSumTypeFuncArg UnboxedTupleOrSum
tuple_or_sum Type
ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
sep [ String -> SDoc
text String
"Illegal unboxed" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"type as function argument:"
               , Type -> SDoc
pprType Type
ty ]
        where
          what :: SDoc
what = case UnboxedTupleOrSum
tuple_or_sum of
            UnboxedTupleOrSum
UnboxedTupleType -> String -> SDoc
text String
"tuple"
            UnboxedTupleOrSum
UnboxedSumType   -> String -> SDoc
text String
"sum"
    TcRnLinearFuncInKind Type
ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Illegal linear function in a kind:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprType Type
ty
    TcRnForAllEscapeError Type
ty Type
kind
      -> 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
"Quantified type's kind mentions quantified type variable")
                Int
2 (String -> SDoc
text String
"type:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty))
           , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"where the body of the forall has this kind:")
                Int
2 (SDoc -> SDoc
quotes (Type -> SDoc
pprKind Type
kind)) ]
    TcRnVDQInTermType Type
ty
      -> 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
"Illegal visible, dependent quantification" SDoc -> SDoc -> SDoc
<+>
                   String -> SDoc
text String
"in the type of a term:")
                Int
2 (Type -> SDoc
pprType Type
ty)
           , String -> SDoc
text String
"(GHC does not yet support this)" ]
    TcRnBadQuantPredHead Type
ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Quantified predicate must have a class or type variable head:")
              Int
2 (Type -> SDoc
pprType Type
ty)
    TcRnIllegalTupleConstraint Type
ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Illegal tuple constraint:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprType Type
ty
    TcRnNonTypeVarArgInConstraint Type
ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Non type-variable argument")
              Int
2 (String -> SDoc
text String
"in the constraint:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprType Type
ty)
    TcRnIllegalImplicitParam Type
ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Illegal implicit parameter" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprType Type
ty)
    TcRnIllegalConstraintSynonymOfKind Type
kind
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Illegal constraint synonym of kind:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprKind Type
kind)
    TcRnIllegalClassInst TyConFlavour
tcf
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Illegal instance for a" SDoc -> SDoc -> SDoc
<+> TyConFlavour -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyConFlavour
tcf
                , String -> SDoc
text String
"A class instance must be for a class" ]
    TcRnOversaturatedVisibleKindArg Type
ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Illegal oversaturated visible kind argument:" SDoc -> SDoc -> SDoc
<+>
           SDoc -> SDoc
quotes (Char -> SDoc
char Char
'@' SDoc -> SDoc -> SDoc
<> Type -> SDoc
pprParendType Type
ty)
    TcRnBadAssociatedType Name
clas Name
tc
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"Class", SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
clas)
                , String -> SDoc
text String
"does not have an associated type", SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
tc) ]
    TcRnForAllRankErr Rank
rank Type
ty
      -> let herald :: SDoc
herald = case Type -> ([TcTyVar], Type)
tcSplitForAllTyVars Type
ty of
               ([], Type
_) -> String -> SDoc
text String
"Illegal qualified type:"
               ([TcTyVar], Type)
_       -> String -> SDoc
text String
"Illegal polymorphic type:"
             extra :: SDoc
extra = case Rank
rank of
               Rank
MonoTypeConstraint -> String -> SDoc
text String
"A constraint must be a monotype"
               Rank
_                  -> SDoc
empty
         in SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [SDoc -> Int -> SDoc -> SDoc
hang SDoc
herald Int
2 (Type -> SDoc
pprType Type
ty), SDoc
extra]
    TcRnMonomorphicBindings [Name]
bindings
      -> let pp_bndrs :: SDoc
pp_bndrs = [Name] -> SDoc
pprBindings [Name]
bindings
         in SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
              [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The Monomorphism Restriction applies to the binding"
                  SDoc -> SDoc -> SDoc
<> [Name] -> SDoc
forall a. [a] -> SDoc
plural [Name]
bindings
                  , String -> SDoc
text String
"for" SDoc -> SDoc -> SDoc
<+> SDoc
pp_bndrs ]
    TcRnOrphanInstance ClsInst
inst
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"Orphan instance:"
                , ClsInst -> SDoc
pprInstanceHdr ClsInst
inst
                ]
    TcRnFunDepConflict UnitState
unit_state NonEmpty ClsInst
sorted
      -> let herald :: SDoc
herald = String -> SDoc
text String
"Functional dependencies conflict between instance declarations:"
         in SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
              UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
unit_state (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ (SDoc -> Int -> SDoc -> SDoc
hang SDoc
herald Int
2 ([ClsInst] -> SDoc
pprInstances ([ClsInst] -> SDoc) -> [ClsInst] -> SDoc
forall a b. (a -> b) -> a -> b
$ NonEmpty ClsInst -> [ClsInst]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty ClsInst
sorted))
    TcRnDupInstanceDecls UnitState
unit_state NonEmpty ClsInst
sorted
      -> let herald :: SDoc
herald = String -> SDoc
text String
"Duplicate instance declarations:"
         in SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
              UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
unit_state (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ (SDoc -> Int -> SDoc -> SDoc
hang SDoc
herald Int
2 ([ClsInst] -> SDoc
pprInstances ([ClsInst] -> SDoc) -> [ClsInst] -> SDoc
forall a b. (a -> b) -> a -> b
$ NonEmpty ClsInst -> [ClsInst]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty ClsInst
sorted))
    TcRnConflictingFamInstDecls NonEmpty FamInst
sortedNE
      -> let sorted :: [FamInst]
sorted = NonEmpty FamInst -> [FamInst]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty FamInst
sortedNE
         in SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
              SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Conflicting family instance declarations:")
                 Int
2 ([SDoc] -> SDoc
vcat [ TyCon -> CoAxBranch -> SDoc
pprCoAxBranchUser (CoAxiom Unbranched -> TyCon
forall (br :: BranchFlag). CoAxiom br -> TyCon
coAxiomTyCon CoAxiom Unbranched
ax) (CoAxiom Unbranched -> CoAxBranch
coAxiomSingleBranch CoAxiom Unbranched
ax)
                         | FamInst
fi <- [FamInst]
sorted
                         , let ax :: CoAxiom Unbranched
ax = FamInst -> CoAxiom Unbranched
famInstAxiom FamInst
fi ])
    TcRnFamInstNotInjective InjectivityErrReason
rea TyCon
fam_tc (CoAxBranch
eqn1 NE.:| [CoAxBranch]
rest_eqns)
      -> let (SDoc
herald, Bool
show_kinds) = case InjectivityErrReason
rea of
               InjErrRhsBareTyVar [Type]
tys ->
                 (SDoc
injectivityErrorHerald SDoc -> SDoc -> SDoc
$$
                  String -> SDoc
text String
"RHS of injective type family equation is a bare" SDoc -> SDoc -> SDoc
<+>
                  String -> SDoc
text String
"type variable" SDoc -> SDoc -> SDoc
$$
                  String -> SDoc
text String
"but these LHS type and kind patterns are not bare" SDoc -> SDoc -> SDoc
<+>
                  String -> SDoc
text String
"variables:" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [Type]
tys, Bool
False)
               InjectivityErrReason
InjErrRhsCannotBeATypeFam ->
                 (SDoc
injectivityErrorHerald SDoc -> SDoc -> SDoc
$$
                   String -> SDoc
text String
"RHS of injective type family equation cannot" SDoc -> SDoc -> SDoc
<+>
                   String -> SDoc
text String
"be a type family:", Bool
False)
               InjectivityErrReason
InjErrRhsOverlap ->
                  (String -> SDoc
text String
"Type family equation right-hand sides overlap; this violates" SDoc -> SDoc -> SDoc
$$
                   String -> SDoc
text String
"the family's injectivity annotation:", Bool
False)
               InjErrCannotInferFromRhs TyVarSet
tvs HasKinds
has_kinds SuggestUndecidableInstances
_ ->
                 let show_kinds :: Bool
show_kinds = HasKinds
has_kinds HasKinds -> HasKinds -> Bool
forall a. Eq a => a -> a -> Bool
== HasKinds
YesHasKinds
                     what :: SDoc
what = if Bool
show_kinds then String -> SDoc
text String
"Type/kind" else String -> SDoc
text String
"Type"
                     body :: SDoc
body = [SDoc] -> SDoc
sep [ SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"variable" SDoc -> SDoc -> SDoc
<>
                                  TyVarSet -> SDoc
pluralVarSet TyVarSet
tvs SDoc -> SDoc -> SDoc
<+> TyVarSet -> ([TcTyVar] -> SDoc) -> SDoc
pprVarSet TyVarSet
tvs ([TcTyVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList ([TcTyVar] -> SDoc)
-> ([TcTyVar] -> [TcTyVar]) -> [TcTyVar] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TcTyVar] -> [TcTyVar]
scopedSort)
                                , String -> SDoc
text String
"cannot be inferred from the right-hand side." ]
                     in (SDoc
injectivityErrorHerald SDoc -> SDoc -> SDoc
$$ SDoc
body SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"In the type family equation:", Bool
show_kinds)

         in SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
pprWithExplicitKindsWhen Bool
show_kinds (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
              SDoc -> Int -> SDoc -> SDoc
hang SDoc
herald
                Int
2 ([SDoc] -> SDoc
vcat ((CoAxBranch -> SDoc) -> [CoAxBranch] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (TyCon -> CoAxBranch -> SDoc
pprCoAxBranchUser TyCon
fam_tc) (CoAxBranch
eqn1 CoAxBranch -> [CoAxBranch] -> [CoAxBranch]
forall a. a -> [a] -> [a]
: [CoAxBranch]
rest_eqns)))
    TcRnBangOnUnliftedType Type
ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Strictness flag has no effect on unlifted type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
    TcRnMultipleDefaultDeclarations [LDefaultDecl GhcRn]
dup_things
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Multiple default declarations")
              Int
2 ([SDoc] -> SDoc
vcat ((GenLocated SrcSpanAnnA (DefaultDecl GhcRn) -> SDoc)
-> [GenLocated SrcSpanAnnA (DefaultDecl GhcRn)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LDefaultDecl GhcRn -> SDoc
GenLocated SrcSpanAnnA (DefaultDecl GhcRn) -> SDoc
pp [LDefaultDecl GhcRn]
[GenLocated SrcSpanAnnA (DefaultDecl GhcRn)]
dup_things))
         where
           pp :: LDefaultDecl GhcRn -> SDoc
           pp :: LDefaultDecl GhcRn -> SDoc
pp (L SrcSpanAnnA
locn (DefaultDecl XCDefaultDecl GhcRn
_ [LHsType GhcRn]
_))
             = String -> SDoc
text String
"here was another default declaration" SDoc -> SDoc -> SDoc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
locn)
    TcRnBadDefaultType Type
ty [Class]
deflt_clss
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"The default type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not an instance of")
              Int
2 ((SDoc -> SDoc -> SDoc) -> [SDoc] -> SDoc
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\SDoc
a SDoc
b -> SDoc
a SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"or" SDoc -> SDoc -> SDoc
<+> SDoc
b) ((Class -> SDoc) -> [Class] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> SDoc
quotes(SDoc -> SDoc) -> (Class -> SDoc) -> Class -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr) [Class]
deflt_clss))
    TcRnMessage
TcRnPatSynBundledWithNonDataCon
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Pattern synonyms can be bundled only with datatypes."
    TcRnPatSynBundledWithWrongType Type
expected_res_ty Type
res_ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Pattern synonyms can only be bundled with matching type constructors"
               SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"Couldn't match expected type of"
               SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
expected_res_ty)
               SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"with actual type of"
               SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
res_ty)
    TcRnDupeModuleExport ModuleName
mod
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"Duplicate"
                , SDoc -> SDoc
quotes (String -> SDoc
text String
"Module" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod)
                , String -> SDoc
text String
"in export list" ]
    TcRnExportedModNotImported ModuleName
mod
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated
       (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> String -> SDoc
formatExportItemError
           (String -> SDoc
text String
"module" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod)
           String
"is not imported"
    TcRnNullExportedModule ModuleName
mod
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated
       (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> String -> SDoc
formatExportItemError
           (String -> SDoc
text String
"module" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod)
           String
"exports nothing"
    TcRnMissingExportList ModuleName
mod
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated
       (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> String -> SDoc
formatExportItemError
           (String -> SDoc
text String
"module" SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod)
           String
"is missing an export list"
    TcRnExportHiddenComponents IE GhcPs
export_item
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated
       (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> String -> SDoc
formatExportItemError
           (IE GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr IE GhcPs
export_item)
           String
"attempts to export constructors or class methods that are not visible here"
    TcRnDuplicateExport GreName
child IE GhcPs
ie1 IE GhcPs
ie2
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
hsep [ SDoc -> SDoc
quotes (GreName -> SDoc
forall a. Outputable a => a -> SDoc
ppr GreName
child)
                , String -> SDoc
text String
"is exported by", SDoc -> SDoc
quotes (IE GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr IE GhcPs
ie1)
                , String -> SDoc
text String
"and",            SDoc -> SDoc
quotes (IE GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr IE GhcPs
ie2) ]
    TcRnExportedParentChildMismatch Name
parent_name TyThing
ty_thing GreName
child [Name]
parent_names
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"The type constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
parent_name)
                 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not the parent of the" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
what_is
                 SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
thing SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'.'
                 SDoc -> SDoc -> SDoc
$$ String -> SDoc
text (String -> String
capitalise String
what_is)
                    SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"s can only be exported with their parent type constructor."
                 SDoc -> SDoc -> SDoc
$$ (case [SDoc]
parents of
                       [] -> SDoc
empty
                       [SDoc
_] -> String -> SDoc
text String
"Parent:"
                       [SDoc]
_  -> String -> SDoc
text String
"Parents:") SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
fsep (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma [SDoc]
parents)
      where
        pp_category :: TyThing -> String
        pp_category :: TyThing -> String
pp_category (AnId TcTyVar
i)
          | TcTyVar -> Bool
isRecordSelector TcTyVar
i = String
"record selector"
        pp_category TyThing
i = TyThing -> String
tyThingCategory TyThing
i
        what_is :: String
what_is = TyThing -> String
pp_category TyThing
ty_thing
        thing :: SDoc
thing = GreName -> SDoc
forall a. Outputable a => a -> SDoc
ppr GreName
child
        parents :: [SDoc]
parents = (Name -> SDoc) -> [Name] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
parent_names
    TcRnConflictingExports OccName
occ GreName
child1 GlobalRdrElt
gre1 IE GhcPs
ie1 GreName
child2 GlobalRdrElt
gre2 IE GhcPs
ie2
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Conflicting exports for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ) SDoc -> SDoc -> SDoc
<> SDoc
colon
                , GreName -> GlobalRdrElt -> IE GhcPs -> SDoc
forall {a}. Outputable a => GreName -> GlobalRdrElt -> a -> SDoc
ppr_export GreName
child1 GlobalRdrElt
gre1 IE GhcPs
ie1
                , GreName -> GlobalRdrElt -> IE GhcPs -> SDoc
forall {a}. Outputable a => GreName -> GlobalRdrElt -> a -> SDoc
ppr_export GreName
child2 GlobalRdrElt
gre2 IE GhcPs
ie2
                ]
      where
        ppr_export :: GreName -> GlobalRdrElt -> a -> SDoc
ppr_export GreName
child GlobalRdrElt
gre a
ie = Int -> SDoc -> SDoc
nest Int
3 (SDoc -> Int -> SDoc -> SDoc
hang (SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
ie) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"exports" SDoc -> SDoc -> SDoc
<+>
                                                SDoc -> SDoc
quotes (GreName -> SDoc
ppr_name GreName
child))
                                            Int
2 (GlobalRdrElt -> SDoc
pprNameProvenance GlobalRdrElt
gre))

        -- DuplicateRecordFields means that nameOccName might be a
        -- mangled $sel-prefixed thing, in which case show the correct OccName
        -- alone (but otherwise show the Name so it will have a module
        -- qualifier)
        ppr_name :: GreName -> SDoc
ppr_name (FieldGreName FieldLabel
fl) | FieldLabel -> Bool
flIsOverloaded FieldLabel
fl = FieldLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr FieldLabel
fl
                                   | Bool
otherwise         = Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (FieldLabel -> Name
flSelector FieldLabel
fl)
        ppr_name (NormalGreName Name
name) = Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
    TcRnAmbiguousField HsExpr GhcRn
rupd TyCon
parent_type
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
          [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"The record update" SDoc -> SDoc -> SDoc
<+> HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
rupd
                   SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"with type" SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
parent_type
                   SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is ambiguous."
               , String -> SDoc
text String
"This will not be supported by -XDuplicateRecordFields in future releases of GHC."
               ]
    TcRnMissingFields ConLike
con [(FieldLabelString, Type)]
fields
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [SDoc
header, Int -> SDoc -> SDoc
nest Int
2 SDoc
rest]
         where
           rest :: SDoc
rest | [(FieldLabelString, Type)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, Type)]
fields = SDoc
empty
                | Bool
otherwise   = [SDoc] -> SDoc
vcat (((FieldLabelString, Type) -> SDoc)
-> [(FieldLabelString, Type)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldLabelString, Type) -> SDoc
pprField [(FieldLabelString, Type)]
fields)
           header :: SDoc
header = String -> SDoc
text String
"Fields of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
con) SDoc -> SDoc -> SDoc
<+>
                    String -> SDoc
text String
"not initialised" SDoc -> SDoc -> SDoc
<>
                    if [(FieldLabelString, Type)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, Type)]
fields then SDoc
empty else SDoc
colon
    TcRnFieldUpdateInvalidType [(FieldLabelString, Type)]
prs
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Record update for insufficiently polymorphic field"
                   SDoc -> SDoc -> SDoc
<> [(FieldLabelString, Type)] -> SDoc
forall a. [a] -> SDoc
plural [(FieldLabelString, Type)]
prs SDoc -> SDoc -> SDoc
<> SDoc
colon)
              Int
2 ([SDoc] -> SDoc
vcat [ FieldLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FieldLabelString
f SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty | (FieldLabelString
f,Type
ty) <- [(FieldLabelString, Type)]
prs ])
    TcRnNoConstructorHasAllFields [FieldLabelString]
conflictingFields
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"No constructor has all these fields:")
              Int
2 ([FieldLabelString] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [FieldLabelString]
conflictingFields)
    TcRnMixedSelectors Name
data_name [TcTyVar]
data_sels Name
pat_name [TcTyVar]
pat_syn_sels
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Cannot use a mixture of pattern synonym and record selectors" SDoc -> SDoc -> SDoc
$$
           String -> SDoc
text String
"Record selectors defined by"
             SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
data_name)
             SDoc -> SDoc -> SDoc
<> SDoc
colon
             SDoc -> SDoc -> SDoc
<+> (TcTyVar -> SDoc) -> [TcTyVar] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcTyVar]
data_sels SDoc -> SDoc -> SDoc
$$
           String -> SDoc
text String
"Pattern synonym selectors defined by"
             SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
pat_name)
             SDoc -> SDoc -> SDoc
<> SDoc
colon
             SDoc -> SDoc -> SDoc
<+> (TcTyVar -> SDoc) -> [TcTyVar] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcTyVar]
pat_syn_sels
    TcRnMissingStrictFields ConLike
con [(FieldLabelString, Type)]
fields
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [SDoc
header, Int -> SDoc -> SDoc
nest Int
2 SDoc
rest]
         where
           rest :: SDoc
rest | [(FieldLabelString, Type)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, Type)]
fields = SDoc
empty  -- Happens for non-record constructors
                                       -- with strict fields
                | Bool
otherwise   = [SDoc] -> SDoc
vcat (((FieldLabelString, Type) -> SDoc)
-> [(FieldLabelString, Type)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FieldLabelString, Type) -> SDoc
pprField [(FieldLabelString, Type)]
fields)

           header :: SDoc
header = String -> SDoc
text String
"Constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
con) SDoc -> SDoc -> SDoc
<+>
                    String -> SDoc
text String
"does not have the required strict field(s)" SDoc -> SDoc -> SDoc
<>
                    if [(FieldLabelString, Type)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FieldLabelString, Type)]
fields then SDoc
empty else SDoc
colon
    TcRnNoPossibleParentForFields [LHsRecUpdField GhcRn]
rbinds
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"No type has all these fields:")
              Int
2 ([GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn)] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn)]
fields)
         where fields :: [GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn)]
fields = (GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
      (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
 -> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
-> [GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
         (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
-> [GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (HsFieldBind
  (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
  (GenLocated SrcSpanAnnA (HsExpr GhcRn))
-> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn)
forall lhs rhs. HsFieldBind lhs rhs -> lhs
hfbLHS (HsFieldBind
   (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
   (GenLocated SrcSpanAnnA (HsExpr GhcRn))
 -> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
-> (GenLocated
      SrcSpanAnnA
      (HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
         (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
    -> HsFieldBind
         (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
         (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> GenLocated
     SrcSpanAnnA
     (HsFieldBind
        (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
        (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated
  SrcSpanAnnA
  (HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
     (GenLocated SrcSpanAnnA (HsExpr GhcRn)))
-> HsFieldBind
     (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
     (GenLocated SrcSpanAnnA (HsExpr GhcRn))
forall l e. GenLocated l e -> e
unLoc) [LHsRecUpdField GhcRn]
[GenLocated
   SrcSpanAnnA
   (HsFieldBind
      (GenLocated (SrcAnn NoEpAnns) (AmbiguousFieldOcc GhcRn))
      (GenLocated SrcSpanAnnA (HsExpr GhcRn)))]
rbinds
    TcRnBadOverloadedRecordUpdate [LHsRecUpdField GhcRn]
_rbinds
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Record update is ambiguous, and requires a type signature"
    TcRnStaticFormNotClosed Name
name NotClosedReason
reason
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
             SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is used in a static form but it is not closed"
             SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"because it"
             SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
sep (NotClosedReason -> [SDoc]
causes NotClosedReason
reason)
         where
          causes :: NotClosedReason -> [SDoc]
          causes :: NotClosedReason -> [SDoc]
causes NotClosedReason
NotLetBoundReason = [String -> SDoc
text String
"is not let-bound."]
          causes (NotTypeClosed TyVarSet
vs) =
            [ String -> SDoc
text String
"has a non-closed type because it contains the"
            , String -> SDoc
text String
"type variables:" SDoc -> SDoc -> SDoc
<+>
              TyVarSet -> ([TcTyVar] -> SDoc) -> SDoc
pprVarSet TyVarSet
vs ([SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> ([TcTyVar] -> [SDoc]) -> [TcTyVar] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> [SDoc]) -> ([TcTyVar] -> [SDoc]) -> [TcTyVar] -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TcTyVar -> SDoc) -> [TcTyVar] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> SDoc
quotes (SDoc -> SDoc) -> (TcTyVar -> SDoc) -> TcTyVar -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr))
            ]
          causes (NotClosed Name
n NotClosedReason
reason) =
            let msg :: SDoc
msg = String -> SDoc
text String
"uses" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"which"
             in case NotClosedReason
reason of
                  NotClosed Name
_ NotClosedReason
_ -> SDoc
msg SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: NotClosedReason -> [SDoc]
causes NotClosedReason
reason
                  NotClosedReason
_   -> let ([SDoc]
xs0, [SDoc]
xs1) = Int -> [SDoc] -> ([SDoc], [SDoc])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
1 ([SDoc] -> ([SDoc], [SDoc])) -> [SDoc] -> ([SDoc], [SDoc])
forall a b. (a -> b) -> a -> b
$ NotClosedReason -> [SDoc]
causes NotClosedReason
reason
                          in (SDoc -> SDoc) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SDoc
msg SDoc -> SDoc -> SDoc
<+>) [SDoc]
xs0 [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
xs1
    TcRnMessage
TcRnUselessTypeable
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Deriving" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
typeableClassName) SDoc -> SDoc -> SDoc
<+>
           String -> SDoc
text String
"has no effect: all types now auto-derive Typeable"
    TcRnDerivingDefaults Class
cls
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
sep
                     [ String -> SDoc
text String
"Both DeriveAnyClass and"
                       SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"GeneralizedNewtypeDeriving are enabled"
                     , String -> SDoc
text String
"Defaulting to the DeriveAnyClass strategy"
                       SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"for instantiating" SDoc -> SDoc -> SDoc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls
                     ]
    TcRnNonUnaryTypeclassConstraint LHsSigType GhcRn
ct
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> SDoc
quotes (GenLocated SrcSpanAnnA (HsSigType GhcRn) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsSigType GhcRn
GenLocated SrcSpanAnnA (HsSigType GhcRn)
ct)
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not a unary constraint, as expected by a deriving clause"
    TcRnPartialTypeSignatures SuggestPartialTypeSignatures
_ [Type]
theta
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Found type wildcard" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Char -> SDoc
char Char
'_')
                       SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"standing for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes ([Type] -> SDoc
pprTheta [Type]
theta)
    TcRnCannotDeriveInstance Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving DeriveInstanceErrReason
reason
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> DeriveInstanceErrReason
-> SDoc
derivErrDiagnosticMessage Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
True DeriveInstanceErrReason
reason
    TcRnMessage
TcRnLazyGADTPattern
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"An existential or GADT data constructor cannot be used")
              Int
2 (String -> SDoc
text String
"inside a lazy (~) pattern")
    TcRnMessage
TcRnArrowProcGADTPattern
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Proc patterns cannot use existential or GADT data constructors"

    TcRnSpecialClassInst Class
cls Bool
because_safeHaskell
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
            String -> SDoc
text String
"Class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> SDoc) -> Name -> SDoc
forall a b. (a -> b) -> a -> b
$ Class -> Name
className Class
cls)
                   SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"does not support user-specified instances"
                   SDoc -> SDoc -> SDoc
<> SDoc
safeHaskell_msg
          where
            safeHaskell_msg :: SDoc
safeHaskell_msg
              | Bool
because_safeHaskell
              = String -> SDoc
text String
" when Safe Haskell is enabled."
              | Bool
otherwise
              = SDoc
dot
    TcRnForallIdentifier RdrName
rdr_name
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
            [SDoc] -> SDoc
fsep [ String -> SDoc
text String
"The use of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
rdr_name)
                                     SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"as an identifier",
                   String -> SDoc
text String
"will become an error in a future GHC release." ]
    TcRnMessage
TcRnTypeEqualityOutOfScope
      -> [SDoc] -> DecoratedSDoc
mkDecorated
           [ String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"~") SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"operator is out of scope." SDoc -> SDoc -> SDoc
$$
             String -> SDoc
text String
"Assuming it to stand for an equality constraint."
           , String -> SDoc
text String
"NB:" SDoc -> SDoc -> SDoc
<+> (SDoc -> SDoc
quotes (String -> SDoc
text String
"~") SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"used to be built-in syntax but now is a regular type operator" SDoc -> SDoc -> SDoc
$$
                             String -> SDoc
text String
"exported from Data.Type.Equality and Prelude.") SDoc -> SDoc -> SDoc
$$
             String -> SDoc
text String
"If you are using a custom Prelude, consider re-exporting it."
           , String -> SDoc
text String
"This will become an error in a future GHC release." ]
    TcRnMessage
TcRnTypeEqualityRequiresOperators
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
            [SDoc] -> SDoc
fsep [ String -> SDoc
text String
"The use of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (String -> SDoc
text String
"~")
                                     SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"without TypeOperators",
                   String -> SDoc
text String
"will become an error in a future GHC release." ]
    TcRnIllegalTypeOperator SDoc
overall_ty RdrName
op
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"Illegal operator" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
op) SDoc -> SDoc -> SDoc
<+>
           String -> SDoc
text String
"in type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr SDoc
overall_ty)
    TcRnMessage
TcRnGADTMonoLocalBinds
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
            [SDoc] -> SDoc
fsep [ String -> SDoc
text String
"Pattern matching on GADTs without MonoLocalBinds"
                 , String -> SDoc
text String
"is fragile." ]
    TcRnIncorrectNameSpace Name
name Bool
_
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ SDoc
msg
        where
          msg :: SDoc
msg
            -- We are in a type-level namespace,
            -- and the name is incorrectly at the term-level.
            | NameSpace -> Bool
isValNameSpace NameSpace
ns
            = String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"does not live in the type-level namespace"

            -- We are in a term-level namespace,
            -- and the name is incorrectly at the type-level.
            | Bool
otherwise
            = String -> SDoc
text String
"Illegal term-level use of the" SDoc -> SDoc -> SDoc
<+> SDoc
what
          ns :: NameSpace
ns = Name -> NameSpace
nameNameSpace Name
name
          what :: SDoc
what = NameSpace -> SDoc
pprNameSpace NameSpace
ns SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
    TcRnNotInScope NotInScopeError
err RdrName
name [ImportError]
imp_errs [GhcHint]
_
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           RdrName -> NotInScopeError -> SDoc
pprScopeError RdrName
name NotInScopeError
err SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat ((ImportError -> SDoc) -> [ImportError] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ImportError -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ImportError]
imp_errs)
    TcRnUntickedPromotedThing UntickedPromotedThing
thing
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
         String -> SDoc
text String
"Unticked promoted" SDoc -> SDoc -> SDoc
<+> SDoc
what
           where
             what :: SDoc
             what :: SDoc
what = case UntickedPromotedThing
thing of
               UntickedPromotedThing
UntickedExplicitList -> String -> SDoc
text String
"list" SDoc -> SDoc -> SDoc
<> SDoc
dot
               UntickedConstructor LexicalFixity
fixity Name
nm ->
                 let con :: SDoc
con      = LexicalFixity -> Name -> SDoc
pprUntickedConstructor LexicalFixity
fixity Name
nm
                     bare_sym :: Bool
bare_sym = LexicalFixity -> Name -> Bool
isBareSymbol LexicalFixity
fixity Name
nm
                 in String -> SDoc
text String
"constructor:" SDoc -> SDoc -> SDoc
<+> SDoc
con SDoc -> SDoc -> SDoc
<> if Bool
bare_sym then SDoc
empty else SDoc
dot
    TcRnIllegalBuiltinSyntax SDoc
what RdrName
rdr_name
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
hsep [String -> SDoc
text String
"Illegal", SDoc
what, String -> SDoc
text String
"of built-in syntax:", RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
rdr_name]
    TcRnWarnDefaulting [Ct]
tidy_wanteds Maybe TcTyVar
tidy_tv Type
default_ty
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> Int -> SDoc -> SDoc
hang ([SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ [ String -> SDoc
text String
"Defaulting" ]
                     [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
                     (case Maybe TcTyVar
tidy_tv of
                         Maybe TcTyVar
Nothing -> []
                         Just TcTyVar
tv -> [String -> SDoc
text String
"the type variable"
                                    , SDoc -> SDoc
quotes (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv)])
                     [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
                     [ String -> SDoc
text String
"to type"
                     , SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
default_ty)
                     , String -> SDoc
text String
"in the following constraint" SDoc -> SDoc -> SDoc
<> [Ct] -> SDoc
forall a. [a] -> SDoc
plural [Ct]
tidy_wanteds ])
             Int
2
             ([Ct] -> SDoc
pprWithArising [Ct]
tidy_wanteds)


    TcRnForeignImportPrimExtNotSet ForeignImport
_decl
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"`foreign import prim' requires GHCForeignImportPrim."

    TcRnForeignImportPrimSafeAnn ForeignImport
_decl
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"The safe/unsafe annotation should not be used with `foreign import prim'."

    TcRnForeignFunctionImportAsValue ForeignImport
_decl
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"`value' imports cannot have function types"

    TcRnFunPtrImportWithoutAmpersand ForeignImport
_decl
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           String -> SDoc
text String
"possible missing & in foreign import of FunPtr"

    TcRnIllegalForeignDeclBackend Either ForeignExport ForeignImport
_decl Backend
_backend ExpectedBackends
expectedBknds
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Illegal foreign declaration:" SDoc -> SDoc -> SDoc
<+>
           case ExpectedBackends
expectedBknds of
             ExpectedBackends
COrAsmOrLlvm ->
               String -> SDoc
text String
"requires unregisterised, llvm (-fllvm) or native code generation (-fasm)"
             ExpectedBackends
COrAsmOrLlvmOrInterp ->
               String -> SDoc
text String
"requires interpreted, unregisterised, llvm or native code generation"

    TcRnUnsupportedCallConv Either ForeignExport ForeignImport
_decl UnsupportedCallConvention
unsupportedCC
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           case UnsupportedCallConvention
unsupportedCC of
             UnsupportedCallConvention
StdCallConvUnsupported ->
               String -> SDoc
text String
"the 'stdcall' calling convention is unsupported on this platform,"
               SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"treating as ccall"
             UnsupportedCallConvention
PrimCallConvUnsupported ->
               String -> SDoc
text String
"The `prim' calling convention can only be used with `foreign import'"
             UnsupportedCallConvention
JavaScriptCallConvUnsupported ->
               String -> SDoc
text String
"The `javascript' calling convention is unsupported on this platform"

    TcRnIllegalForeignType Maybe ArgOrResult
mArgOrResult IllegalForeignTypeReason
reason
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> Int -> SDoc -> SDoc
hang SDoc
msg Int
2 SDoc
extra
      where
        arg_or_res :: SDoc
arg_or_res = case Maybe ArgOrResult
mArgOrResult of
          Maybe ArgOrResult
Nothing -> SDoc
empty
          Just ArgOrResult
Arg -> String -> SDoc
text String
"argument"
          Just ArgOrResult
Result -> String -> SDoc
text String
"result"
        msg :: SDoc
msg = [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"Unacceptable", SDoc
arg_or_res
                   , String -> SDoc
text String
"type in foreign declaration:"]
        extra :: SDoc
extra =
          case IllegalForeignTypeReason
reason of
            TypeCannotBeMarshaled Type
ty TypeCannotBeMarshaledReason
why ->
              let innerMsg :: SDoc
innerMsg = SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"cannot be marshalled in a foreign call"
               in case TypeCannotBeMarshaledReason
why of
                TypeCannotBeMarshaledReason
NotADataType ->
                  SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not a data type"
                NewtypeDataConNotInScope Maybe TyCon
Nothing ->
                  SDoc -> Int -> SDoc -> SDoc
hang SDoc
innerMsg Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"because its data constructor is not in scope"
                NewtypeDataConNotInScope (Just TyCon
tc) ->
                  SDoc -> Int -> SDoc -> SDoc
hang SDoc
innerMsg Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                    String -> SDoc
text String
"because the data constructor for"
                    SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not in scope"
                TypeCannotBeMarshaledReason
UnliftedFFITypesNeeded ->
                  SDoc
innerMsg SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"UnliftedFFITypes is required to marshal unlifted types"
                TypeCannotBeMarshaledReason
NotABoxedMarshalableTyCon -> SDoc
innerMsg
                TypeCannotBeMarshaledReason
ForeignLabelNotAPtr ->
                  SDoc
innerMsg SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)"
                TypeCannotBeMarshaledReason
NotSimpleUnliftedType ->
                  SDoc
innerMsg SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"foreign import prim only accepts simple unlifted types"
            ForeignDynNotPtr Type
expected Type
ty ->
              [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Expected: Ptr/FunPtr" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprParendType Type
expected SDoc -> SDoc -> SDoc
<> SDoc
comma, String -> SDoc
text String
"  Actual:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty ]
            IllegalForeignTypeReason
SafeHaskellMustBeInIO ->
              String -> SDoc
text String
"Safe Haskell is on, all FFI imports must be in the IO monad"
            IllegalForeignTypeReason
IOResultExpected ->
              String -> SDoc
text String
"IO result type expected"
            IllegalForeignTypeReason
UnexpectedNestedForall ->
              String -> SDoc
text String
"Unexpected nested forall"
            IllegalForeignTypeReason
LinearTypesNotAllowed ->
              String -> SDoc
text String
"Linear types are not supported in FFI declarations, see #18472"
            IllegalForeignTypeReason
OneArgExpected ->
              String -> SDoc
text String
"One argument expected"
            IllegalForeignTypeReason
AtLeastOneArgExpected ->
              String -> SDoc
text String
"At least one argument expected"
    TcRnInvalidCIdentifier FieldLabelString
target
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
           [SDoc] -> SDoc
sep [SDoc -> SDoc
quotes (FieldLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FieldLabelString
target) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not a valid C identifier"]

  diagnosticReason :: TcRnMessage -> DiagnosticReason
diagnosticReason = \case
    TcRnUnknownMessage a
m
      -> a -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason a
m
    TcRnMessageWithInfo UnitState
_ TcRnMessageDetailed
msg_with_info
      -> case TcRnMessageDetailed
msg_with_info of
           TcRnMessageDetailed ErrInfo
_ TcRnMessage
m -> TcRnMessage -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason TcRnMessage
m
    TcRnSolverReport [SolverReportWithCtxt]
_ DiagnosticReason
reason [GhcHint]
_
      -> DiagnosticReason
reason -- Error, or a Warning if we are deferring type errors
    TcRnRedundantConstraints {}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnRedundantConstraints
    TcRnInaccessibleCode {}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnInaccessibleCode
    TcRnTypeDoesNotHaveFixedRuntimeRep{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnImplicitLift{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnImplicitLift
    TcRnUnusedPatternBinds{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnUnusedPatternBinds
    TcRnDodgyImports{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnDodgyImports
    TcRnDodgyExports{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnDodgyExports
    TcRnMissingImportList{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnMissingImportList
    TcRnUnsafeDueToPlugin{}
      -> DiagnosticReason
WarningWithoutFlag
    TcRnModMissingRealSrcSpan{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnIdNotExportedFromModuleSig{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnIdNotExportedFromLocalSig{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnShadowedName{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnNameShadowing
    TcRnDuplicateWarningDecls{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnSimplifierTooManyIterations{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnIllegalPatSynDecl{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnLinearPatSyn{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnMessage
TcRnEmptyRecordUpdate
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnIllegalFieldPunning{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnIllegalWildcardsInRecord{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnIllegalWildcardInType{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnDuplicateFieldName{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnIllegalViewPattern{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnCharLiteralOutOfRange{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnIllegalWildcardsInConstructor{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnIgnoringAnnotations{}
      -> DiagnosticReason
WarningWithoutFlag
    TcRnMessage
TcRnAnnotationInSafeHaskell
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnInvalidTypeApplication{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnMessage
TcRnTagToEnumMissingValArg
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnTagToEnumUnspecifiedResTy{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnTagToEnumResTyNotAnEnum{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnMessage
TcRnArrowIfThenElsePredDependsOnResultTy
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnMessage
TcRnIllegalHsBootFileDecl
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnRecursivePatternSynonym{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnPartialTypeSigTyVarMismatch{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnPartialTypeSigBadQuantifier{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnMissingSignature MissingSignature
what Exported
exported Bool
overridden
      -> WarningFlag -> DiagnosticReason
WarningWithFlag (WarningFlag -> DiagnosticReason)
-> WarningFlag -> DiagnosticReason
forall a b. (a -> b) -> a -> b
$ MissingSignature -> Exported -> Bool -> WarningFlag
missingSignatureWarningFlag MissingSignature
what Exported
exported Bool
overridden
    TcRnPolymorphicBinderMissingSig{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnMissingLocalSignatures
    TcRnOverloadedSig{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnTupleConstraintInst{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnAbstractClassInst{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnNoClassInstHead{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnUserTypeError{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnConstraintInKind{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnUnboxedTupleOrSumTypeFuncArg{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnLinearFuncInKind{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnForAllEscapeError{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnVDQInTermType{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnBadQuantPredHead{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnIllegalTupleConstraint{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnNonTypeVarArgInConstraint{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnIllegalImplicitParam{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnIllegalConstraintSynonymOfKind{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnIllegalClassInst{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnOversaturatedVisibleKindArg{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnBadAssociatedType{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnForAllRankErr{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnMonomorphicBindings{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnMonomorphism
    TcRnOrphanInstance{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnOrphans
    TcRnFunDepConflict{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnDupInstanceDecls{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnConflictingFamInstDecls{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnFamInstNotInjective{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnBangOnUnliftedType{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnRedundantStrictnessFlags
    TcRnMultipleDefaultDeclarations{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnBadDefaultType{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnPatSynBundledWithNonDataCon{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnPatSynBundledWithWrongType{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnDupeModuleExport{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnDuplicateExports
    TcRnExportedModNotImported{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnNullExportedModule{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnDodgyExports
    TcRnMissingExportList{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnMissingExportList
    TcRnExportHiddenComponents{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnDuplicateExport{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnDuplicateExports
    TcRnExportedParentChildMismatch{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnConflictingExports{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnAmbiguousField{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnAmbiguousFields
    TcRnMissingFields{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnMissingFields
    TcRnFieldUpdateInvalidType{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnNoConstructorHasAllFields{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnMixedSelectors{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnMissingStrictFields{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnNoPossibleParentForFields{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnBadOverloadedRecordUpdate{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnStaticFormNotClosed{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnMessage
TcRnUselessTypeable
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnDerivingTypeable
    TcRnDerivingDefaults{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnDerivingDefaults
    TcRnNonUnaryTypeclassConstraint{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnPartialTypeSignatures{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnPartialTypeSignatures
    TcRnCannotDeriveInstance Class
_ [Type]
_ Maybe (DerivStrategy GhcTc)
_ UsingGeneralizedNewtypeDeriving
_ DeriveInstanceErrReason
rea
      -> case DeriveInstanceErrReason
rea of
           DerivErrNotWellKinded{}                 -> DiagnosticReason
ErrorWithoutFlag
           DeriveInstanceErrReason
DerivErrSafeHaskellGenericInst          -> DiagnosticReason
ErrorWithoutFlag
           DerivErrDerivingViaWrongKind{}          -> DiagnosticReason
ErrorWithoutFlag
           DerivErrNoEtaReduce{}                   -> DiagnosticReason
ErrorWithoutFlag
           DeriveInstanceErrReason
DerivErrBootFileFound                   -> DiagnosticReason
ErrorWithoutFlag
           DerivErrDataConsNotAllInScope{}         -> DiagnosticReason
ErrorWithoutFlag
           DeriveInstanceErrReason
DerivErrGNDUsedOnData                   -> DiagnosticReason
ErrorWithoutFlag
           DeriveInstanceErrReason
DerivErrNullaryClasses                  -> DiagnosticReason
ErrorWithoutFlag
           DeriveInstanceErrReason
DerivErrLastArgMustBeApp                -> DiagnosticReason
ErrorWithoutFlag
           DerivErrNoFamilyInstance{}              -> DiagnosticReason
ErrorWithoutFlag
           DerivErrNotStockDeriveable{}            -> DiagnosticReason
ErrorWithoutFlag
           DerivErrHasAssociatedDatatypes{}        -> DiagnosticReason
ErrorWithoutFlag
           DeriveInstanceErrReason
DerivErrNewtypeNonDeriveableClass       -> DiagnosticReason
ErrorWithoutFlag
           DerivErrCannotEtaReduceEnough{}         -> DiagnosticReason
ErrorWithoutFlag
           DerivErrOnlyAnyClassDeriveable{}        -> DiagnosticReason
ErrorWithoutFlag
           DerivErrNotDeriveable{}                 -> DiagnosticReason
ErrorWithoutFlag
           DerivErrNotAClass{}                     -> DiagnosticReason
ErrorWithoutFlag
           DerivErrNoConstructors{}                -> DiagnosticReason
ErrorWithoutFlag
           DerivErrLangExtRequired{}               -> DiagnosticReason
ErrorWithoutFlag
           DerivErrDunnoHowToDeriveForType{}       -> DiagnosticReason
ErrorWithoutFlag
           DerivErrMustBeEnumType{}                -> DiagnosticReason
ErrorWithoutFlag
           DerivErrMustHaveExactlyOneConstructor{} -> DiagnosticReason
ErrorWithoutFlag
           DerivErrMustHaveSomeParameters{}        -> DiagnosticReason
ErrorWithoutFlag
           DerivErrMustNotHaveClassContext{}       -> DiagnosticReason
ErrorWithoutFlag
           DerivErrBadConstructor{}                -> DiagnosticReason
ErrorWithoutFlag
           DerivErrGenerics{}                      -> DiagnosticReason
ErrorWithoutFlag
           DerivErrEnumOrProduct{}                 -> DiagnosticReason
ErrorWithoutFlag
    TcRnMessage
TcRnLazyGADTPattern
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnMessage
TcRnArrowProcGADTPattern
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnSpecialClassInst {}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnForallIdentifier {}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnForallIdentifier
    TcRnMessage
TcRnTypeEqualityOutOfScope
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnTypeEqualityOutOfScope
    TcRnMessage
TcRnTypeEqualityRequiresOperators
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnTypeEqualityRequiresOperators
    TcRnIllegalTypeOperator {}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnGADTMonoLocalBinds {}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnGADTMonoLocalBinds
    TcRnIncorrectNameSpace {}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnNotInScope {}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnUntickedPromotedThing {}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnUntickedPromotedConstructors
    TcRnIllegalBuiltinSyntax {}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnWarnDefaulting {}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnTypeDefaults
    TcRnForeignImportPrimExtNotSet{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnForeignImportPrimSafeAnn{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnForeignFunctionImportAsValue{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnFunPtrImportWithoutAmpersand{}
      -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnDodgyForeignImports
    TcRnIllegalForeignDeclBackend{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnUnsupportedCallConv Either ForeignExport ForeignImport
_ UnsupportedCallConvention
unsupportedCC
      -> case UnsupportedCallConvention
unsupportedCC of
           UnsupportedCallConvention
StdCallConvUnsupported -> WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnUnsupportedCallingConventions
           UnsupportedCallConvention
_ -> DiagnosticReason
ErrorWithoutFlag
    TcRnIllegalForeignType{}
      -> DiagnosticReason
ErrorWithoutFlag
    TcRnInvalidCIdentifier{}
      -> DiagnosticReason
ErrorWithoutFlag

  diagnosticHints :: TcRnMessage -> [GhcHint]
diagnosticHints = \case
    TcRnUnknownMessage a
m
      -> a -> [GhcHint]
forall a. Diagnostic a => a -> [GhcHint]
diagnosticHints a
m
    TcRnMessageWithInfo UnitState
_ TcRnMessageDetailed
msg_with_info
      -> case TcRnMessageDetailed
msg_with_info of
           TcRnMessageDetailed ErrInfo
_ TcRnMessage
m -> TcRnMessage -> [GhcHint]
forall a. Diagnostic a => a -> [GhcHint]
diagnosticHints TcRnMessage
m
    TcRnSolverReport [SolverReportWithCtxt]
_ DiagnosticReason
_ [GhcHint]
hints
      -> [GhcHint]
hints
    TcRnRedundantConstraints{}
      -> [GhcHint]
noHints
    TcRnInaccessibleCode{}
      -> [GhcHint]
noHints
    TcRnTypeDoesNotHaveFixedRuntimeRep{}
      -> [GhcHint]
noHints
    TcRnImplicitLift{}
      -> [GhcHint]
noHints
    TcRnUnusedPatternBinds{}
      -> [GhcHint]
noHints
    TcRnDodgyImports{}
      -> [GhcHint]
noHints
    TcRnDodgyExports{}
      -> [GhcHint]
noHints
    TcRnMissingImportList{}
      -> [GhcHint]
noHints
    TcRnUnsafeDueToPlugin{}
      -> [GhcHint]
noHints
    TcRnModMissingRealSrcSpan{}
      -> [GhcHint]
noHints
    TcRnIdNotExportedFromModuleSig Name
name Module
mod
      -> [Name -> Maybe Module -> GhcHint
SuggestAddToHSigExportList Name
name (Maybe Module -> GhcHint) -> Maybe Module -> GhcHint
forall a b. (a -> b) -> a -> b
$ Module -> Maybe Module
forall a. a -> Maybe a
Just Module
mod]
    TcRnIdNotExportedFromLocalSig Name
name
      -> [Name -> Maybe Module -> GhcHint
SuggestAddToHSigExportList Name
name Maybe Module
forall a. Maybe a
Nothing]
    TcRnShadowedName{}
      -> [GhcHint]
noHints
    TcRnDuplicateWarningDecls{}
      -> [GhcHint]
noHints
    TcRnSimplifierTooManyIterations{}
      -> [GhcHint
SuggestIncreaseSimplifierIterations]
    TcRnIllegalPatSynDecl{}
      -> [GhcHint]
noHints
    TcRnLinearPatSyn{}
      -> [GhcHint]
noHints
    TcRnEmptyRecordUpdate{}
      -> [GhcHint]
noHints
    TcRnIllegalFieldPunning{}
      -> [Extension -> GhcHint
suggestExtension Extension
LangExt.NamedFieldPuns]
    TcRnIllegalWildcardsInRecord{}
      -> [Extension -> GhcHint
suggestExtension Extension
LangExt.RecordWildCards]
    TcRnIllegalWildcardInType{}
      -> [GhcHint]
noHints
    TcRnDuplicateFieldName{}
      -> [GhcHint]
noHints
    TcRnIllegalViewPattern{}
      -> [Extension -> GhcHint
suggestExtension Extension
LangExt.ViewPatterns]
    TcRnCharLiteralOutOfRange{}
      -> [GhcHint]
noHints
    TcRnIllegalWildcardsInConstructor{}
      -> [GhcHint]
noHints
    TcRnIgnoringAnnotations{}
      -> [GhcHint]
noHints
    TcRnMessage
TcRnAnnotationInSafeHaskell
      -> [GhcHint]
noHints
    TcRnInvalidTypeApplication{}
      -> [GhcHint]
noHints
    TcRnMessage
TcRnTagToEnumMissingValArg
      -> [GhcHint]
noHints
    TcRnTagToEnumUnspecifiedResTy{}
      -> [GhcHint]
noHints
    TcRnTagToEnumResTyNotAnEnum{}
      -> [GhcHint]
noHints
    TcRnMessage
TcRnArrowIfThenElsePredDependsOnResultTy
      -> [GhcHint]
noHints
    TcRnMessage
TcRnIllegalHsBootFileDecl
      -> [GhcHint]
noHints
    TcRnRecursivePatternSynonym{}
      -> [GhcHint]
noHints
    TcRnPartialTypeSigTyVarMismatch{}
      -> [GhcHint]
noHints
    TcRnPartialTypeSigBadQuantifier{}
      -> [GhcHint]
noHints
    TcRnMissingSignature {}
      -> [GhcHint]
noHints
    TcRnPolymorphicBinderMissingSig{}
      -> [GhcHint]
noHints
    TcRnOverloadedSig{}
      -> [GhcHint]
noHints
    TcRnTupleConstraintInst{}
      -> [GhcHint]
noHints
    TcRnAbstractClassInst{}
      -> [GhcHint]
noHints
    TcRnNoClassInstHead{}
      -> [GhcHint]
noHints
    TcRnUserTypeError{}
      -> [GhcHint]
noHints
    TcRnConstraintInKind{}
      -> [GhcHint]
noHints
    TcRnUnboxedTupleOrSumTypeFuncArg UnboxedTupleOrSum
tuple_or_sum Type
_
      -> [Extension -> GhcHint
suggestExtension (Extension -> GhcHint) -> Extension -> GhcHint
forall a b. (a -> b) -> a -> b
$ UnboxedTupleOrSum -> Extension
unboxedTupleOrSumExtension UnboxedTupleOrSum
tuple_or_sum]
    TcRnLinearFuncInKind{}
      -> [GhcHint]
noHints
    TcRnForAllEscapeError{}
      -> [GhcHint]
noHints
    TcRnVDQInTermType{}
      -> [GhcHint]
noHints
    TcRnBadQuantPredHead{}
      -> [GhcHint]
noHints
    TcRnIllegalTupleConstraint{}
      -> [Extension -> GhcHint
suggestExtension Extension
LangExt.ConstraintKinds]
    TcRnNonTypeVarArgInConstraint{}
      -> [Extension -> GhcHint
suggestExtension Extension
LangExt.FlexibleContexts]
    TcRnIllegalImplicitParam{}
      -> [GhcHint]
noHints
    TcRnIllegalConstraintSynonymOfKind{}
      -> [Extension -> GhcHint
suggestExtension Extension
LangExt.ConstraintKinds]
    TcRnIllegalClassInst{}
      -> [GhcHint]
noHints
    TcRnOversaturatedVisibleKindArg{}
      -> [GhcHint]
noHints
    TcRnBadAssociatedType{}
      -> [GhcHint]
noHints
    TcRnForAllRankErr Rank
rank Type
_
      -> case Rank
rank of
           LimitedRank{}      -> [Extension -> GhcHint
suggestExtension Extension
LangExt.RankNTypes]
           Rank
MonoTypeRankZero   -> [Extension -> GhcHint
suggestExtension Extension
LangExt.RankNTypes]
           Rank
MonoTypeTyConArg   -> [Extension -> GhcHint
suggestExtension Extension
LangExt.ImpredicativeTypes]
           Rank
MonoTypeSynArg     -> [Extension -> GhcHint
suggestExtension Extension
LangExt.LiberalTypeSynonyms]
           Rank
MonoTypeConstraint -> [Extension -> GhcHint
suggestExtension Extension
LangExt.QuantifiedConstraints]
           Rank
_                  -> [GhcHint]
noHints
    TcRnMonomorphicBindings [Name]
bindings
      -> case [Name]
bindings of
          []     -> [GhcHint]
noHints
          (Name
x:[Name]
xs) -> [AvailableBindings -> GhcHint
SuggestAddTypeSignatures (AvailableBindings -> GhcHint) -> AvailableBindings -> GhcHint
forall a b. (a -> b) -> a -> b
$ NonEmpty Name -> AvailableBindings
NamedBindings (Name
x Name -> [Name] -> NonEmpty Name
forall a. a -> [a] -> NonEmpty a
NE.:| [Name]
xs)]
    TcRnOrphanInstance{}
      -> [GhcHint
SuggestFixOrphanInstance]
    TcRnFunDepConflict{}
      -> [GhcHint]
noHints
    TcRnDupInstanceDecls{}
      -> [GhcHint]
noHints
    TcRnConflictingFamInstDecls{}
      -> [GhcHint]
noHints
    TcRnFamInstNotInjective InjectivityErrReason
rea TyCon
_ NonEmpty CoAxBranch
_
      -> case InjectivityErrReason
rea of
           InjErrRhsBareTyVar{}      -> [GhcHint]
noHints
           InjectivityErrReason
InjErrRhsCannotBeATypeFam -> [GhcHint]
noHints
           InjectivityErrReason
InjErrRhsOverlap          -> [GhcHint]
noHints
           InjErrCannotInferFromRhs TyVarSet
_ HasKinds
_ SuggestUndecidableInstances
suggestUndInst
             | SuggestUndecidableInstances
YesSuggestUndecidableInstaces <- SuggestUndecidableInstances
suggestUndInst
             -> [Extension -> GhcHint
suggestExtension Extension
LangExt.UndecidableInstances]
             | Bool
otherwise
             -> [GhcHint]
noHints
    TcRnBangOnUnliftedType{}
      -> [GhcHint]
noHints
    TcRnMultipleDefaultDeclarations{}
      -> [GhcHint]
noHints
    TcRnBadDefaultType{}
      -> [GhcHint]
noHints
    TcRnPatSynBundledWithNonDataCon{}
      -> [GhcHint]
noHints
    TcRnPatSynBundledWithWrongType{}
      -> [GhcHint]
noHints
    TcRnDupeModuleExport{}
      -> [GhcHint]
noHints
    TcRnExportedModNotImported{}
      -> [GhcHint]
noHints
    TcRnNullExportedModule{}
      -> [GhcHint]
noHints
    TcRnMissingExportList{}
      -> [GhcHint]
noHints
    TcRnExportHiddenComponents{}
      -> [GhcHint]
noHints
    TcRnDuplicateExport{}
      -> [GhcHint]
noHints
    TcRnExportedParentChildMismatch{}
      -> [GhcHint]
noHints
    TcRnConflictingExports{}
      -> [GhcHint]
noHints
    TcRnAmbiguousField{}
      -> [GhcHint]
noHints
    TcRnMissingFields{}
      -> [GhcHint]
noHints
    TcRnFieldUpdateInvalidType{}
      -> [GhcHint]
noHints
    TcRnNoConstructorHasAllFields{}
      -> [GhcHint]
noHints
    TcRnMixedSelectors{}
      -> [GhcHint]
noHints
    TcRnMissingStrictFields{}
      -> [GhcHint]
noHints
    TcRnNoPossibleParentForFields{}
      -> [GhcHint]
noHints
    TcRnBadOverloadedRecordUpdate{}
      -> [GhcHint]
noHints
    TcRnStaticFormNotClosed{}
      -> [GhcHint]
noHints
    TcRnMessage
TcRnUselessTypeable
      -> [GhcHint]
noHints
    TcRnDerivingDefaults{}
      -> [GhcHint
useDerivingStrategies]
    TcRnNonUnaryTypeclassConstraint{}
      -> [GhcHint]
noHints
    TcRnPartialTypeSignatures SuggestPartialTypeSignatures
suggestParSig [Type]
_
      -> case SuggestPartialTypeSignatures
suggestParSig of
           SuggestPartialTypeSignatures
YesSuggestPartialTypeSignatures
             -> let info :: SDoc
info = String -> SDoc
text String
"to use the inferred type"
                in [SDoc -> Extension -> GhcHint
suggestExtensionWithInfo SDoc
info Extension
LangExt.PartialTypeSignatures]
           SuggestPartialTypeSignatures
NoSuggestPartialTypeSignatures
             -> [GhcHint]
noHints
    TcRnCannotDeriveInstance Class
cls [Type]
_ Maybe (DerivStrategy GhcTc)
_ UsingGeneralizedNewtypeDeriving
newtype_deriving DeriveInstanceErrReason
rea
      -> Class
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> [GhcHint]
deriveInstanceErrReasonHints Class
cls UsingGeneralizedNewtypeDeriving
newtype_deriving DeriveInstanceErrReason
rea
    TcRnMessage
TcRnLazyGADTPattern
      -> [GhcHint]
noHints
    TcRnMessage
TcRnArrowProcGADTPattern
      -> [GhcHint]
noHints
    TcRnSpecialClassInst {}
      -> [GhcHint]
noHints
    TcRnForallIdentifier {}
      -> [GhcHint
SuggestRenameForall]
    TcRnMessage
TcRnTypeEqualityOutOfScope
      -> [GhcHint]
noHints
    TcRnMessage
TcRnTypeEqualityRequiresOperators
      -> [Extension -> GhcHint
suggestExtension Extension
LangExt.TypeOperators]
    TcRnIllegalTypeOperator {}
      -> [Extension -> GhcHint
suggestExtension Extension
LangExt.TypeOperators]
    TcRnGADTMonoLocalBinds {}
      -> [[Extension] -> GhcHint
suggestAnyExtension [Extension
LangExt.GADTs, Extension
LangExt.TypeFamilies]]
    TcRnIncorrectNameSpace Name
nm Bool
is_th_use
      | Bool
is_th_use
      -> [NameSpace -> GhcHint
SuggestAppropriateTHTick (NameSpace -> GhcHint) -> NameSpace -> GhcHint
forall a b. (a -> b) -> a -> b
$ Name -> NameSpace
nameNameSpace Name
nm]
      | Bool
otherwise
      -> [GhcHint]
noHints
    TcRnNotInScope NotInScopeError
err RdrName
_ [ImportError]
_ [GhcHint]
hints
      -> NotInScopeError -> [GhcHint]
scopeErrorHints NotInScopeError
err [GhcHint] -> [GhcHint] -> [GhcHint]
forall a. [a] -> [a] -> [a]
++ [GhcHint]
hints
    TcRnUntickedPromotedThing UntickedPromotedThing
thing
      -> [UntickedPromotedThing -> GhcHint
SuggestAddTick UntickedPromotedThing
thing]
    TcRnIllegalBuiltinSyntax {}
      -> [GhcHint]
noHints
    TcRnWarnDefaulting {}
      -> [GhcHint]
noHints
    TcRnForeignImportPrimExtNotSet{}
      -> [Extension -> GhcHint
suggestExtension Extension
LangExt.GHCForeignImportPrim]
    TcRnForeignImportPrimSafeAnn{}
      -> [GhcHint]
noHints
    TcRnForeignFunctionImportAsValue{}
      -> [GhcHint]
noHints
    TcRnFunPtrImportWithoutAmpersand{}
      -> [GhcHint]
noHints
    TcRnIllegalForeignDeclBackend{}
      -> [GhcHint]
noHints
    TcRnUnsupportedCallConv{}
      -> [GhcHint]
noHints
    TcRnIllegalForeignType Maybe ArgOrResult
_ IllegalForeignTypeReason
reason
      -> case IllegalForeignTypeReason
reason of
           TypeCannotBeMarshaled Type
_ TypeCannotBeMarshaledReason
why
             | NewtypeDataConNotInScope{} <- TypeCannotBeMarshaledReason
why -> [GhcHint
SuggestImportingDataCon]
             | TypeCannotBeMarshaledReason
UnliftedFFITypesNeeded <- TypeCannotBeMarshaledReason
why -> [Extension -> GhcHint
suggestExtension Extension
LangExt.UnliftedFFITypes]
           IllegalForeignTypeReason
_ -> [GhcHint]
noHints
    TcRnInvalidCIdentifier{}
      -> [GhcHint]
noHints

deriveInstanceErrReasonHints :: Class
                             -> UsingGeneralizedNewtypeDeriving
                             -> DeriveInstanceErrReason
                             -> [GhcHint]
deriveInstanceErrReasonHints :: Class
-> UsingGeneralizedNewtypeDeriving
-> DeriveInstanceErrReason
-> [GhcHint]
deriveInstanceErrReasonHints Class
cls UsingGeneralizedNewtypeDeriving
newtype_deriving = \case
  DerivErrNotWellKinded TyCon
_ Type
_ Int
n_args_to_keep
    | Class
cls Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
gen1ClassKey Bool -> Bool -> Bool
&& Int
n_args_to_keep Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
    -> [Extension -> GhcHint
suggestExtension Extension
LangExt.PolyKinds]
    | Bool
otherwise
    -> [GhcHint]
noHints
  DeriveInstanceErrReason
DerivErrSafeHaskellGenericInst  -> [GhcHint]
noHints
  DerivErrDerivingViaWrongKind{}  -> [GhcHint]
noHints
  DerivErrNoEtaReduce{}           -> [GhcHint]
noHints
  DeriveInstanceErrReason
DerivErrBootFileFound           -> [GhcHint]
noHints
  DerivErrDataConsNotAllInScope{} -> [GhcHint]
noHints
  DeriveInstanceErrReason
DerivErrGNDUsedOnData           -> [GhcHint]
noHints
  DeriveInstanceErrReason
DerivErrNullaryClasses          -> [GhcHint]
noHints
  DeriveInstanceErrReason
DerivErrLastArgMustBeApp        -> [GhcHint]
noHints
  DerivErrNoFamilyInstance{}      -> [GhcHint]
noHints
  DerivErrNotStockDeriveable DeriveAnyClassEnabled
deriveAnyClassEnabled
    | DeriveAnyClassEnabled
deriveAnyClassEnabled DeriveAnyClassEnabled -> DeriveAnyClassEnabled -> Bool
forall a. Eq a => a -> a -> Bool
== DeriveAnyClassEnabled
NoDeriveAnyClassEnabled
    -> [Extension -> GhcHint
suggestExtension Extension
LangExt.DeriveAnyClass]
    | Bool
otherwise
    -> [GhcHint]
noHints
  DerivErrHasAssociatedDatatypes{}
    -> [GhcHint]
noHints
  DeriveInstanceErrReason
DerivErrNewtypeNonDeriveableClass
    | UsingGeneralizedNewtypeDeriving
newtype_deriving UsingGeneralizedNewtypeDeriving
-> UsingGeneralizedNewtypeDeriving -> Bool
forall a. Eq a => a -> a -> Bool
== UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving
    -> [GhcHint
useGND]
    | Bool
otherwise
    -> [GhcHint]
noHints
  DerivErrCannotEtaReduceEnough{}
    | UsingGeneralizedNewtypeDeriving
newtype_deriving UsingGeneralizedNewtypeDeriving
-> UsingGeneralizedNewtypeDeriving -> Bool
forall a. Eq a => a -> a -> Bool
== UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving
    -> [GhcHint
useGND]
    | Bool
otherwise
    -> [GhcHint]
noHints
  DerivErrOnlyAnyClassDeriveable TyCon
_ DeriveAnyClassEnabled
deriveAnyClassEnabled
    | DeriveAnyClassEnabled
deriveAnyClassEnabled DeriveAnyClassEnabled -> DeriveAnyClassEnabled -> Bool
forall a. Eq a => a -> a -> Bool
== DeriveAnyClassEnabled
NoDeriveAnyClassEnabled
    -> [Extension -> GhcHint
suggestExtension Extension
LangExt.DeriveAnyClass]
    | Bool
otherwise
    -> [GhcHint]
noHints
  DerivErrNotDeriveable DeriveAnyClassEnabled
deriveAnyClassEnabled
    | DeriveAnyClassEnabled
deriveAnyClassEnabled DeriveAnyClassEnabled -> DeriveAnyClassEnabled -> Bool
forall a. Eq a => a -> a -> Bool
== DeriveAnyClassEnabled
NoDeriveAnyClassEnabled
    -> [Extension -> GhcHint
suggestExtension Extension
LangExt.DeriveAnyClass]
    | Bool
otherwise
    -> [GhcHint]
noHints
  DerivErrNotAClass{}
    -> [GhcHint]
noHints
  DerivErrNoConstructors{}
    -> let info :: SDoc
info = String -> SDoc
text String
"to enable deriving for empty data types"
       in [SDoc -> Extension -> GhcHint
useExtensionInOrderTo SDoc
info Extension
LangExt.EmptyDataDeriving]
  DerivErrLangExtRequired{}
    -- This is a slightly weird corner case of GHC: we are failing
    -- to derive a typeclass instance because a particular 'Extension'
    -- is not enabled (and so we report in the main error), but here
    -- we don't want to /repeat/ to enable the extension in the hint.
    -> [GhcHint]
noHints
  DerivErrDunnoHowToDeriveForType{}
    -> [GhcHint]
noHints
  DerivErrMustBeEnumType TyCon
rep_tc
    -- We want to suggest GND only if this /is/ a newtype.
    | UsingGeneralizedNewtypeDeriving
newtype_deriving UsingGeneralizedNewtypeDeriving
-> UsingGeneralizedNewtypeDeriving -> Bool
forall a. Eq a => a -> a -> Bool
== UsingGeneralizedNewtypeDeriving
NoGeneralizedNewtypeDeriving Bool -> Bool -> Bool
&& TyCon -> Bool
isNewTyCon TyCon
rep_tc
    -> [GhcHint
useGND]
    | Bool
otherwise
    -> [GhcHint]
noHints
  DerivErrMustHaveExactlyOneConstructor{}
    -> [GhcHint]
noHints
  DerivErrMustHaveSomeParameters{}
    -> [GhcHint]
noHints
  DerivErrMustNotHaveClassContext{}
    -> [GhcHint]
noHints
  DerivErrBadConstructor Maybe HasWildcard
wcard [DeriveInstanceBadConstructor]
_
    -> case Maybe HasWildcard
wcard of
         Maybe HasWildcard
Nothing        -> [GhcHint]
noHints
         Just HasWildcard
YesHasWildcard -> [GhcHint
SuggestFillInWildcardConstraint]
         Just HasWildcard
NoHasWildcard  -> [GhcHint
SuggestAddStandaloneDerivation]
  DerivErrGenerics{}
    -> [GhcHint]
noHints
  DerivErrEnumOrProduct{}
    -> [GhcHint]
noHints

messageWithInfoDiagnosticMessage :: UnitState
                                 -> ErrInfo
                                 -> DecoratedSDoc
                                 -> DecoratedSDoc
messageWithInfoDiagnosticMessage :: UnitState -> ErrInfo -> DecoratedSDoc -> DecoratedSDoc
messageWithInfoDiagnosticMessage UnitState
unit_state ErrInfo{SDoc
errInfoContext :: ErrInfo -> SDoc
errInfoSupplementary :: ErrInfo -> SDoc
errInfoContext :: SDoc
errInfoSupplementary :: SDoc
..} DecoratedSDoc
important =
  let err_info' :: [SDoc]
err_info' = (SDoc -> SDoc) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
unit_state) [SDoc
errInfoContext, SDoc
errInfoSupplementary]
      in ((SDoc -> SDoc) -> DecoratedSDoc -> DecoratedSDoc
mapDecoratedSDoc (UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
unit_state) DecoratedSDoc
important) DecoratedSDoc -> DecoratedSDoc -> DecoratedSDoc
`unionDecoratedSDoc`
         [SDoc] -> DecoratedSDoc
mkDecorated [SDoc]
err_info'

dodgy_msg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc
dodgy_msg :: forall a b. (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc
dodgy_msg SDoc
kind a
tc b
ie
  = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> SDoc
kind SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"item"
                     SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (b -> SDoc
forall a. Outputable a => a -> SDoc
ppr b
ie)
                SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"suggests that",
          SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
tc) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has (in-scope) constructors or class methods,",
          String -> SDoc
text String
"but it has none" ]

dodgy_msg_insert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)
dodgy_msg_insert :: forall (p :: Pass). IdP (GhcPass p) -> IE (GhcPass p)
dodgy_msg_insert IdP (GhcPass p)
tc = XIEThingAll (GhcPass p)
-> LIEWrappedName (IdP (GhcPass p)) -> IE (GhcPass p)
forall pass.
XIEThingAll pass -> LIEWrappedName (IdP pass) -> IE pass
IEThingAll XIEThingAll (GhcPass p)
EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn LIEWrappedName (IdP (GhcPass p))
ii
  where
    ii :: LIEWrappedName (IdP (GhcPass p))
    ii :: LIEWrappedName (IdP (GhcPass p))
ii = IEWrappedName (IdGhcP p)
-> LocatedAn AnnListItem (IEWrappedName (IdGhcP p))
forall a an. a -> LocatedAn an a
noLocA (LocatedN (IdGhcP p) -> IEWrappedName (IdGhcP p)
forall name. LocatedN name -> IEWrappedName name
IEName (LocatedN (IdGhcP p) -> IEWrappedName (IdGhcP p))
-> LocatedN (IdGhcP p) -> IEWrappedName (IdGhcP p)
forall a b. (a -> b) -> a -> b
$ IdGhcP p -> LocatedN (IdGhcP p)
forall a an. a -> LocatedAn an a
noLocA IdP (GhcPass p)
IdGhcP p
tc)

pprTypeDoesNotHaveFixedRuntimeRep :: Type -> FixedRuntimeRepProvenance -> SDoc
pprTypeDoesNotHaveFixedRuntimeRep :: Type -> FixedRuntimeRepProvenance -> SDoc
pprTypeDoesNotHaveFixedRuntimeRep Type
ty FixedRuntimeRepProvenance
prov =
  let what :: SDoc
what = FixedRuntimeRepProvenance -> SDoc
pprFixedRuntimeRepProvenance FixedRuntimeRepProvenance
prov
  in String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"does not have a fixed runtime representation:"
  SDoc -> SDoc -> SDoc
$$ Type -> SDoc
format_frr_err Type
ty

format_frr_err :: Type  -- ^ the type which doesn't have a fixed runtime representation
                -> SDoc
format_frr_err :: Type -> SDoc
format_frr_err Type
ty
  = (SDoc
bullet SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
tidy_ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
tidy_ki)
  where
    (TidyEnv
tidy_env, Type
tidy_ty) = TidyEnv -> Type -> (TidyEnv, Type)
tidyOpenType TidyEnv
emptyTidyEnv Type
ty
    tidy_ki :: Type
tidy_ki             = TidyEnv -> Type -> Type
tidyType TidyEnv
tidy_env ((() :: Constraint) => Type -> Type
Type -> Type
tcTypeKind Type
ty)

pprField :: (FieldLabelString, TcType) -> SDoc
pprField :: (FieldLabelString, Type) -> SDoc
pprField (FieldLabelString
f,Type
ty) = FieldLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FieldLabelString
f SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty

pprRecordFieldPart :: RecordFieldPart -> SDoc
pprRecordFieldPart :: RecordFieldPart -> SDoc
pprRecordFieldPart = \case
  RecordFieldConstructor{} -> String -> SDoc
text String
"construction"
  RecordFieldPattern{}     -> String -> SDoc
text String
"pattern"
  RecordFieldPart
RecordFieldUpdate        -> String -> SDoc
text String
"update"

pprBindings :: [Name] -> SDoc
pprBindings :: [Name] -> SDoc
pprBindings = (Name -> SDoc) -> [Name] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas (SDoc -> SDoc
quotes (SDoc -> SDoc) -> (Name -> SDoc) -> Name -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr)

injectivityErrorHerald :: SDoc
injectivityErrorHerald :: SDoc
injectivityErrorHerald =
  String -> SDoc
text String
"Type family equation violates the family's injectivity annotation."

formatExportItemError :: SDoc -> String -> SDoc
formatExportItemError :: SDoc -> String -> SDoc
formatExportItemError SDoc
exportedThing String
reason =
  [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"The export item"
       , SDoc -> SDoc
quotes SDoc
exportedThing
       , String -> SDoc
text String
reason ]

-- | What warning flag is associated with the given missing signature?
missingSignatureWarningFlag :: MissingSignature -> Exported -> Bool -> WarningFlag
missingSignatureWarningFlag :: MissingSignature -> Exported -> Bool -> WarningFlag
missingSignatureWarningFlag (MissingTopLevelBindingSig {}) Exported
exported Bool
overridden
  | Exported
IsExported <- Exported
exported
  , Bool -> Bool
not Bool
overridden
  = WarningFlag
Opt_WarnMissingExportedSignatures
  | Bool
otherwise
  = WarningFlag
Opt_WarnMissingSignatures
missingSignatureWarningFlag (MissingPatSynSig {}) Exported
exported Bool
overridden
  | Exported
IsExported <- Exported
exported
  , Bool -> Bool
not Bool
overridden
  = WarningFlag
Opt_WarnMissingExportedPatternSynonymSignatures
  | Bool
otherwise
  = WarningFlag
Opt_WarnMissingPatternSynonymSignatures
missingSignatureWarningFlag (MissingTyConKindSig {}) Exported
_ Bool
_
  = WarningFlag
Opt_WarnMissingKindSignatures

useDerivingStrategies :: GhcHint
useDerivingStrategies :: GhcHint
useDerivingStrategies =
  SDoc -> Extension -> GhcHint
useExtensionInOrderTo (String -> SDoc
text String
"to pick a different strategy") Extension
LangExt.DerivingStrategies

useGND :: GhcHint
useGND :: GhcHint
useGND = let info :: SDoc
info = String -> SDoc
text String
"for GHC's" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"newtype-deriving extension"
         in SDoc -> Extension -> GhcHint
suggestExtensionWithInfo SDoc
info Extension
LangExt.GeneralizedNewtypeDeriving

cannotMakeDerivedInstanceHerald :: Class
                                -> [Type]
                                -> Maybe (DerivStrategy GhcTc)
                                -> UsingGeneralizedNewtypeDeriving
                                -> Bool -- ^ If False, only prints the why.
                                -> SDoc
                                -> SDoc
cannotMakeDerivedInstanceHerald :: Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_args Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald SDoc
why =
  if Bool
pprHerald
     then [SDoc] -> SDoc
sep [(SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Can't make a derived instance of")
                   Int
2 (SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred) SDoc -> SDoc -> SDoc
<+> SDoc
via_mechanism)
                SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
2 SDoc
extra) SDoc -> SDoc -> SDoc
<> SDoc
colon,
               Int -> SDoc -> SDoc
nest Int
2 SDoc
why]
      else SDoc
why
  where
    strat_used :: Bool
strat_used = Maybe (DerivStrategy GhcTc) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (DerivStrategy GhcTc)
mb_strat
    extra :: SDoc
extra | Bool -> Bool
not Bool
strat_used, (UsingGeneralizedNewtypeDeriving
newtype_deriving UsingGeneralizedNewtypeDeriving
-> UsingGeneralizedNewtypeDeriving -> Bool
forall a. Eq a => a -> a -> Bool
== UsingGeneralizedNewtypeDeriving
YesGeneralizedNewtypeDeriving)
          = String -> SDoc
text String
"(even with cunning GeneralizedNewtypeDeriving)"
          | Bool
otherwise = SDoc
empty
    pred :: Type
pred = Class -> [Type] -> Type
mkClassPred Class
cls [Type]
cls_args
    via_mechanism :: SDoc
via_mechanism | Bool
strat_used
                  , Just DerivStrategy GhcTc
strat <- Maybe (DerivStrategy GhcTc)
mb_strat
                  = String -> SDoc
text String
"with the" SDoc -> SDoc -> SDoc
<+> (DerivStrategy GhcTc -> SDoc
forall a. DerivStrategy a -> SDoc
derivStrategyName DerivStrategy GhcTc
strat) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"strategy"
                  | Bool
otherwise
                  = SDoc
empty

badCon :: DataCon -> SDoc -> SDoc
badCon :: DataCon -> SDoc -> SDoc
badCon DataCon
con SDoc
msg = String -> SDoc
text String
"Constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con) SDoc -> SDoc -> SDoc
<+> SDoc
msg

derivErrDiagnosticMessage :: Class
                          -> [Type]
                          -> Maybe (DerivStrategy GhcTc)
                          -> UsingGeneralizedNewtypeDeriving
                          -> Bool -- If True, includes the herald \"can't make a derived..\"
                          -> DeriveInstanceErrReason
                          -> SDoc
derivErrDiagnosticMessage :: Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> DeriveInstanceErrReason
-> SDoc
derivErrDiagnosticMessage Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald = \case
  DerivErrNotWellKinded TyCon
tc Type
cls_kind Int
_
    -> [SDoc] -> SDoc
sep [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Cannot derive well-kinded instance of form"
                         SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> [Type] -> SDoc
pprClassPred Class
cls [Type]
cls_tys
                                       SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"...")))
                  Int
2 SDoc
empty
           , Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"Class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls)
                         SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"expects an argument of kind"
                         SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprKind Type
cls_kind))
           ]
  DeriveInstanceErrReason
DerivErrSafeHaskellGenericInst
    ->     String -> SDoc
text String
"Generic instances can only be derived in"
       SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"Safe Haskell using the stock strategy."
  DerivErrDerivingViaWrongKind Type
cls_kind Type
via_ty Type
via_kind
    -> SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Cannot derive instance via" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprType Type
via_ty))
          Int
2 (String -> SDoc
text String
"Class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls)
                  SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"expects an argument of kind"
                  SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprKind Type
cls_kind) SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
','
         SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
"but" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprType Type
via_ty)
                  SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has kind" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprKind Type
via_kind))
  DerivErrNoEtaReduce Type
inst_ty
    -> [SDoc] -> SDoc
sep [String -> SDoc
text String
"Cannot eta-reduce to an instance of form",
            Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"instance (...) =>"
                   SDoc -> SDoc -> SDoc
<+> Class -> [Type] -> SDoc
pprClassPred Class
cls ([Type]
cls_tys [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type
inst_ty]))]
  DeriveInstanceErrReason
DerivErrBootFileFound
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
         (String -> SDoc
text String
"Cannot derive instances in hs-boot files"
          SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
"Write an instance declaration instead")
  DerivErrDataConsNotAllInScope TyCon
tc
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
         (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"The data constructors of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"are not all in scope")
            Int
2 (String -> SDoc
text String
"so you cannot derive an instance for it"))
  DeriveInstanceErrReason
DerivErrGNDUsedOnData
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
         (String -> SDoc
text String
"GeneralizedNewtypeDeriving cannot be used on non-newtypes")
  DeriveInstanceErrReason
DerivErrNullaryClasses
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
         (String -> SDoc
text String
"Cannot derive instances for nullary classes")
  DeriveInstanceErrReason
DerivErrLastArgMustBeApp
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
         ( String -> SDoc
text String
"The last argument of the instance must be a"
         SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"data or newtype application")
  DerivErrNoFamilyInstance TyCon
tc [Type]
tc_args
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
         (String -> SDoc
text String
"No family instance for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> [Type] -> SDoc
pprTypeApp TyCon
tc [Type]
tc_args))
  DerivErrNotStockDeriveable DeriveAnyClassEnabled
_
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
         (SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not a stock derivable class (Eq, Show, etc.)")
  DerivErrHasAssociatedDatatypes HasAssociatedDataFamInsts
hasAdfs AssociatedTyLastVarInKind
at_last_cls_tv_in_kinds AssociatedTyNotParamOverLastTyVar
at_without_last_cls_tv
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
         (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat [ Bool -> SDoc -> SDoc
ppWhen (HasAssociatedDataFamInsts
hasAdfs HasAssociatedDataFamInsts -> HasAssociatedDataFamInsts -> Bool
forall a. Eq a => a -> a -> Bool
== HasAssociatedDataFamInsts
YesHasAdfs) SDoc
adfs_msg
               , case AssociatedTyNotParamOverLastTyVar
at_without_last_cls_tv of
                    YesAssociatedTyNotParamOverLastTyVar TyCon
tc -> TyCon -> SDoc
at_without_last_cls_tv_msg TyCon
tc
                    AssociatedTyNotParamOverLastTyVar
NoAssociatedTyNotParamOverLastTyVar     -> SDoc
empty
               , case AssociatedTyLastVarInKind
at_last_cls_tv_in_kinds of
                   YesAssocTyLastVarInKind TyCon
tc -> TyCon -> SDoc
at_last_cls_tv_in_kinds_msg TyCon
tc
                   AssociatedTyLastVarInKind
NoAssocTyLastVarInKind     -> SDoc
empty
               ]
       where

         adfs_msg :: SDoc
adfs_msg  = String -> SDoc
text String
"the class has associated data types"

         at_without_last_cls_tv_msg :: TyCon -> SDoc
at_without_last_cls_tv_msg TyCon
at_tc = SDoc -> Int -> SDoc -> SDoc
hang
           (String -> SDoc
text String
"the associated type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
at_tc)
            SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not parameterized over the last type variable")
           Int
2 (String -> SDoc
text String
"of the class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls))

         at_last_cls_tv_in_kinds_msg :: TyCon -> SDoc
at_last_cls_tv_in_kinds_msg TyCon
at_tc = SDoc -> Int -> SDoc -> SDoc
hang
           (String -> SDoc
text String
"the associated type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
at_tc)
            SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"contains the last type variable")
          Int
2 (String -> SDoc
text String
"of the class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls)
            SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"in a kind, which is not (yet) allowed")
  DeriveInstanceErrReason
DerivErrNewtypeNonDeriveableClass
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> DeriveInstanceErrReason
-> SDoc
derivErrDiagnosticMessage Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald (DeriveAnyClassEnabled -> DeriveInstanceErrReason
DerivErrNotStockDeriveable DeriveAnyClassEnabled
NoDeriveAnyClassEnabled)
  DerivErrCannotEtaReduceEnough Bool
eta_ok
    -> let cant_derive_err :: SDoc
cant_derive_err = Bool -> SDoc -> SDoc
ppUnless Bool
eta_ok SDoc
eta_msg
           eta_msg :: SDoc
eta_msg = String -> SDoc
text String
"cannot eta-reduce the representation type enough"
       in Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
          SDoc
cant_derive_err
  DerivErrOnlyAnyClassDeriveable TyCon
tc DeriveAnyClassEnabled
_
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
         (SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is a type class,"
                          SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"and can only have a derived instance"
                          SDoc -> SDoc -> SDoc
$+$ String -> SDoc
text String
"if DeriveAnyClass is enabled")
  DerivErrNotDeriveable DeriveAnyClassEnabled
_
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald SDoc
empty
  DerivErrNotAClass Type
predType
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
         (SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
predType) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not a class")
  DerivErrNoConstructors TyCon
rep_tc
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
         (SDoc -> SDoc
quotes (TyCon -> SDoc
pprSourceTyCon TyCon
rep_tc) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"must have at least one data constructor")
  DerivErrLangExtRequired Extension
ext
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
         (String -> SDoc
text String
"You need " SDoc -> SDoc -> SDoc
<> Extension -> SDoc
forall a. Outputable a => a -> SDoc
ppr Extension
ext
            SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"to derive an instance for this class")
  DerivErrDunnoHowToDeriveForType Type
ty
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
        (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Don't know how to derive" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls))
              Int
2 (String -> SDoc
text String
"for type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)))
  DerivErrMustBeEnumType TyCon
rep_tc
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
         ([SDoc] -> SDoc
sep [ SDoc -> SDoc
quotes (TyCon -> SDoc
pprSourceTyCon TyCon
rep_tc) SDoc -> SDoc -> SDoc
<+>
                String -> SDoc
text String
"must be an enumeration type"
              , String -> SDoc
text String
"(an enumeration consists of one or more nullary, non-GADT constructors)" ])

  DerivErrMustHaveExactlyOneConstructor TyCon
rep_tc
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
         (SDoc -> SDoc
quotes (TyCon -> SDoc
pprSourceTyCon TyCon
rep_tc) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"must have precisely one constructor")
  DerivErrMustHaveSomeParameters TyCon
rep_tc
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
         (String -> SDoc
text String
"Data type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
rep_tc) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"must have some type parameters")
  DerivErrMustNotHaveClassContext TyCon
rep_tc [Type]
bad_stupid_theta
    -> Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
         (String -> SDoc
text String
"Data type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
rep_tc)
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"must not have a class context:" SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
pprTheta [Type]
bad_stupid_theta)
  DerivErrBadConstructor Maybe HasWildcard
_ [DeriveInstanceBadConstructor]
reasons
    -> let why :: SDoc
why = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (DeriveInstanceBadConstructor -> SDoc)
-> [DeriveInstanceBadConstructor] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map DeriveInstanceBadConstructor -> SDoc
renderReason [DeriveInstanceBadConstructor]
reasons
       in Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald SDoc
why
         where
           renderReason :: DeriveInstanceBadConstructor -> SDoc
renderReason = \case
                 DerivErrBadConExistential DataCon
con
                   -> DataCon -> SDoc -> SDoc
badCon DataCon
con (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"must be truly polymorphic in the last argument of the data type"
                 DerivErrBadConCovariant DataCon
con
                   -> DataCon -> SDoc -> SDoc
badCon DataCon
con (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"must not use the type variable in a function argument"
                 DerivErrBadConFunTypes DataCon
con
                   -> DataCon -> SDoc -> SDoc
badCon DataCon
con (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"must not contain function types"
                 DerivErrBadConWrongArg DataCon
con
                   -> DataCon -> SDoc -> SDoc
badCon DataCon
con (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"must use the type variable only as the last argument of a data type"
                 DerivErrBadConIsGADT DataCon
con
                   -> DataCon -> SDoc -> SDoc
badCon DataCon
con (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"is a GADT"
                 DerivErrBadConHasExistentials DataCon
con
                   -> DataCon -> SDoc -> SDoc
badCon DataCon
con (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"has existential type variables in its type"
                 DerivErrBadConHasConstraints DataCon
con
                   -> DataCon -> SDoc -> SDoc
badCon DataCon
con (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"has constraints in its type"
                 DerivErrBadConHasHigherRankType DataCon
con
                   -> DataCon -> SDoc -> SDoc
badCon DataCon
con (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"has a higher-rank type"
  DerivErrGenerics [DeriveGenericsErrReason]
reasons
    -> let why :: SDoc
why = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (DeriveGenericsErrReason -> SDoc)
-> [DeriveGenericsErrReason] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map DeriveGenericsErrReason -> SDoc
renderReason [DeriveGenericsErrReason]
reasons
       in Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald SDoc
why
         where
           renderReason :: DeriveGenericsErrReason -> SDoc
renderReason = \case
             DerivErrGenericsMustNotHaveDatatypeContext TyCon
tc_name
                -> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc_name SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"must not have a datatype context"
             DerivErrGenericsMustNotHaveExoticArgs DataCon
dc
                -> DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"must not have exotic unlifted or polymorphic arguments"
             DerivErrGenericsMustBeVanillaDataCon DataCon
dc
                -> DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"must be a vanilla data constructor"
             DerivErrGenericsMustHaveSomeTypeParams TyCon
rep_tc
                ->     String -> SDoc
text String
"Data type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
rep_tc)
                   SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"must have some type parameters"
             DerivErrGenericsMustNotHaveExistentials DataCon
con
               -> DataCon -> SDoc -> SDoc
badCon DataCon
con (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"must not have existential arguments"
             DerivErrGenericsWrongArgKind DataCon
con
               -> DataCon -> SDoc -> SDoc
badCon DataCon
con (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                    String -> SDoc
text String
"applies a type to an argument involving the last parameter"
                 SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"but the applied type is not of kind * -> *"
  DerivErrEnumOrProduct DeriveInstanceErrReason
this DeriveInstanceErrReason
that
    -> let ppr1 :: SDoc
ppr1 = Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> DeriveInstanceErrReason
-> SDoc
derivErrDiagnosticMessage Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
False DeriveInstanceErrReason
this
           ppr2 :: SDoc
ppr2 = Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> DeriveInstanceErrReason
-> SDoc
derivErrDiagnosticMessage Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
False DeriveInstanceErrReason
that
       in Class
-> [Type]
-> Maybe (DerivStrategy GhcTc)
-> UsingGeneralizedNewtypeDeriving
-> Bool
-> SDoc
-> SDoc
cannotMakeDerivedInstanceHerald Class
cls [Type]
cls_tys Maybe (DerivStrategy GhcTc)
mb_strat UsingGeneralizedNewtypeDeriving
newtype_deriving Bool
pprHerald
          (SDoc
ppr1 SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"  or" SDoc -> SDoc -> SDoc
$$ SDoc
ppr2)

{- *********************************************************************
*                                                                      *
              Outputable SolverReportErrCtxt (for debugging)
*                                                                      *
**********************************************************************-}

instance Outputable SolverReportErrCtxt where
  ppr :: SolverReportErrCtxt -> SDoc
ppr (CEC { cec_binds :: SolverReportErrCtxt -> EvBindsVar
cec_binds              = EvBindsVar
bvar
           , cec_defer_type_errors :: SolverReportErrCtxt -> DiagnosticReason
cec_defer_type_errors  = DiagnosticReason
dte
           , cec_expr_holes :: SolverReportErrCtxt -> DiagnosticReason
cec_expr_holes         = DiagnosticReason
eh
           , cec_type_holes :: SolverReportErrCtxt -> DiagnosticReason
cec_type_holes         = DiagnosticReason
th
           , cec_out_of_scope_holes :: SolverReportErrCtxt -> DiagnosticReason
cec_out_of_scope_holes = DiagnosticReason
osh
           , cec_warn_redundant :: SolverReportErrCtxt -> Bool
cec_warn_redundant     = Bool
wr
           , cec_expand_syns :: SolverReportErrCtxt -> Bool
cec_expand_syns        = Bool
es
           , cec_suppress :: SolverReportErrCtxt -> Bool
cec_suppress           = Bool
sup })
    = String -> SDoc
text String
"CEC" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
vcat
         [ String -> SDoc
text String
"cec_binds"              SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> EvBindsVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr EvBindsVar
bvar
         , String -> SDoc
text String
"cec_defer_type_errors"  SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> DiagnosticReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr DiagnosticReason
dte
         , String -> SDoc
text String
"cec_expr_holes"         SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> DiagnosticReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr DiagnosticReason
eh
         , String -> SDoc
text String
"cec_type_holes"         SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> DiagnosticReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr DiagnosticReason
th
         , String -> SDoc
text String
"cec_out_of_scope_holes" SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> DiagnosticReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr DiagnosticReason
osh
         , String -> SDoc
text String
"cec_warn_redundant"     SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
wr
         , String -> SDoc
text String
"cec_expand_syns"        SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
es
         , String -> SDoc
text String
"cec_suppress"           SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
sup ])

{- *********************************************************************
*                                                                      *
                    Outputting TcSolverReportMsg errors
*                                                                      *
**********************************************************************-}

-- | Pretty-print a 'SolverReportWithCtxt', containing a 'TcSolverReportMsg'
-- with its enclosing 'SolverReportErrCtxt'.
pprSolverReportWithCtxt :: SolverReportWithCtxt -> SDoc
pprSolverReportWithCtxt :: SolverReportWithCtxt -> SDoc
pprSolverReportWithCtxt (SolverReportWithCtxt { reportContext :: SolverReportWithCtxt -> SolverReportErrCtxt
reportContext = SolverReportErrCtxt
ctxt, reportContent :: SolverReportWithCtxt -> TcSolverReportMsg
reportContent = TcSolverReportMsg
msg })
   = SolverReportErrCtxt -> TcSolverReportMsg -> SDoc
pprTcSolverReportMsg SolverReportErrCtxt
ctxt TcSolverReportMsg
msg

-- | Pretty-print a 'TcSolverReportMsg', with its enclosing 'SolverReportErrCtxt'.
pprTcSolverReportMsg :: SolverReportErrCtxt -> TcSolverReportMsg -> SDoc
pprTcSolverReportMsg :: SolverReportErrCtxt -> TcSolverReportMsg -> SDoc
pprTcSolverReportMsg SolverReportErrCtxt
ctxt (TcReportWithInfo TcSolverReportMsg
msg (TcSolverReportInfo
info :| [TcSolverReportInfo]
infos)) =
  [SDoc] -> SDoc
vcat
    ( SolverReportErrCtxt -> TcSolverReportMsg -> SDoc
pprTcSolverReportMsg SolverReportErrCtxt
ctxt TcSolverReportMsg
msg
    SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: SolverReportErrCtxt -> TcSolverReportInfo -> SDoc
pprTcSolverReportInfo SolverReportErrCtxt
ctxt TcSolverReportInfo
info
    SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: (TcSolverReportInfo -> SDoc) -> [TcSolverReportInfo] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SolverReportErrCtxt -> TcSolverReportInfo -> SDoc
pprTcSolverReportInfo SolverReportErrCtxt
ctxt) [TcSolverReportInfo]
infos )
pprTcSolverReportMsg SolverReportErrCtxt
_ (BadTelescope TyVarBndrs
telescope [TcTyVar]
skols) =
  SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"These kind and type variables:" SDoc -> SDoc -> SDoc
<+> TyVarBndrs -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVarBndrs
telescope SDoc -> SDoc -> SDoc
$$
       String -> SDoc
text String
"are out of dependency order. Perhaps try this ordering:")
    Int
2 ([TcTyVar] -> SDoc
pprTyVars [TcTyVar]
sorted_tvs)
  where
    sorted_tvs :: [TcTyVar]
sorted_tvs = [TcTyVar] -> [TcTyVar]
scopedSort [TcTyVar]
skols
pprTcSolverReportMsg SolverReportErrCtxt
_ (UserTypeError Type
ty) =
  Type -> SDoc
pprUserTypeErrorTy Type
ty
pprTcSolverReportMsg SolverReportErrCtxt
ctxt (ReportHoleError Hole
hole HoleError
err) =
  SolverReportErrCtxt -> Hole -> HoleError -> SDoc
pprHoleError SolverReportErrCtxt
ctxt Hole
hole HoleError
err
pprTcSolverReportMsg SolverReportErrCtxt
_ (CannotUnifyWithPolytype ErrorItem
item TcTyVar
tv1 Type
ty2) =
  [SDoc] -> SDoc
vcat [ (if TcTyVar -> Bool
isSkolemTyVar TcTyVar
tv1
          then String -> SDoc
text String
"Cannot equate type variable"
          else String -> SDoc
text String
"Cannot instantiate unification variable")
         SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv1)
       , SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"with a" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"involving polytypes:") Int
2 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty2) ]
  where
    what :: SDoc
what = String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ TypeOrKind -> String
levelString (TypeOrKind -> String) -> TypeOrKind -> String
forall a b. (a -> b) -> a -> b
$
           CtLoc -> Maybe TypeOrKind
ctLocTypeOrKind_maybe (ErrorItem -> CtLoc
errorItemCtLoc ErrorItem
item) Maybe TypeOrKind -> TypeOrKind -> TypeOrKind
forall a. Maybe a -> a -> a
`orElse` TypeOrKind
TypeLevel
pprTcSolverReportMsg SolverReportErrCtxt
_
  (Mismatch { mismatch_ea :: TcSolverReportMsg -> Bool
mismatch_ea   = Bool
add_ea
            , mismatch_item :: TcSolverReportMsg -> ErrorItem
mismatch_item = ErrorItem
item
            , mismatch_ty1 :: TcSolverReportMsg -> Type
mismatch_ty1  = Type
ty1
            , mismatch_ty2 :: TcSolverReportMsg -> Type
mismatch_ty2  = Type
ty2 })
  = CtOrigin -> SDoc -> SDoc
addArising (ErrorItem -> CtOrigin
errorItemOrigin ErrorItem
item) SDoc
msg
  where
    msg :: SDoc
msg
      | (Type -> Bool
isLiftedRuntimeRep Type
ty1 Bool -> Bool -> Bool
&& Type -> Bool
isUnliftedRuntimeRep Type
ty2) Bool -> Bool -> Bool
||
        (Type -> Bool
isLiftedRuntimeRep Type
ty2 Bool -> Bool -> Bool
&& Type -> Bool
isUnliftedRuntimeRep Type
ty1) Bool -> Bool -> Bool
||
        (Type -> Bool
isLiftedLevity Type
ty1 Bool -> Bool -> Bool
&& Type -> Bool
isUnliftedLevity Type
ty2) Bool -> Bool -> Bool
||
        (Type -> Bool
isLiftedLevity Type
ty2 Bool -> Bool -> Bool
&& Type -> Bool
isUnliftedLevity Type
ty1)
      = String -> SDoc
text String
"Couldn't match a lifted type with an unlifted type"

      | Type -> Bool
isAtomicTy Type
ty1 Bool -> Bool -> Bool
|| Type -> Bool
isAtomicTy Type
ty2
      = -- Print with quotes
        [SDoc] -> SDoc
sep [ String -> SDoc
text String
herald1 SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty1)
            , Int -> SDoc -> SDoc
nest Int
padding (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
              String -> SDoc
text String
herald2 SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty2) ]

      | Bool
otherwise
      = -- Print with vertical layout
        [SDoc] -> SDoc
vcat [ String -> SDoc
text String
herald1 SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty1
             , Int -> SDoc -> SDoc
nest Int
padding (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
               String -> SDoc
text String
herald2 SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty2 ]

    herald1 :: String
herald1 = [String] -> String
conc [ String
"Couldn't match"
                   , if Bool
is_repr then String
"representation of" else String
""
                   , if Bool
add_ea then String
"expected"          else String
""
                   , String
what ]
    herald2 :: String
herald2 = [String] -> String
conc [ String
"with"
                   , if Bool
is_repr then String
"that of"          else String
""
                   , if