{-# 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"]
    TcRnCannotDefaultConcrete FixedRuntimeRepOrigin
frr
      -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> SDoc -> DecoratedSDoc
forall a b. (a -> b) -> a -> b
$
         FixedRuntimeRepContext -> SDoc
forall a. Outputable a => a -> SDoc
ppr (FixedRuntimeRepOrigin -> FixedRuntimeRepContext
frr_context FixedRuntimeRepOrigin
frr) SDoc -> SDoc -> SDoc
$$
         String -> SDoc
text String
"cannot be assigned a fixed runtime representation," SDoc -> SDoc -> SDoc
<+>
         String -> SDoc
text String
"not even by defaulting."

  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
    TcRnCannotDefaultConcrete{}
      -> 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
    TcRnCannotDefaultConcrete{}
      -> [AvailableBindings -> GhcHint
SuggestAddTypeSignatures AvailableBindings
UnnamedBinding]


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 Bool
add_ea then (String
"actual " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
what) else String
"" ]

    padding :: Int
padding = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
herald1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
herald2

    is_repr :: Bool
is_repr = case ErrorItem -> EqRel
errorItemEqRel ErrorItem
item of { EqRel
ReprEq -> Bool
True; EqRel
NomEq -> Bool
False }

    what :: String
what = TypeOrKind -> String
levelString (CtLoc -> Maybe TypeOrKind
ctLocTypeOrKind_maybe (ErrorItem -> CtLoc
errorItemCtLoc ErrorItem
item) Maybe TypeOrKind -> TypeOrKind -> TypeOrKind
forall a. Maybe a -> a -> a
`orElse` TypeOrKind
TypeLevel)

    conc :: [String] -> String
    conc :: [String] -> String
conc = (String -> String -> String) -> [String] -> String
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 String -> String -> String
add_space

    add_space :: String -> String -> String
    add_space :: String -> String -> String
add_space String
s1 String
s2 | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s1   = String
s2
                    | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s2   = String
s1
                    | Bool
otherwise = String
s1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s2)
pprTcSolverReportMsg SolverReportErrCtxt
_
  (KindMismatch { kmismatch_what :: TcSolverReportMsg -> TypedThing
kmismatch_what     = TypedThing
thing
                , kmismatch_expected :: TcSolverReportMsg -> Type
kmismatch_expected = Type
exp
                , kmismatch_actual :: TcSolverReportMsg -> Type
kmismatch_actual   = Type
act })
  = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Expected" SDoc -> SDoc -> SDoc
<+> SDoc
kind_desc SDoc -> SDoc -> SDoc
<> SDoc
comma)
      Int
2 (String -> SDoc
text String
"but" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TypedThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypedThing
thing) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has kind" SDoc -> SDoc -> SDoc
<+>
        SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
act))
  where
    kind_desc :: SDoc
kind_desc | Type -> Bool
tcIsConstraintKind Type
exp = String -> SDoc
text String
"a constraint"
              | Just Type
arg <- (() :: Constraint) => Type -> Maybe Type
Type -> Maybe Type
kindRep_maybe Type
exp  -- TYPE t0
              , Type -> Bool
tcIsTyVarTy Type
arg = (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocPrintExplicitRuntimeReps ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \case
                                   Bool
True  -> String -> SDoc
text String
"kind" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp)
                                   Bool
False -> String -> SDoc
text String
"a type"
              | Bool
otherwise       = String -> SDoc
text String
"kind" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp)


pprTcSolverReportMsg SolverReportErrCtxt
ctxt
  (TypeEqMismatch { teq_mismatch_ppr_explicit_kinds :: TcSolverReportMsg -> Bool
teq_mismatch_ppr_explicit_kinds = Bool
ppr_explicit_kinds
                  , teq_mismatch_item :: TcSolverReportMsg -> ErrorItem
teq_mismatch_item     = ErrorItem
item
                  , teq_mismatch_ty1 :: TcSolverReportMsg -> Type
teq_mismatch_ty1      = Type
ty1
                  , teq_mismatch_ty2 :: TcSolverReportMsg -> Type
teq_mismatch_ty2      = Type
ty2
                  , teq_mismatch_expected :: TcSolverReportMsg -> Type
teq_mismatch_expected = Type
exp
                  , teq_mismatch_actual :: TcSolverReportMsg -> Type
teq_mismatch_actual   = Type
act
                  , teq_mismatch_what :: TcSolverReportMsg -> Maybe TypedThing
teq_mismatch_what     = Maybe TypedThing
mb_thing })
  = CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Bool -> SDoc -> SDoc
pprWithExplicitKindsWhen Bool
ppr_explicit_kinds SDoc
msg
  where
    msg :: SDoc
msg
      | Type -> Bool
isUnliftedTypeKind Type
act, Type -> Bool
isLiftedTypeKind Type
exp
      = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"Expecting a lifted type, but"
            , Maybe TypedThing -> SDoc -> SDoc -> SDoc
forall {a}. Outputable a => Maybe a -> SDoc -> SDoc -> SDoc
thing_msg Maybe TypedThing
mb_thing (String -> SDoc
text String
"an") (String -> SDoc
text String
"unlifted") ]
      | Type -> Bool
isLiftedTypeKind Type
act, Type -> Bool
isUnliftedTypeKind Type
exp
      = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"Expecting an unlifted type, but"
            , Maybe TypedThing -> SDoc -> SDoc -> SDoc
forall {a}. Outputable a => Maybe a -> SDoc -> SDoc -> SDoc
thing_msg Maybe TypedThing
mb_thing (String -> SDoc
text String
"a") (String -> SDoc
text String
"lifted") ]
      | Type -> Bool
tcIsLiftedTypeKind Type
exp
      = SDoc
maybe_num_args_msg SDoc -> SDoc -> SDoc
$$
        [SDoc] -> SDoc
sep [ String -> SDoc
text String
"Expected a type, but"
            , case Maybe TypedThing
mb_thing of
                Maybe TypedThing
Nothing    -> String -> SDoc
text String
"found something with kind"
                Just TypedThing
thing -> SDoc -> SDoc
quotes (TypedThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypedThing
thing) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"has kind"
            , SDoc -> SDoc
quotes (Type -> SDoc
pprWithTYPE Type
act) ]
      | Just SDoc
nargs_msg <- Maybe SDoc
num_args_msg
      , Right TcSolverReportMsg
ea_msg <- SolverReportErrCtxt
-> Maybe ErrorItem
-> TypeOrKind
-> CtOrigin
-> Either [TcSolverReportInfo] TcSolverReportMsg
mk_ea_msg SolverReportErrCtxt
ctxt (ErrorItem -> Maybe ErrorItem
forall a. a -> Maybe a
Just ErrorItem
item) TypeOrKind
level CtOrigin
orig
      = SDoc
nargs_msg SDoc -> SDoc -> SDoc
$$ SolverReportErrCtxt -> TcSolverReportMsg -> SDoc
pprTcSolverReportMsg SolverReportErrCtxt
ctxt TcSolverReportMsg
ea_msg
      | -- pprTrace "check" (ppr ea_looks_same $$ ppr exp $$ ppr act $$ ppr ty1 $$ ppr ty2) $
        Type -> Type -> Type -> Type -> Bool
ea_looks_same Type
ty1 Type
ty2 Type
exp Type
act
      , Right TcSolverReportMsg
ea_msg <- SolverReportErrCtxt
-> Maybe ErrorItem
-> TypeOrKind
-> CtOrigin
-> Either [TcSolverReportInfo] TcSolverReportMsg
mk_ea_msg SolverReportErrCtxt
ctxt (ErrorItem -> Maybe ErrorItem
forall a. a -> Maybe a
Just ErrorItem
item) TypeOrKind
level CtOrigin
orig
      = SolverReportErrCtxt -> TcSolverReportMsg -> SDoc
pprTcSolverReportMsg SolverReportErrCtxt
ctxt TcSolverReportMsg
ea_msg
      -- The mismatched types are /inside/ exp and act
      | let mismatch_err :: TcSolverReportMsg
mismatch_err = Bool -> ErrorItem -> Type -> Type -> TcSolverReportMsg
Mismatch Bool
False ErrorItem
item Type
ty1 Type
ty2
            errs :: [TcSolverReportMsg]
errs = case SolverReportErrCtxt
-> Maybe ErrorItem
-> TypeOrKind
-> CtOrigin
-> Either [TcSolverReportInfo] TcSolverReportMsg
mk_ea_msg SolverReportErrCtxt
ctxt Maybe ErrorItem
forall a. Maybe a
Nothing TypeOrKind
level CtOrigin
orig of
              Left [TcSolverReportInfo]
ea_info -> [ TcSolverReportMsg -> [TcSolverReportInfo] -> TcSolverReportMsg
mkTcReportWithInfo TcSolverReportMsg
mismatch_err [TcSolverReportInfo]
ea_info ]
              Right TcSolverReportMsg
ea_err -> [ TcSolverReportMsg
mismatch_err, TcSolverReportMsg
ea_err ]
      = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (TcSolverReportMsg -> SDoc) -> [TcSolverReportMsg] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SolverReportErrCtxt -> TcSolverReportMsg -> SDoc
pprTcSolverReportMsg SolverReportErrCtxt
ctxt) [TcSolverReportMsg]
errs

    ct_loc :: CtLoc
ct_loc = ErrorItem -> CtLoc
errorItemCtLoc ErrorItem
item
    orig :: CtOrigin
orig   = ErrorItem -> CtOrigin
errorItemOrigin ErrorItem
item
    level :: TypeOrKind
level  = CtLoc -> Maybe TypeOrKind
ctLocTypeOrKind_maybe CtLoc
ct_loc Maybe TypeOrKind -> TypeOrKind -> TypeOrKind
forall a. Maybe a -> a -> a
`orElse` TypeOrKind
TypeLevel

    thing_msg :: Maybe a -> SDoc -> SDoc -> SDoc
thing_msg (Just a
thing) SDoc
_  SDoc
levity = SDoc -> SDoc
quotes (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
thing) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is" SDoc -> SDoc -> SDoc
<+> SDoc
levity
    thing_msg Maybe a
Nothing      SDoc
an SDoc
levity = String -> SDoc
text String
"got" SDoc -> SDoc -> SDoc
<+> SDoc
an SDoc -> SDoc -> SDoc
<+> SDoc
levity SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"type"

    num_args_msg :: Maybe SDoc
num_args_msg = case TypeOrKind
level of
      TypeOrKind
KindLevel
        | Bool -> Bool
not (Type -> Bool
isMetaTyVarTy Type
exp) Bool -> Bool -> Bool
&& Bool -> Bool
not (Type -> Bool
isMetaTyVarTy Type
act)
           -- if one is a meta-tyvar, then it's possible that the user
           -- has asked for something impredicative, and we couldn't unify.
           -- Don't bother with counting arguments.
        -> let n_act :: Int
n_act = Type -> Int
count_args Type
act
               n_exp :: Int
n_exp = Type -> Int
count_args Type
exp in
           case Int
n_act Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n_exp of
             Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0   -- we don't know how many args there are, so don't
                         -- recommend removing args that aren't
               , Just TypedThing
thing <- Maybe TypedThing
mb_thing
               -> SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ SolverReportErrCtxt -> TcSolverReportMsg -> SDoc
pprTcSolverReportMsg SolverReportErrCtxt
ctxt (Int -> TypedThing -> TcSolverReportMsg
ExpectingMoreArguments Int
n TypedThing
thing)
             Int
_ -> Maybe SDoc
forall a. Maybe a
Nothing

      TypeOrKind
_ -> Maybe SDoc
forall a. Maybe a
Nothing

    maybe_num_args_msg :: SDoc
maybe_num_args_msg = Maybe SDoc
num_args_msg Maybe SDoc -> SDoc -> SDoc
forall a. Maybe a -> a -> a
`orElse` SDoc
empty

    count_args :: Type -> Int
count_args Type
ty = (TyCoBinder -> Bool) -> [TyCoBinder] -> Int
forall a. (a -> Bool) -> [a] -> Int
count TyCoBinder -> Bool
isVisibleBinder ([TyCoBinder] -> Int) -> [TyCoBinder] -> Int
forall a b. (a -> b) -> a -> b
$ ([TyCoBinder], Type) -> [TyCoBinder]
forall a b. (a, b) -> a
fst (([TyCoBinder], Type) -> [TyCoBinder])
-> ([TyCoBinder], Type) -> [TyCoBinder]
forall a b. (a -> b) -> a -> b
$ Type -> ([TyCoBinder], Type)
splitPiTys Type
ty
pprTcSolverReportMsg SolverReportErrCtxt
_ (FixedRuntimeRepError [FixedRuntimeRepErrorInfo]
frr_origs) =
  [SDoc] -> SDoc
vcat ((FixedRuntimeRepErrorInfo -> SDoc)
-> [FixedRuntimeRepErrorInfo] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map FixedRuntimeRepErrorInfo -> SDoc
make_msg [FixedRuntimeRepErrorInfo]
frr_origs)
  where
    -- Assemble the error message: pair up each origin with the corresponding type, e.g.
    --   • FixedRuntimeRep origin msg 1 ...
    --       a :: TYPE r1
    --   • FixedRuntimeRep origin msg 2 ...
    --       b :: TYPE r2
    make_msg :: FixedRuntimeRepErrorInfo -> SDoc
    make_msg :: FixedRuntimeRepErrorInfo -> SDoc
make_msg (FRR_Info { frr_info_origin :: FixedRuntimeRepErrorInfo -> FixedRuntimeRepOrigin
frr_info_origin =
                           FixedRuntimeRepOrigin
                             { frr_type :: FixedRuntimeRepOrigin -> Type
frr_type    = Type
ty
                             , frr_context :: FixedRuntimeRepOrigin -> FixedRuntimeRepContext
frr_context = FixedRuntimeRepContext
frr_ctxt }
                       , frr_info_not_concrete :: FixedRuntimeRepErrorInfo -> Maybe (TcTyVar, Type)
frr_info_not_concrete =
                         Maybe (TcTyVar, Type)
mb_not_conc }) =
      -- Add bullet points if there is more than one error.
      (if [FixedRuntimeRepErrorInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FixedRuntimeRepErrorInfo]
frr_origs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 then (SDoc
bullet SDoc -> SDoc -> SDoc
<+>) else SDoc -> SDoc
forall a. a -> a
id) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
        [SDoc] -> SDoc
vcat [ [SDoc] -> SDoc
sep [ FixedRuntimeRepContext -> SDoc
pprFixedRuntimeRepContext FixedRuntimeRepContext
frr_ctxt
                   , String -> SDoc
text String
"does not have a fixed runtime representation." ]
             , Type -> SDoc
type_printout Type
ty
             , case Maybe (TcTyVar, Type)
mb_not_conc of
                Maybe (TcTyVar, Type)
Nothing -> SDoc
empty
                Just (TcTyVar
conc_tv, Type
not_conc) ->
                  TcTyVar -> Type -> SDoc
unsolved_concrete_eq_explanation TcTyVar
conc_tv Type
not_conc ]

    -- Don't print out the type (only the kind), if the type includes
    -- a confusing cast, unless the user passed -fprint-explicit-coercions.
    --
    -- Example:
    --
    --   In T20363, we have a representation-polymorphism error with a type
    --   of the form
    --
    --     ( (# #) |> co ) :: TYPE NilRep
    --
    --   where NilRep is a nullary type family application which reduces to TupleRep '[].
    --   We prefer avoiding showing the cast to the user, but we also don't want to
    --   print the confusing:
    --
    --     (# #) :: TYPE NilRep
    --
    --  So in this case we simply don't print the type, only the kind.
    confusing_cast :: Type -> Bool
    confusing_cast :: Type -> Bool
confusing_cast Type
ty =
      case Type
ty of
        CastTy Type
inner_ty KindCoercion
_
          -- A confusing cast is one that is responsible
          -- for a representation-polymorphism error.
          -> Type -> Bool
isConcrete ((() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
inner_ty)
        Type
_ -> Bool
False

    type_printout :: Type -> SDoc
    type_printout :: Type -> SDoc
type_printout Type
ty =
      (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocPrintExplicitCoercions ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \ Bool
show_coercions ->
        if  Type -> Bool
confusing_cast Type
ty Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
show_coercions
        then [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Its kind is:"
                  , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Type -> SDoc
pprWithTYPE ((() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
ty)
                  , String -> SDoc
text String
"(Use -fprint-explicit-coercions to see the full type.)" ]
        else [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Its type is:"
                  , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprWithTYPE ((() :: Constraint) => Type -> Type
Type -> Type
typeKind Type
ty) ]

    unsolved_concrete_eq_explanation :: TcTyVar -> Type -> SDoc
    unsolved_concrete_eq_explanation :: TcTyVar -> Type -> SDoc
unsolved_concrete_eq_explanation TcTyVar
tv Type
not_conc =
          String -> SDoc
text String
"Cannot unify" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
not_conc)
      SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"with the type variable" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv)
      SDoc -> SDoc -> SDoc
$$  String -> SDoc
text String
"because it is not a concrete" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<> SDoc
dot
      where
        ki :: Type
ki = TcTyVar -> Type
tyVarKind TcTyVar
tv
        what :: SDoc
        what :: SDoc
what
          | Type -> Bool
isRuntimeRepTy Type
ki
          = SDoc -> SDoc
quotes (String -> SDoc
text String
"RuntimeRep")
          | Type -> Bool
isLevityTy Type
ki
          = SDoc -> SDoc
quotes (String -> SDoc
text String
"Levity")
          | Bool
otherwise
          = String -> SDoc
text String
"type"

pprTcSolverReportMsg SolverReportErrCtxt
_ (SkolemEscape ErrorItem
item Implication
implic [TcTyVar]
esc_skols) =
  let
    esc_doc :: SDoc
esc_doc = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"because" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"variable" SDoc -> SDoc -> SDoc
<> [TcTyVar] -> SDoc
forall a. [a] -> SDoc
plural [TcTyVar]
esc_skols
                SDoc -> SDoc -> SDoc
<+> [TcTyVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [TcTyVar]
esc_skols
              , String -> SDoc
text String
"would escape" SDoc -> SDoc -> SDoc
<+>
                if [TcTyVar] -> Bool
forall a. [a] -> Bool
isSingleton [TcTyVar]
esc_skols then String -> SDoc
text String
"its scope"
                                         else String -> SDoc
text String
"their scope" ]
  in
  [SDoc] -> SDoc
vcat [ Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc
esc_doc
       , [SDoc] -> SDoc
sep [ (if [TcTyVar] -> Bool
forall a. [a] -> Bool
isSingleton [TcTyVar]
esc_skols
                then String -> SDoc
text String
"This (rigid, skolem)" SDoc -> SDoc -> SDoc
<+>
                     SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"variable is"
                else String -> SDoc
text String
"These (rigid, skolem)" SDoc -> SDoc -> SDoc
<+>
                     SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"variables are")
         SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"bound by"
       , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ SkolemInfoAnon -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Implication -> SkolemInfoAnon
ic_info Implication
implic)
       , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"at" SDoc -> SDoc -> SDoc
<+>
         RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcLclEnv -> RealSrcSpan
getLclEnvLoc (Implication -> TcLclEnv
ic_env Implication
implic)) ] ]
  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
_ (UntouchableVariable TcTyVar
tv Implication
implic)
  | Implic { ic_given :: Implication -> [TcTyVar]
ic_given = [TcTyVar]
given, ic_info :: Implication -> SkolemInfoAnon
ic_info = SkolemInfoAnon
skol_info } <- Implication
implic
  = [SDoc] -> SDoc
sep [ SDoc -> SDoc
quotes (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is untouchable"
        , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"inside the constraints:" SDoc -> SDoc -> SDoc
<+> [TcTyVar] -> SDoc
pprEvVarTheta [TcTyVar]
given
        , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"bound by" SDoc -> SDoc -> SDoc
<+> SkolemInfoAnon -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfoAnon
skol_info
        , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"at" SDoc -> SDoc -> SDoc
<+>
          RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcLclEnv -> RealSrcSpan
getLclEnvLoc (Implication -> TcLclEnv
ic_env Implication
implic)) ]
pprTcSolverReportMsg SolverReportErrCtxt
_ (BlockedEquality ErrorItem
item) =
  [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Cannot use equality for substitution:")
           Int
2 (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ErrorItem -> Type
errorItemPred ErrorItem
item))
       , String -> SDoc
text String
"Doing so would be ill-kinded." ]
pprTcSolverReportMsg SolverReportErrCtxt
_ (ExpectingMoreArguments Int
n TypedThing
thing) =
  String -> SDoc
text String
"Expecting" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
speakN (Int -> Int
forall a. Num a => a -> a
abs Int
n) SDoc -> SDoc -> SDoc
<+>
    SDoc
more SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TypedThing -> SDoc
forall a. Outputable a => a -> SDoc
ppr TypedThing
thing)
  where
    more :: SDoc
more
     | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1    = String -> SDoc
text String
"more argument to"
     | Bool
otherwise = String -> SDoc
text String
"more arguments to" -- n > 1
pprTcSolverReportMsg SolverReportErrCtxt
ctxt (UnboundImplicitParams (ErrorItem
item :| [ErrorItem]
items)) =
  let givens :: [Implication]
givens = SolverReportErrCtxt -> [Implication]
getUserGivens SolverReportErrCtxt
ctxt
  in if [Implication] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Implication]
givens
     then CtOrigin -> SDoc -> SDoc
addArising (ErrorItem -> CtOrigin
errorItemOrigin ErrorItem
item) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
            [SDoc] -> SDoc
sep [ String -> SDoc
text String
"Unbound implicit parameter" SDoc -> SDoc -> SDoc
<> [Type] -> SDoc
forall a. [a] -> SDoc
plural [Type]
preds
                , Int -> SDoc -> SDoc
nest Int
2 ([Type] -> SDoc
pprParendTheta [Type]
preds) ]
     else SolverReportErrCtxt -> TcSolverReportMsg -> SDoc
pprTcSolverReportMsg SolverReportErrCtxt
ctxt ([Implication]
-> NonEmpty ErrorItem -> Maybe CND_Extra -> TcSolverReportMsg
CouldNotDeduce [Implication]
givens (ErrorItem
item ErrorItem -> [ErrorItem] -> NonEmpty ErrorItem
forall a. a -> [a] -> NonEmpty a
:| [ErrorItem]
items) Maybe CND_Extra
forall a. Maybe a
Nothing)
  where
    preds :: [Type]
preds = (ErrorItem -> Type) -> [ErrorItem] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ErrorItem -> Type
errorItemPred (ErrorItem
item ErrorItem -> [ErrorItem] -> [ErrorItem]
forall a. a -> [a] -> [a]
: [ErrorItem]
items)
pprTcSolverReportMsg SolverReportErrCtxt
ctxt (CouldNotDeduce [Implication]
useful_givens (ErrorItem
item :| [ErrorItem]
others) Maybe CND_Extra
mb_extra)
  = SDoc
main_msg SDoc -> SDoc -> SDoc
$$
     case Either [TcSolverReportInfo] TcSolverReportMsg
supplementary of
      Left [TcSolverReportInfo]
infos
        -> [SDoc] -> SDoc
vcat ((TcSolverReportInfo -> SDoc) -> [TcSolverReportInfo] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SolverReportErrCtxt -> TcSolverReportInfo -> SDoc
pprTcSolverReportInfo SolverReportErrCtxt
ctxt) [TcSolverReportInfo]
infos)
      Right TcSolverReportMsg
other_msg
        -> SolverReportErrCtxt -> TcSolverReportMsg -> SDoc
pprTcSolverReportMsg SolverReportErrCtxt
ctxt TcSolverReportMsg
other_msg
  where
    main_msg :: SDoc
main_msg
      | [Implication] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Implication]
useful_givens
      = CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig (SDoc
no_instance_msg SDoc -> SDoc -> SDoc
<+> SDoc
missing)
      | Bool
otherwise
      = [SDoc] -> SDoc
vcat (CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig (SDoc
no_deduce_msg SDoc -> SDoc -> SDoc
<+> SDoc
missing)
              SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [Implication] -> [SDoc]
pp_givens [Implication]
useful_givens)

    supplementary :: Either [TcSolverReportInfo] TcSolverReportMsg
supplementary = case Maybe CND_Extra
mb_extra of
      Maybe CND_Extra
Nothing
        -> [TcSolverReportInfo]
-> Either [TcSolverReportInfo] TcSolverReportMsg
forall a b. a -> Either a b
Left []
      Just (CND_Extra TypeOrKind
level Type
ty1 Type
ty2)
        -> SolverReportErrCtxt
-> TypeOrKind
-> Type
-> Type
-> CtOrigin
-> Either [TcSolverReportInfo] TcSolverReportMsg
mk_supplementary_ea_msg SolverReportErrCtxt
ctxt TypeOrKind
level Type
ty1 Type
ty2 CtOrigin
orig
    orig :: CtOrigin
orig = ErrorItem -> CtOrigin
errorItemOrigin ErrorItem
item
    wanteds :: [Type]
wanteds = (ErrorItem -> Type) -> [ErrorItem] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map ErrorItem -> Type
errorItemPred (ErrorItem
itemErrorItem -> [ErrorItem] -> [ErrorItem]
forall a. a -> [a] -> [a]
:[ErrorItem]
others)

    no_instance_msg :: SDoc
no_instance_msg =
      case [Type]
wanteds of
        [Type
wanted] | Just (TyCon
tc, [Type]
_) <- (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
wanted
                 -- Don't say "no instance" for a constraint such as "c" for a type variable c.
                 , TyCon -> Bool
isClassTyCon TyCon
tc -> String -> SDoc
text String
"No instance for"
        [Type]
_ -> String -> SDoc
text String
"Could not solve:"

    no_deduce_msg :: SDoc
no_deduce_msg =
      case [Type]
wanteds of
        [Type
_wanted] -> String -> SDoc
text String
"Could not deduce"
        [Type]
_         -> String -> SDoc
text String
"Could not deduce:"

    missing :: SDoc
missing =
      case [Type]
wanteds of
        [Type
wanted] -> Type -> SDoc
pprParendType Type
wanted
        [Type]
_        -> [Type] -> SDoc
pprTheta [Type]
wanteds

pprTcSolverReportMsg SolverReportErrCtxt
ctxt (AmbiguityPreventsSolvingCt ErrorItem
item ([TcTyVar], [TcTyVar])
ambigs) =
  SolverReportErrCtxt -> TcSolverReportInfo -> SDoc
pprTcSolverReportInfo SolverReportErrCtxt
ctxt (Bool -> ([TcTyVar], [TcTyVar]) -> TcSolverReportInfo
Ambiguity Bool
True ([TcTyVar], [TcTyVar])
ambigs) SDoc -> SDoc -> SDoc
<+>
  CtOrigin -> SDoc
pprArising (ErrorItem -> CtOrigin
errorItemOrigin ErrorItem
item) SDoc -> SDoc -> SDoc
$$
  String -> SDoc
text String
"prevents the constraint" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
pprParendType (Type -> SDoc) -> Type -> SDoc
forall a b. (a -> b) -> a -> b
$ ErrorItem -> Type
errorItemPred ErrorItem
item)
  SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"from being solved."
pprTcSolverReportMsg ctxt :: SolverReportErrCtxt
ctxt@(CEC {cec_encl :: SolverReportErrCtxt -> [Implication]
cec_encl = [Implication]
implics})
  (CannotResolveInstance ErrorItem
item [ClsInst]
unifiers [ClsInst]
candidates [ImportError]
imp_errs [GhcHint]
suggs RelevantBindings
binds)
  =
    [SDoc] -> SDoc
vcat
      [ SolverReportErrCtxt -> TcSolverReportMsg -> SDoc
pprTcSolverReportMsg SolverReportErrCtxt
ctxt TcSolverReportMsg
no_inst_msg
      , Int -> SDoc -> SDoc
nest Int
2 SDoc
extra_note
      , Maybe SDoc
mb_patsyn_prov Maybe SDoc -> SDoc -> SDoc
forall a. Maybe a -> a -> a
`orElse` SDoc
empty
      , Bool -> SDoc -> SDoc
ppWhen (Bool
has_ambigs Bool -> Bool -> Bool
&& Bool -> Bool
not ([ClsInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
unifiers Bool -> Bool -> Bool
&& [Implication] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Implication]
useful_givens))
        ([SDoc] -> SDoc
vcat [ Bool -> SDoc -> SDoc
ppUnless Bool
lead_with_ambig (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                  SolverReportErrCtxt -> TcSolverReportInfo -> SDoc
pprTcSolverReportInfo SolverReportErrCtxt
ctxt (Bool -> ([TcTyVar], [TcTyVar]) -> TcSolverReportInfo
Ambiguity Bool
False ([TcTyVar]
ambig_kvs, [TcTyVar]
ambig_tvs))
              , RelevantBindings -> SDoc
pprRelevantBindings RelevantBindings
binds
              , SDoc
potential_msg ])
      , Bool -> SDoc -> SDoc
ppWhen (Maybe SDoc -> Bool
forall a. Maybe a -> Bool
isNothing Maybe SDoc
mb_patsyn_prov) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
            -- Don't suggest fixes for the provided context of a pattern
            -- synonym; the right fix is to bind more in the pattern
        [SDoc] -> SDoc
show_fixes (Bool -> Type -> [Implication] -> [SDoc]
ctxtFixes Bool
has_ambigs Type
pred [Implication]
implics
                    [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [SDoc]
drv_fixes)
      , Bool -> SDoc -> SDoc
ppWhen (Bool -> Bool
not ([ClsInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
candidates))
        (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"There are instances for similar types:")
            Int
2 ([SDoc] -> SDoc
vcat ((ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ClsInst]
candidates)))
            -- See Note [Report candidate instances]
      , [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (ImportError -> SDoc) -> [ImportError] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ImportError -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ImportError]
imp_errs
      , [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (GhcHint -> SDoc) -> [GhcHint] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GhcHint -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GhcHint]
suggs ]
  where
    orig :: CtOrigin
orig          = ErrorItem -> CtOrigin
errorItemOrigin ErrorItem
item
    pred :: Type
pred          = ErrorItem -> Type
errorItemPred ErrorItem
item
    (Class
clas, [Type]
tys)   = (() :: Constraint) => Type -> (Class, [Type])
Type -> (Class, [Type])
getClassPredTys Type
pred
    -- See Note [Highlighting ambiguous type variables]
    ([TcTyVar]
ambig_kvs, [TcTyVar]
ambig_tvs) = Type -> ([TcTyVar], [TcTyVar])
ambigTkvsOfTy Type
pred
    ambigs :: [TcTyVar]
ambigs = [TcTyVar]
ambig_kvs [TcTyVar] -> [TcTyVar] -> [TcTyVar]
forall a. [a] -> [a] -> [a]
++ [TcTyVar]
ambig_tvs
    has_ambigs :: Bool
has_ambigs = Bool -> Bool
not ([TcTyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcTyVar]
ambigs)
    useful_givens :: [Implication]
useful_givens = CtOrigin -> [Implication] -> [Implication]
discardProvCtxtGivens CtOrigin
orig ([Implication] -> [Implication]
getUserGivensFromImplics [Implication]
implics)
         -- useful_givens are the enclosing implications with non-empty givens,
         -- modulo the horrid discardProvCtxtGivens
    lead_with_ambig :: Bool
lead_with_ambig = Bool -> Bool
not ([TcTyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcTyVar]
ambigs)
                   Bool -> Bool -> Bool
&& Bool -> Bool
not ((TcTyVar -> Bool) -> [TcTyVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TcTyVar -> Bool
isRuntimeUnkSkol [TcTyVar]
ambigs)
                   Bool -> Bool -> Bool
&& Bool -> Bool
not ([ClsInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
unifiers)
                   Bool -> Bool -> Bool
&& [Implication] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Implication]
useful_givens

    no_inst_msg :: TcSolverReportMsg
    no_inst_msg :: TcSolverReportMsg
no_inst_msg
      | Bool
lead_with_ambig
      = ErrorItem -> ([TcTyVar], [TcTyVar]) -> TcSolverReportMsg
AmbiguityPreventsSolvingCt ErrorItem
item ([TcTyVar]
ambig_kvs, [TcTyVar]
ambig_tvs)
      | Bool
otherwise
      = [Implication]
-> NonEmpty ErrorItem -> Maybe CND_Extra -> TcSolverReportMsg
CouldNotDeduce [Implication]
useful_givens (ErrorItem
item ErrorItem -> [ErrorItem] -> NonEmpty ErrorItem
forall a. a -> [a] -> NonEmpty a
:| []) Maybe CND_Extra
forall a. Maybe a
Nothing

    -- Report "potential instances" only when the constraint arises
    -- directly from the user's use of an overloaded function
    want_potential :: CtOrigin -> Bool
want_potential (TypeEqOrigin {}) = Bool
False
    want_potential CtOrigin
_                 = Bool
True

    potential_msg :: SDoc
potential_msg
      = Bool -> SDoc -> SDoc
ppWhen (Bool -> Bool
not ([ClsInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
unifiers) Bool -> Bool -> Bool
&& CtOrigin -> Bool
want_potential CtOrigin
orig) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
          SDoc
potential_hdr SDoc -> SDoc -> SDoc
$$
          PotentialInstances -> SDoc
potentialInstancesErrMsg (PotentialInstances { matches :: [ClsInst]
matches = [], [ClsInst]
unifiers :: [ClsInst]
unifiers :: [ClsInst]
unifiers })

    potential_hdr :: SDoc
potential_hdr
      = Bool -> SDoc -> SDoc
ppWhen Bool
lead_with_ambig (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
        String -> SDoc
text String
"Probable fix: use a type annotation to specify what"
        SDoc -> SDoc -> SDoc
<+> [TcTyVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [TcTyVar]
ambig_tvs SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"should be."

    mb_patsyn_prov :: Maybe SDoc
    mb_patsyn_prov :: Maybe SDoc
mb_patsyn_prov
      | Bool -> Bool
not Bool
lead_with_ambig
      , ProvCtxtOrigin PSB{ psb_def :: forall idL idR. PatSynBind idL idR -> LPat idR
psb_def = L SrcSpanAnnA
_ Pat GhcRn
pat } <- CtOrigin
orig
      = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"In other words, a successful match on the pattern"
                   , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Pat GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr Pat GhcRn
pat
                   , String -> SDoc
text String
"does not provide the constraint" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprParendType Type
pred ])
      | Bool
otherwise = Maybe SDoc
forall a. Maybe a
Nothing

    extra_note :: SDoc
extra_note | (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Type -> Bool
isFunTy (TyCon -> [Type] -> [Type]
filterOutInvisibleTypes (Class -> TyCon
classTyCon Class
clas) [Type]
tys)
               = String -> SDoc
text String
"(maybe you haven't applied a function to enough arguments?)"
               | Class -> Name
className Class
clas Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeableClassName  -- Avoid mysterious "No instance for (Typeable T)
               , [Type
_,Type
ty] <- [Type]
tys                        -- Look for (Typeable (k->*) (T k))
               , Just (TyCon
tc,[Type]
_) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
ty
               , Bool -> Bool
not (TyCon -> Bool
isTypeFamilyTyCon TyCon
tc)
               = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"GHC can't yet do polykinded")
                    Int
2 (String -> SDoc
text String
"Typeable" SDoc -> SDoc -> SDoc
<+>
                       SDoc -> SDoc
parens (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((() :: Constraint) => Type -> Type
Type -> Type
tcTypeKind Type
ty)))
               | Bool
otherwise
               = SDoc
empty

    drv_fixes :: [SDoc]
drv_fixes = case CtOrigin
orig of
                   CtOrigin
DerivClauseOrigin                  -> [Bool -> SDoc
drv_fix Bool
False]
                   CtOrigin
StandAloneDerivOrigin              -> [Bool -> SDoc
drv_fix Bool
True]
                   DerivOriginDC DataCon
_ Int
_       Bool
standalone -> [Bool -> SDoc
drv_fix Bool
standalone]
                   DerivOriginCoerce TcTyVar
_ Type
_ Type
_ Bool
standalone -> [Bool -> SDoc
drv_fix Bool
standalone]
                   CtOrigin
_                -> []

    drv_fix :: Bool -> SDoc
drv_fix Bool
standalone_wildcard
      | Bool
standalone_wildcard
      = String -> SDoc
text String
"fill in the wildcard constraint yourself"
      | Bool
otherwise
      = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"use a standalone 'deriving instance' declaration,")
           Int
2 (String -> SDoc
text String
"so you can specify the instance context yourself")

pprTcSolverReportMsg (CEC {cec_encl :: SolverReportErrCtxt -> [Implication]
cec_encl = [Implication]
implics}) (OverlappingInstances ErrorItem
item [ClsInst]
matches [ClsInst]
unifiers) =
  [SDoc] -> SDoc
vcat
    [ CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
        (String -> SDoc
text String
"Overlapping instances for"
        SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprType (Class -> [Type] -> Type
mkClassPred Class
clas [Type]
tys))
    , Bool -> SDoc -> SDoc
ppUnless ([SDoc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SDoc]
matching_givens) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                  [SDoc] -> SDoc
sep [String -> SDoc
text String
"Matching givens (or their superclasses):"
                      , Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat [SDoc]
matching_givens)]
    ,  PotentialInstances -> SDoc
potentialInstancesErrMsg
        (PotentialInstances { [ClsInst]
matches :: [ClsInst]
matches :: [ClsInst]
matches, [ClsInst]
unifiers :: [ClsInst]
unifiers :: [ClsInst]
unifiers })
    ,  Bool -> SDoc -> SDoc
ppWhen ([SDoc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SDoc]
matching_givens Bool -> Bool -> Bool
&& [ClsInst] -> Bool
forall a. [a] -> Bool
isSingleton [ClsInst]
matches Bool -> Bool -> Bool
&& [ClsInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
unifiers) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
       -- Intuitively, some given matched the wanted in their
       -- flattened or rewritten (from given equalities) form
       -- but the matcher can't figure that out because the
       -- constraints are non-flat and non-rewritten so we
       -- simply report back the whole given
       -- context. Accelerate Smart.hs showed this problem.
         [SDoc] -> SDoc
sep [ String -> SDoc
text String
"There exists a (perhaps superclass) match:"
             , Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat ([Implication] -> [SDoc]
pp_givens [Implication]
useful_givens))]

    ,  Bool -> SDoc -> SDoc
ppWhen ([ClsInst] -> Bool
forall a. [a] -> Bool
isSingleton [ClsInst]
matches) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
       SDoc -> SDoc
parens ([SDoc] -> SDoc
vcat [ Bool -> SDoc -> SDoc
ppUnless ([TcTyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcTyVar]
tyCoVars) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                        String -> SDoc
text String
"The choice depends on the instantiation of" SDoc -> SDoc -> SDoc
<+>
                          SDoc -> SDoc
quotes ((TcTyVar -> SDoc) -> [TcTyVar] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcTyVar]
tyCoVars)
                    , Bool -> SDoc -> SDoc
ppUnless ([TyCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyCon]
famTyCons) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                        if ([TcTyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcTyVar]
tyCoVars)
                          then
                            String -> SDoc
text String
"The choice depends on the result of evaluating" SDoc -> SDoc -> SDoc
<+>
                              SDoc -> SDoc
quotes ((TyCon -> SDoc) -> [TyCon] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCon]
famTyCons)
                          else
                            String -> SDoc
text String
"and the result of evaluating" SDoc -> SDoc -> SDoc
<+>
                              SDoc -> SDoc
quotes ((TyCon -> SDoc) -> [TyCon] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCon]
famTyCons)
                    , Bool -> SDoc -> SDoc
ppWhen ([SDoc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([SDoc]
matching_givens)) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                      [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"To pick the first instance above, use IncoherentInstances"
                           , String -> SDoc
text String
"when compiling the other instance declarations"]
               ])]
  where
    orig :: CtOrigin
orig            = ErrorItem -> CtOrigin
errorItemOrigin ErrorItem
item
    pred :: Type
pred            = ErrorItem -> Type
errorItemPred ErrorItem
item
    (Class
clas, [Type]
tys)     = (() :: Constraint) => Type -> (Class, [Type])
Type -> (Class, [Type])
getClassPredTys Type
pred
    tyCoVars :: [TcTyVar]
tyCoVars        = [Type] -> [TcTyVar]
tyCoVarsOfTypesList [Type]
tys
    famTyCons :: [TyCon]
famTyCons       = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isFamilyTyCon ([TyCon] -> [TyCon]) -> [TyCon] -> [TyCon]
forall a b. (a -> b) -> a -> b
$ (Type -> [TyCon]) -> [Type] -> [TyCon]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (UniqSet TyCon -> [TyCon]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet (UniqSet TyCon -> [TyCon])
-> (Type -> UniqSet TyCon) -> Type -> [TyCon]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> UniqSet TyCon
tyConsOfType) [Type]
tys
    useful_givens :: [Implication]
useful_givens   = CtOrigin -> [Implication] -> [Implication]
discardProvCtxtGivens CtOrigin
orig ([Implication] -> [Implication]
getUserGivensFromImplics [Implication]
implics)
    matching_givens :: [SDoc]
matching_givens = (Implication -> Maybe SDoc) -> [Implication] -> [SDoc]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Implication -> Maybe SDoc
matchable [Implication]
useful_givens
    matchable :: Implication -> Maybe SDoc
matchable implic :: Implication
implic@(Implic { ic_given :: Implication -> [TcTyVar]
ic_given = [TcTyVar]
evvars, ic_info :: Implication -> SkolemInfoAnon
ic_info = SkolemInfoAnon
skol_info })
      = case [Type]
ev_vars_matching of
             [] -> Maybe SDoc
forall a. Maybe a
Nothing
             [Type]
_  -> SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> Int -> SDoc -> SDoc
hang ([Type] -> SDoc
pprTheta [Type]
ev_vars_matching)
                            Int
2 ([SDoc] -> SDoc
sep [ String -> SDoc
text String
"bound by" SDoc -> SDoc -> SDoc
<+> SkolemInfoAnon -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfoAnon
skol_info
                                   , String -> SDoc
text String
"at" SDoc -> SDoc -> SDoc
<+>
                                     RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcLclEnv -> RealSrcSpan
getLclEnvLoc (Implication -> TcLclEnv
ic_env Implication
implic)) ])
        where ev_vars_matching :: [Type]
ev_vars_matching = [ Type
pred
                                 | TcTyVar
ev_var <- [TcTyVar]
evvars
                                 , let pred :: Type
pred = TcTyVar -> Type
evVarPred TcTyVar
ev_var
                                 , (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Type -> Bool
can_match (Type
pred Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
transSuperClasses Type
pred) ]
              can_match :: Type -> Bool
can_match Type
pred
                 = case Type -> Maybe (Class, [Type])
getClassPredTys_maybe Type
pred of
                     Just (Class
clas', [Type]
tys') -> Class
clas' Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
clas
                                          Bool -> Bool -> Bool
&& Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust ([Type] -> [Type] -> Maybe TCvSubst
tcMatchTys [Type]
tys [Type]
tys')
                     Maybe (Class, [Type])
Nothing -> Bool
False
pprTcSolverReportMsg SolverReportErrCtxt
_ (UnsafeOverlap ErrorItem
item [ClsInst]
matches [ClsInst]
unsafe_overlapped) =
  [SDoc] -> SDoc
vcat [ CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig (String -> SDoc
text String
"Unsafe overlapping instances for"
                  SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprType (Class -> [Type] -> Type
mkClassPred Class
clas [Type]
tys))
       , [SDoc] -> SDoc
sep [String -> SDoc
text String
"The matching instance is:",
              Int -> SDoc -> SDoc
nest Int
2 (ClsInst -> SDoc
pprInstance (ClsInst -> SDoc) -> ClsInst -> SDoc
forall a b. (a -> b) -> a -> b
$ [ClsInst] -> ClsInst
forall a. HasCallStack => [a] -> a
head [ClsInst]
matches)]
       , [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"It is compiled in a Safe module and as such can only"
              , String -> SDoc
text String
"overlap instances from the same module, however it"
              , String -> SDoc
text String
"overlaps the following instances from different" SDoc -> SDoc -> SDoc
<+>
                String -> SDoc
text String
"modules:"
              , Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat [[ClsInst] -> SDoc
pprInstances ([ClsInst] -> SDoc) -> [ClsInst] -> SDoc
forall a b. (a -> b) -> a -> b
$ [ClsInst]
unsafe_overlapped])
              ]
       ]
  where
    orig :: CtOrigin
orig        = ErrorItem -> CtOrigin
errorItemOrigin ErrorItem
item
    pred :: Type
pred        = ErrorItem -> Type
errorItemPred ErrorItem
item
    (Class
clas, [Type]
tys) = (() :: Constraint) => Type -> (Class, [Type])
Type -> (Class, [Type])
getClassPredTys Type
pred

{- *********************************************************************
*                                                                      *
                 Displaying potential instances
*                                                                      *
**********************************************************************-}

-- | Directly display the given matching and unifying instances,
-- with a header for each: `Matching instances`/`Potentially matching instances`.
pprPotentialInstances :: (ClsInst -> SDoc) -> PotentialInstances -> SDoc
pprPotentialInstances :: (ClsInst -> SDoc) -> PotentialInstances -> SDoc
pprPotentialInstances ClsInst -> SDoc
ppr_inst (PotentialInstances { [ClsInst]
matches :: PotentialInstances -> [ClsInst]
matches :: [ClsInst]
matches, [ClsInst]
unifiers :: PotentialInstances -> [ClsInst]
unifiers :: [ClsInst]
unifiers }) =
  [SDoc] -> SDoc
vcat
    [ Bool -> SDoc -> SDoc
ppWhen (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ClsInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
matches) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
       String -> SDoc
text String
"Matching instance" SDoc -> SDoc -> SDoc
<> [ClsInst] -> SDoc
forall a. [a] -> SDoc
plural [ClsInst]
matches SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
$$
         Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat ((ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> SDoc
ppr_inst [ClsInst]
matches))
    , Bool -> SDoc -> SDoc
ppWhen (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ClsInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
unifiers) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
        (String -> SDoc
text String
"Potentially matching instance" SDoc -> SDoc -> SDoc
<> [ClsInst] -> SDoc
forall a. [a] -> SDoc
plural [ClsInst]
unifiers SDoc -> SDoc -> SDoc
<> SDoc
colon) SDoc -> SDoc -> SDoc
$$
         Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat ((ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> SDoc
ppr_inst [ClsInst]
unifiers))
    ]

-- | Display a summary of available instances, omitting those involving
-- out-of-scope types, in order to explain why we couldn't solve a particular
-- constraint, e.g. due to instance overlap or out-of-scope types.
--
-- To directly display a collection of matching/unifying instances,
-- use 'pprPotentialInstances'.
potentialInstancesErrMsg :: PotentialInstances -> SDoc
-- See Note [Displaying potential instances]
potentialInstancesErrMsg :: PotentialInstances -> SDoc
potentialInstancesErrMsg PotentialInstances
potentials =
  (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocPrintPotentialInstances ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \Bool
print_insts ->
  (PprStyle -> SDoc) -> SDoc
getPprStyle ((PprStyle -> SDoc) -> SDoc) -> (PprStyle -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \PprStyle
sty ->
    PotentialInstances -> Bool -> PprStyle -> SDoc
potentials_msg_with_options PotentialInstances
potentials Bool
print_insts PprStyle
sty

-- | Display a summary of available instances, omitting out-of-scope ones.
--
-- Use 'potentialInstancesErrMsg' to automatically set the pretty-printing
-- options.
potentials_msg_with_options :: PotentialInstances
                            -> Bool -- ^ Whether to print /all/ potential instances
                            -> PprStyle
                            -> SDoc
potentials_msg_with_options :: PotentialInstances -> Bool -> PprStyle -> SDoc
potentials_msg_with_options
  (PotentialInstances { [ClsInst]
matches :: PotentialInstances -> [ClsInst]
matches :: [ClsInst]
matches, [ClsInst]
unifiers :: PotentialInstances -> [ClsInst]
unifiers :: [ClsInst]
unifiers })
  Bool
show_all_potentials PprStyle
sty
  | [ClsInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
matches Bool -> Bool -> Bool
&& [ClsInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
unifiers
  = SDoc
empty

  | [ClsInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
show_these_matches Bool -> Bool -> Bool
&& [ClsInst] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
show_these_unifiers
  = [SDoc] -> SDoc
vcat [ SDoc -> SDoc
not_in_scope_msg SDoc
empty
         , SDoc
flag_hint ]

  | Bool
otherwise
  = [SDoc] -> SDoc
vcat [ (ClsInst -> SDoc) -> PotentialInstances -> SDoc
pprPotentialInstances
            ClsInst -> SDoc
pprInstance -- print instance + location info
            (PotentialInstances
              { matches :: [ClsInst]
matches  = [ClsInst]
show_these_matches
              , unifiers :: [ClsInst]
unifiers = [ClsInst]
show_these_unifiers })
         , [ClsInst] -> SDoc
overlapping_but_not_more_specific_msg [ClsInst]
sorted_matches
         , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
           [ Bool -> SDoc -> SDoc
ppWhen (Int
n_in_scope_hidden Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
             String -> SDoc
text String
"...plus"
               SDoc -> SDoc -> SDoc
<+> Int -> SDoc -> SDoc
speakNOf Int
n_in_scope_hidden (String -> SDoc
text String
"other")
           , Bool -> SDoc -> SDoc
ppWhen (Int
not_in_scopes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
              SDoc -> SDoc
not_in_scope_msg (String -> SDoc
text String
"...plus")
           , SDoc
flag_hint ] ]
  where
    n_show_matches, n_show_unifiers :: Int
    n_show_matches :: Int
n_show_matches  = Int
3
    n_show_unifiers :: Int
n_show_unifiers = Int
2

    ([ClsInst]
in_scope_matches, [ClsInst]
not_in_scope_matches) = (ClsInst -> Bool) -> [ClsInst] -> ([ClsInst], [ClsInst])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ClsInst -> Bool
inst_in_scope [ClsInst]
matches
    ([ClsInst]
in_scope_unifiers, [ClsInst]
not_in_scope_unifiers) = (ClsInst -> Bool) -> [ClsInst] -> ([ClsInst], [ClsInst])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ClsInst -> Bool
inst_in_scope [ClsInst]
unifiers
    sorted_matches :: [ClsInst]
sorted_matches = (ClsInst -> ClsInst -> Ordering) -> [ClsInst] -> [ClsInst]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ClsInst -> ClsInst -> Ordering
fuzzyClsInstCmp [ClsInst]
in_scope_matches
    sorted_unifiers :: [ClsInst]
sorted_unifiers = (ClsInst -> ClsInst -> Ordering) -> [ClsInst] -> [ClsInst]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ClsInst -> ClsInst -> Ordering
fuzzyClsInstCmp [ClsInst]
in_scope_unifiers
    ([ClsInst]
show_these_matches, [ClsInst]
show_these_unifiers)
       | Bool
show_all_potentials = ([ClsInst]
sorted_matches, [ClsInst]
sorted_unifiers)
       | Bool
otherwise           = (Int -> [ClsInst] -> [ClsInst]
forall a. Int -> [a] -> [a]
take Int
n_show_matches  [ClsInst]
sorted_matches
                               ,Int -> [ClsInst] -> [ClsInst]
forall a. Int -> [a] -> [a]
take Int
n_show_unifiers [ClsInst]
sorted_unifiers)
    n_in_scope_hidden :: Int
n_in_scope_hidden
      = [ClsInst] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClsInst]
sorted_matches Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [ClsInst] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClsInst]
sorted_unifiers
      Int -> Int -> Int
forall a. Num a => a -> a -> a
- [ClsInst] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClsInst]
show_these_matches Int -> Int -> Int
forall a. Num a => a -> a -> a
- [ClsInst] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClsInst]
show_these_unifiers

       -- "in scope" means that all the type constructors
       -- are lexically in scope; these instances are likely
       -- to be more useful
    inst_in_scope :: ClsInst -> Bool
    inst_in_scope :: ClsInst -> Bool
inst_in_scope ClsInst
cls_inst = (Name -> Bool) -> NameSet -> Bool
nameSetAll Name -> Bool
name_in_scope (NameSet -> Bool) -> NameSet -> Bool
forall a b. (a -> b) -> a -> b
$
                             [Type] -> NameSet
orphNamesOfTypes (ClsInst -> [Type]
is_tys ClsInst
cls_inst)

    name_in_scope :: Name -> Bool
name_in_scope Name
name
      | Name -> Bool
pretendNameIsInScope Name
name
      = Bool
True -- E.g. (->); see Note [pretendNameIsInScope] in GHC.Builtin.Names
      | Just Module
mod <- Name -> Maybe Module
nameModule_maybe Name
name
      = QualifyName -> Bool
qual_in_scope (PprStyle -> QueryQualifyName
qualName PprStyle
sty Module
mod (Name -> OccName
nameOccName Name
name))
      | Bool
otherwise
      = Bool
True

    qual_in_scope :: QualifyName -> Bool
    qual_in_scope :: QualifyName -> Bool
qual_in_scope QualifyName
NameUnqual    = Bool
True
    qual_in_scope (NameQual {}) = Bool
True
    qual_in_scope QualifyName
_             = Bool
False

    not_in_scopes :: Int
    not_in_scopes :: Int
not_in_scopes = [ClsInst] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClsInst]
not_in_scope_matches Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [ClsInst] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ClsInst]
not_in_scope_unifiers

    not_in_scope_msg :: SDoc -> SDoc
not_in_scope_msg SDoc
herald =
      SDoc -> Int -> SDoc -> SDoc
hang (SDoc
herald SDoc -> SDoc -> SDoc
<+> Int -> SDoc -> SDoc
speakNOf Int
not_in_scopes (String -> SDoc
text String
"instance")
                     SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"involving out-of-scope types")
           Int
2 (Bool -> SDoc -> SDoc
ppWhen Bool
show_all_potentials (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
               (ClsInst -> SDoc) -> PotentialInstances -> SDoc
pprPotentialInstances
               ClsInst -> SDoc
pprInstanceHdr -- only print the header, not the instance location info
                 (PotentialInstances
                   { matches :: [ClsInst]
matches = [ClsInst]
not_in_scope_matches
                   , unifiers :: [ClsInst]
unifiers = [ClsInst]
not_in_scope_unifiers
                   }))

    flag_hint :: SDoc
flag_hint = Bool -> SDoc -> SDoc
ppUnless (Bool
show_all_potentials
                         Bool -> Bool -> Bool
|| ([ClsInst] -> [ClsInst] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [ClsInst]
show_these_matches [ClsInst]
matches
                             Bool -> Bool -> Bool
&& [ClsInst] -> [ClsInst] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [ClsInst]
show_these_unifiers [ClsInst]
unifiers)) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                String -> SDoc
text String
"(use -fprint-potential-instances to see them all)"

-- | Compute a message informing the user of any instances that are overlapped
-- but were not discarded because the instance overlapping them wasn't
-- strictly more specific.
overlapping_but_not_more_specific_msg :: [ClsInst] -> SDoc
overlapping_but_not_more_specific_msg :: [ClsInst] -> SDoc
overlapping_but_not_more_specific_msg [ClsInst]
insts
  -- Only print one example of "overlapping but not strictly more specific",
  -- to avoid information overload.
  | (ClsInst, ClsInst)
overlap : [(ClsInst, ClsInst)]
_ <- [(ClsInst, ClsInst)]
overlapping_but_not_more_specific
  = SDoc
overlap_header SDoc -> SDoc -> SDoc
$$ (ClsInst, ClsInst) -> SDoc
ppr_overlapping (ClsInst, ClsInst)
overlap
  | Bool
otherwise
  = SDoc
empty
    where
      overlap_header :: SDoc
      overlap_header :: SDoc
overlap_header
        | [(ClsInst, ClsInst)
_] <- [(ClsInst, ClsInst)]
overlapping_but_not_more_specific
        = String -> SDoc
text String
"An overlapping instance can only be chosen when it is strictly more specific."
        | Bool
otherwise
        = String -> SDoc
text String
"Overlapping instances can only be chosen when they are strictly more specific."
      overlapping_but_not_more_specific :: [(ClsInst, ClsInst)]
      overlapping_but_not_more_specific :: [(ClsInst, ClsInst)]
overlapping_but_not_more_specific
        = ((ClsInst, ClsInst) -> (ClsInst, ClsInst) -> Ordering)
-> [(ClsInst, ClsInst)] -> [(ClsInst, ClsInst)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
nubOrdBy (((ClsInst, ClsInst) -> TcTyVar)
-> (ClsInst, ClsInst) -> (ClsInst, ClsInst) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (ClsInst -> TcTyVar
is_dfun (ClsInst -> TcTyVar)
-> ((ClsInst, ClsInst) -> ClsInst) -> (ClsInst, ClsInst) -> TcTyVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClsInst, ClsInst) -> ClsInst
forall a b. (a, b) -> a
fst))
          [ (ClsInst
overlapper, ClsInst
overlappee)
          | [ClsInst]
these <- (ClsInst -> ClsInst -> Bool) -> [ClsInst] -> [[ClsInst]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Name -> Name -> Bool)
-> (ClsInst -> Name) -> ClsInst -> ClsInst -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ClsInst -> Name
is_cls_nm) [ClsInst]
insts
          -- Take all pairs of distinct instances...
          , ClsInst
one:[ClsInst]
others <- [ClsInst] -> [[ClsInst]]
forall a. [a] -> [[a]]
tails [ClsInst]
these -- if `these = [inst_1, inst_2, ...]`
          , ClsInst
other <- [ClsInst]
others           -- then we get pairs `(one, other) = (inst_i, inst_j)` with `i < j`
          -- ... such that one instance in the pair overlaps the other...
          , let mb_overlapping :: [(ClsInst, ClsInst)]
mb_overlapping
                  | OverlapMode -> Bool
hasOverlappingFlag (OverlapFlag -> OverlapMode
overlapMode (OverlapFlag -> OverlapMode) -> OverlapFlag -> OverlapMode
forall a b. (a -> b) -> a -> b
$ ClsInst -> OverlapFlag
is_flag ClsInst
one)
                  Bool -> Bool -> Bool
|| OverlapMode -> Bool
hasOverlappableFlag (OverlapFlag -> OverlapMode
overlapMode (OverlapFlag -> OverlapMode) -> OverlapFlag -> OverlapMode
forall a b. (a -> b) -> a -> b
$ ClsInst -> OverlapFlag
is_flag ClsInst
other)
                  = [(ClsInst
one, ClsInst
other)]
                  | OverlapMode -> Bool
hasOverlappingFlag (OverlapFlag -> OverlapMode
overlapMode (OverlapFlag -> OverlapMode) -> OverlapFlag -> OverlapMode
forall a b. (a -> b) -> a -> b
$ ClsInst -> OverlapFlag
is_flag ClsInst
other)
                  Bool -> Bool -> Bool
|| OverlapMode -> Bool
hasOverlappableFlag (OverlapFlag -> OverlapMode
overlapMode (OverlapFlag -> OverlapMode) -> OverlapFlag -> OverlapMode
forall a b. (a -> b) -> a -> b
$ ClsInst -> OverlapFlag
is_flag ClsInst
one)
                  = [(ClsInst
other, ClsInst
one)]
                  | Bool
otherwise
                  = []
          , (ClsInst
overlapper, ClsInst
overlappee) <- [(ClsInst, ClsInst)]
mb_overlapping
          -- ... but the overlapper is not more specific than the overlappee.
          , Bool -> Bool
not (ClsInst
overlapper ClsInst -> ClsInst -> Bool
`more_specific_than` ClsInst
overlappee)
          ]
      more_specific_than :: ClsInst -> ClsInst -> Bool
      ClsInst
is1 more_specific_than :: ClsInst -> ClsInst -> Bool
`more_specific_than` ClsInst
is2
        = Maybe TCvSubst -> Bool
forall a. Maybe a -> Bool
isJust ([Type] -> [Type] -> Maybe TCvSubst
tcMatchTys (ClsInst -> [Type]
is_tys ClsInst
is1) (ClsInst -> [Type]
is_tys ClsInst
is2))
      ppr_overlapping :: (ClsInst, ClsInst) -> SDoc
      ppr_overlapping :: (ClsInst, ClsInst) -> SDoc
ppr_overlapping (ClsInst
overlapper, ClsInst
overlappee)
        = String -> SDoc
text String
"The first instance that follows overlaps the second, but is not more specific than it:"
        SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> SDoc
pprInstanceHdr [ClsInst
overlapper, ClsInst
overlappee])

{- Note [Displaying potential instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When showing a list of instances for
  - overlapping instances (show ones that match)
  - no such instance (show ones that could match)
we want to give it a bit of structure.  Here's the plan

* Say that an instance is "in scope" if all of the
  type constructors it mentions are lexically in scope.
  These are the ones most likely to be useful to the programmer.

* Show at most n_show in-scope instances,
  and summarise the rest ("plus N others")

* Summarise the not-in-scope instances ("plus 4 not in scope")

* Add the flag -fshow-potential-instances which replaces the
  summary with the full list
-}

{- *********************************************************************
*                                                                      *
                    Outputting TcSolverReportInfo
*                                                                      *
**********************************************************************-}

-- | Pretty-print an informational message, to accompany a 'TcSolverReportMsg'.
pprTcSolverReportInfo :: SolverReportErrCtxt -> TcSolverReportInfo -> SDoc
pprTcSolverReportInfo :: SolverReportErrCtxt -> TcSolverReportInfo -> SDoc
pprTcSolverReportInfo SolverReportErrCtxt
_ (Ambiguity Bool
prepend_msg ([TcTyVar]
ambig_kvs, [TcTyVar]
ambig_tvs)) = SDoc
msg
  where

    msg :: SDoc
msg |  (TcTyVar -> Bool) -> [TcTyVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TcTyVar -> Bool
isRuntimeUnkSkol [TcTyVar]
ambig_kvs  -- See Note [Runtime skolems]
        Bool -> Bool -> Bool
|| (TcTyVar -> Bool) -> [TcTyVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TcTyVar -> Bool
isRuntimeUnkSkol [TcTyVar]
ambig_tvs
        = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"Cannot resolve unknown runtime type"
                 SDoc -> SDoc -> SDoc
<> [TcTyVar] -> SDoc
forall a. [a] -> SDoc
plural [TcTyVar]
ambig_tvs SDoc -> SDoc -> SDoc
<+> [TcTyVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [TcTyVar]
ambig_tvs
               , String -> SDoc
text String
"Use :print or :force to determine these types"]

        | Bool -> Bool
not ([TcTyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcTyVar]
ambig_tvs)
        = SDoc -> [TcTyVar] -> SDoc
pp_ambig (String -> SDoc
text String
"type") [TcTyVar]
ambig_tvs

        | Bool
otherwise
        = SDoc -> [TcTyVar] -> SDoc
pp_ambig (String -> SDoc
text String
"kind") [TcTyVar]
ambig_kvs

    pp_ambig :: SDoc -> [TcTyVar] -> SDoc
pp_ambig SDoc
what [TcTyVar]
tkvs
      | Bool
prepend_msg -- "Ambiguous type variable 't0'"
      = String -> SDoc
text String
"Ambiguous" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"variable"
        SDoc -> SDoc -> SDoc
<> [TcTyVar] -> SDoc
forall a. [a] -> SDoc
plural [TcTyVar]
tkvs SDoc -> SDoc -> SDoc
<+> [TcTyVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [TcTyVar]
tkvs

      | Bool
otherwise -- "The type variable 't0' is ambiguous"
      = String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"variable" SDoc -> SDoc -> SDoc
<> [TcTyVar] -> SDoc
forall a. [a] -> SDoc
plural [TcTyVar]
tkvs
        SDoc -> SDoc -> SDoc
<+> [TcTyVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [TcTyVar]
tkvs SDoc -> SDoc -> SDoc
<+> [TcTyVar] -> SDoc
forall a. [a] -> SDoc
isOrAre [TcTyVar]
tkvs SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"ambiguous"
pprTcSolverReportInfo SolverReportErrCtxt
ctxt (TyVarInfo TcTyVar
tv ) =
  case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
    SkolemTv SkolemInfo
sk_info TcLevel
_ Bool
_   -> SolverReportErrCtxt -> [(SkolemInfoAnon, [TcTyVar])] -> SDoc
pprSkols SolverReportErrCtxt
ctxt [(SkolemInfo -> SkolemInfoAnon
getSkolemInfo SkolemInfo
sk_info, [TcTyVar
tv])]
    RuntimeUnk {} -> SDoc -> SDoc
quotes (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is an interactive-debugger skolem"
    MetaTv {}     -> SDoc
empty
pprTcSolverReportInfo SolverReportErrCtxt
_ (NonInjectiveTyFam TyCon
tc) =
  String -> SDoc
text String
"NB:" 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 a non-injective type family"
pprTcSolverReportInfo SolverReportErrCtxt
_ (ReportCoercibleMsg CoercibleMsg
msg) =
  CoercibleMsg -> SDoc
pprCoercibleMsg CoercibleMsg
msg
pprTcSolverReportInfo SolverReportErrCtxt
_ (ExpectedActual { ea_expected :: TcSolverReportInfo -> Type
ea_expected = Type
exp, ea_actual :: TcSolverReportInfo -> Type
ea_actual = Type
act }) =
  [SDoc] -> SDoc
vcat
    [ String -> SDoc
text String
"Expected:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp
    , String -> SDoc
text String
"  Actual:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
act ]
pprTcSolverReportInfo SolverReportErrCtxt
_
  (ExpectedActualAfterTySynExpansion
    { ea_expanded_expected :: TcSolverReportInfo -> Type
ea_expanded_expected = Type
exp
    , ea_expanded_actual :: TcSolverReportInfo -> Type
ea_expanded_actual   = Type
act } )
  = [SDoc] -> SDoc
vcat
      [ String -> SDoc
text String
"Type synonyms expanded:"
      , String -> SDoc
text String
"Expected type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
exp
      , String -> SDoc
text String
"  Actual type:" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
act ]
pprTcSolverReportInfo SolverReportErrCtxt
ctxt (WhenMatching Type
cty1 Type
cty2 CtOrigin
sub_o Maybe TypeOrKind
mb_sub_t_or_k) =
  (SDocContext -> Bool) -> (Bool -> SDoc) -> SDoc
forall a. (SDocContext -> a) -> (a -> SDoc) -> SDoc
sdocOption SDocContext -> Bool
sdocPrintExplicitCoercions ((Bool -> SDoc) -> SDoc) -> (Bool -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \Bool
printExplicitCoercions ->
    if Bool
printExplicitCoercions
       Bool -> Bool -> Bool
|| Bool -> Bool
not (Type
cty1 Type -> Type -> Bool
`pickyEqType` Type
cty2)
      then [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"When matching" SDoc -> SDoc -> SDoc
<+> SDoc
sub_whats)
                      Int
2 ([SDoc] -> SDoc
vcat [ Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
cty1 SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+>
                               Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((() :: Constraint) => Type -> Type
Type -> Type
tcTypeKind Type
cty1)
                             , Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
cty2 SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+>
                               Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((() :: Constraint) => Type -> Type
Type -> Type
tcTypeKind Type
cty2) ])
                , SDoc
supplementary ]
      else String -> SDoc
text String
"When matching the kind of" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
cty1)
  where
    sub_t_or_k :: TypeOrKind
sub_t_or_k = Maybe TypeOrKind
mb_sub_t_or_k Maybe TypeOrKind -> TypeOrKind -> TypeOrKind
forall a. Maybe a -> a -> a
`orElse` TypeOrKind
TypeLevel
    sub_whats :: SDoc
sub_whats  = String -> SDoc
text (TypeOrKind -> String
levelString TypeOrKind
sub_t_or_k) SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
's'
    supplementary :: SDoc
supplementary =
      case SolverReportErrCtxt
-> TypeOrKind
-> Type
-> Type
-> CtOrigin
-> Either [TcSolverReportInfo] TcSolverReportMsg
mk_supplementary_ea_msg SolverReportErrCtxt
ctxt TypeOrKind
sub_t_or_k Type
cty1 Type
cty2 CtOrigin
sub_o of
        Left [TcSolverReportInfo]
infos -> [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (TcSolverReportInfo -> SDoc) -> [TcSolverReportInfo] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SolverReportErrCtxt -> TcSolverReportInfo -> SDoc
pprTcSolverReportInfo SolverReportErrCtxt
ctxt) [TcSolverReportInfo]
infos
        Right TcSolverReportMsg
msg  -> SolverReportErrCtxt -> TcSolverReportMsg -> SDoc
pprTcSolverReportMsg SolverReportErrCtxt
ctxt TcSolverReportMsg
msg
pprTcSolverReportInfo SolverReportErrCtxt
_ (SameOcc Bool
same_pkg Name
n1 Name
n2) =
  String -> SDoc
text String
"NB:" SDoc -> SDoc -> SDoc
<+> (Bool -> Name -> SDoc
ppr_from Bool
same_pkg Name
n1 SDoc -> SDoc -> SDoc
$$ Bool -> Name -> SDoc
ppr_from Bool
same_pkg Name
n2)
  where
    ppr_from :: Bool -> Name -> SDoc
ppr_from Bool
same_pkg Name
nm
      | SrcSpan -> Bool
isGoodSrcSpan SrcSpan
loc
      = SDoc -> Int -> SDoc -> SDoc
hang (SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
nm) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is defined at")
           Int
2 (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc)
      | Bool
otherwise  -- Imported things have an UnhelpfulSrcSpan
      = SDoc -> Int -> SDoc -> SDoc
hang (SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
nm))
           Int
2 ([SDoc] -> SDoc
sep [ String -> SDoc
text String
"is defined in" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
mod))
                  , Bool -> SDoc -> SDoc
ppUnless (Bool
same_pkg Bool -> Bool -> Bool
|| Unit
pkg Unit -> Unit -> Bool
forall a. Eq a => a -> a -> Bool
== Unit
mainUnit) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                    Int -> SDoc -> SDoc
nest Int
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"in package" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unit
pkg) ])
      where
        pkg :: Unit
pkg = Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod
        mod :: Module
mod = (() :: Constraint) => Name -> Module
Name -> Module
nameModule Name
nm
        loc :: SrcSpan
loc = Name -> SrcSpan
nameSrcSpan Name
nm
pprTcSolverReportInfo SolverReportErrCtxt
ctxt (OccursCheckInterestingTyVars (TcTyVar
tv :| [TcTyVar]
tvs)) =
  SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Type variable kinds:") Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
    [SDoc] -> SDoc
vcat ((TcTyVar -> SDoc) -> [TcTyVar] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (TcTyVar -> SDoc
tyvar_binding (TcTyVar -> SDoc) -> (TcTyVar -> TcTyVar) -> TcTyVar -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TidyEnv -> TcTyVar -> TcTyVar
tidyTyCoVarOcc (SolverReportErrCtxt -> TidyEnv
cec_tidy SolverReportErrCtxt
ctxt))
              (TcTyVar
tvTcTyVar -> [TcTyVar] -> [TcTyVar]
forall a. a -> [a] -> [a]
:[TcTyVar]
tvs))
  where
    tyvar_binding :: TcTyVar -> SDoc
tyvar_binding TcTyVar
tyvar = TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tyvar SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcTyVar -> Type
tyVarKind TcTyVar
tyvar)

pprCoercibleMsg :: CoercibleMsg -> SDoc
pprCoercibleMsg :: CoercibleMsg -> SDoc
pprCoercibleMsg (UnknownRoles Type
ty) =
  SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"NB: We cannot know what roles the parameters to" SDoc -> SDoc -> SDoc
<+>
          SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"have;")
       Int
2 (String -> SDoc
text String
"we must assume that the role is nominal")
pprCoercibleMsg (TyConIsAbstract TyCon
tc) =
  [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"NB: The type constructor"
       , SDoc -> SDoc
quotes (TyCon -> SDoc
pprSourceTyCon TyCon
tc)
       , String -> SDoc
text String
"is abstract" ]
pprCoercibleMsg (OutOfScopeNewtypeConstructor TyCon
tc DataCon
dc) =
  SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"The data constructor" 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
$ DataCon -> Name
dataConName DataCon
dc))
    Int
2 ([SDoc] -> SDoc
sep [ String -> SDoc
text String
"of newtype" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (TyCon -> SDoc
pprSourceTyCon TyCon
tc)
           , String -> SDoc
text String
"is not in scope" ])

{- *********************************************************************
*                                                                      *
                  Outputting HoleError messages
*                                                                      *
**********************************************************************-}

pprHoleError :: SolverReportErrCtxt -> Hole -> HoleError -> SDoc
pprHoleError :: SolverReportErrCtxt -> Hole -> HoleError -> SDoc
pprHoleError SolverReportErrCtxt
_ (Hole { Type
hole_ty :: Type
hole_ty :: Hole -> Type
hole_ty, hole_occ :: Hole -> OccName
hole_occ = OccName
occ }) (OutOfScopeHole [ImportError]
imp_errs)
  = SDoc
out_of_scope_msg 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)
  where
    herald :: SDoc
herald | OccName -> Bool
isDataOcc OccName
occ = String -> SDoc
text String
"Data constructor not in scope:"
           | Bool
otherwise     = String -> SDoc
text String
"Variable not in scope:"
    out_of_scope_msg :: SDoc
out_of_scope_msg -- Print v :: ty only if the type has structure
      | Bool
boring_type = SDoc -> Int -> SDoc -> SDoc
hang SDoc
herald Int
2 (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ)
      | Bool
otherwise   = SDoc -> Int -> SDoc -> SDoc
hang SDoc
herald Int
2 (OccName -> Type -> SDoc
pp_occ_with_type OccName
occ Type
hole_ty)
    boring_type :: Bool
boring_type = Type -> Bool
isTyVarTy Type
hole_ty
pprHoleError SolverReportErrCtxt
ctxt (Hole { Type
hole_ty :: Hole -> Type
hole_ty :: Type
hole_ty, OccName
hole_occ :: Hole -> OccName
hole_occ :: OccName
hole_occ}) (HoleError HoleSort
sort [TcTyVar]
other_tvs [(SkolemInfoAnon, [TcTyVar])]
hole_skol_info) =
  [SDoc] -> SDoc
vcat [ SDoc
hole_msg
       , SDoc
tyvars_msg
       , case HoleSort
sort of { ExprHole {} -> SDoc
expr_hole_hint; HoleSort
_ -> SDoc
type_hole_hint } ]

  where

    hole_msg :: SDoc
hole_msg = case HoleSort
sort of
      ExprHole {} ->
        SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Found hole:")
          Int
2 (OccName -> Type -> SDoc
pp_occ_with_type OccName
hole_occ Type
hole_ty)
      HoleSort
TypeHole ->
        SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Found type wildcard" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
hole_occ))
          Int
2 (String -> SDoc
text String
"standing for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes SDoc
pp_hole_type_with_kind)
      HoleSort
ConstraintHole ->
        SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Found extra-constraints wildcard standing for")
          Int
2 (SDoc -> SDoc
quotes (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Type -> SDoc
pprType Type
hole_ty)  -- always kind constraint

    hole_kind :: Type
hole_kind = (() :: Constraint) => Type -> Type
Type -> Type
tcTypeKind Type
hole_ty

    pp_hole_type_with_kind :: SDoc
pp_hole_type_with_kind
      | Type -> Bool
isLiftedTypeKind Type
hole_kind
        Bool -> Bool -> Bool
|| Type -> Bool
isCoVarType Type
hole_ty -- Don't print the kind of unlifted
                               -- equalities (#15039)
      = Type -> SDoc
pprType Type
hole_ty
      | Bool
otherwise
      = Type -> SDoc
pprType Type
hole_ty SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprKind Type
hole_kind

    tyvars :: [TcTyVar]
tyvars = Type -> [TcTyVar]
tyCoVarsOfTypeList Type
hole_ty
    tyvars_msg :: SDoc
tyvars_msg = Bool -> SDoc -> SDoc
ppUnless ([TcTyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcTyVar]
tyvars) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                 String -> SDoc
text String
"Where:" SDoc -> SDoc -> SDoc
<+> ([SDoc] -> SDoc
vcat ((TcTyVar -> SDoc) -> [TcTyVar] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TcTyVar -> SDoc
loc_msg [TcTyVar]
other_tvs)
                                    SDoc -> SDoc -> SDoc
$$ SolverReportErrCtxt -> [(SkolemInfoAnon, [TcTyVar])] -> SDoc
pprSkols SolverReportErrCtxt
ctxt [(SkolemInfoAnon, [TcTyVar])]
hole_skol_info)
                      -- Coercion variables can be free in the
                      -- hole, via kind casts
    expr_hole_hint :: SDoc
expr_hole_hint                       -- Give hint for, say,   f x = _x
         | FieldLabelString -> Int
lengthFS (OccName -> FieldLabelString
occNameFS OccName
hole_occ) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1  -- Don't give this hint for plain "_"
         = String -> SDoc
text String
"Or perhaps" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
hole_occ)
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is mis-spelled, or not in scope"
         | Bool
otherwise
         = SDoc
empty

    type_hole_hint :: SDoc
type_hole_hint
         | DiagnosticReason
ErrorWithoutFlag <- SolverReportErrCtxt -> DiagnosticReason
cec_type_holes SolverReportErrCtxt
ctxt
         = String -> SDoc
text String
"To use the inferred type, enable PartialTypeSignatures"
         | Bool
otherwise
         = SDoc
empty

    loc_msg :: TcTyVar -> SDoc
loc_msg TcTyVar
tv
       | TcTyVar -> Bool
isTyVar TcTyVar
tv
       = case TcTyVar -> TcTyVarDetails
tcTyVarDetails TcTyVar
tv of
           MetaTv {} -> SDoc -> SDoc
quotes (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is an ambiguous type variable"
           TcTyVarDetails
_         -> SDoc
empty  -- Skolems dealt with already
       | Bool
otherwise  -- A coercion variable can be free in the hole type
       = (SDocContext -> Bool) -> SDoc -> SDoc
ppWhenOption SDocContext -> Bool
sdocPrintExplicitCoercions (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
           SDoc -> SDoc
quotes (TcTyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTyVar
tv) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is a coercion variable"

pp_occ_with_type :: OccName -> Type -> SDoc
pp_occ_with_type :: OccName -> Type -> SDoc
pp_occ_with_type OccName
occ Type
hole_ty = SDoc -> Int -> SDoc -> SDoc
hang (OccName -> SDoc
forall a. OutputableBndr a => a -> SDoc
pprPrefixOcc OccName
occ) Int
2 (SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprType Type
hole_ty)

{- *********************************************************************
*                                                                      *
                  Outputting ScopeError messages
*                                                                      *
**********************************************************************-}

pprScopeError :: RdrName -> NotInScopeError -> SDoc
pprScopeError :: RdrName -> NotInScopeError -> SDoc
pprScopeError RdrName
rdr_name NotInScopeError
scope_err =
  case NotInScopeError
scope_err of
    NotInScope {} ->
      SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Not in scope:")
        Int
2 (SDoc
what SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
rdr_name))
    NoExactName Name
name ->
      String -> SDoc
text String
"The Name" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not in scope."
    SameName [GlobalRdrElt]
gres ->
      Bool -> SDoc -> SDoc -> SDoc
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([GlobalRdrElt] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [GlobalRdrElt]
gres Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (String -> SDoc
text String
"pprScopeError SameName: fewer than 2 elements" SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
2 ([GlobalRdrElt] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GlobalRdrElt]
gres))
      (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Same Name in multiple name-spaces:")
           Int
2 ([SDoc] -> SDoc
vcat ((Name -> SDoc) -> [Name] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> SDoc
pp_one [Name]
sorted_names))
      where
        sorted_names :: [Name]
sorted_names = (Name -> Name -> Ordering) -> [Name] -> [Name]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (SrcSpan -> SrcSpan -> Ordering
leftmost_smallest (SrcSpan -> SrcSpan -> Ordering)
-> (Name -> SrcSpan) -> Name -> Name -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Name -> SrcSpan
nameSrcSpan) ((GlobalRdrElt -> Name) -> [GlobalRdrElt] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map GlobalRdrElt -> Name
greMangledName [GlobalRdrElt]
gres)
        pp_one :: Name -> SDoc
pp_one Name
name
          = SDoc -> Int -> SDoc -> SDoc
hang (NameSpace -> SDoc
pprNameSpace (OccName -> NameSpace
occNameSpace (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
name))
                  SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<> SDoc
comma)
               Int
2 (String -> SDoc
text String
"declared at:" SDoc -> SDoc -> SDoc
<+> SrcLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> SrcLoc
nameSrcLoc Name
name))
    MissingBinding SDoc
thing [GhcHint]
_ ->
      [SDoc] -> SDoc
sep [ String -> SDoc
text String
"The" SDoc -> SDoc -> SDoc
<+> SDoc
thing
               SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
rdr_name)
          , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"lacks an accompanying binding" ]
    NotInScopeError
NoTopLevelBinding ->
      SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"No top-level binding for")
        Int
2 (SDoc
what 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
"in this module")
    UnknownSubordinate SDoc
doc ->
      SDoc -> SDoc
quotes (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
rdr_name) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is not a (visible)" SDoc -> SDoc -> SDoc
<+> SDoc
doc
  where
    what :: SDoc
what = NameSpace -> SDoc
pprNonVarNameSpace (OccName -> NameSpace
occNameSpace (RdrName -> OccName
rdrNameOcc RdrName
rdr_name))

scopeErrorHints :: NotInScopeError -> [GhcHint]
scopeErrorHints :: NotInScopeError -> [GhcHint]
scopeErrorHints NotInScopeError
scope_err =
  case NotInScopeError
scope_err of
    NotInScopeError
NotInScope             -> [GhcHint]
noHints
    NoExactName {}         -> [GhcHint
SuggestDumpSlices]
    SameName {}            -> [GhcHint
SuggestDumpSlices]
    MissingBinding SDoc
_ [GhcHint]
hints -> [GhcHint]
hints
    NotInScopeError
NoTopLevelBinding      -> [GhcHint]
noHints
    UnknownSubordinate {}  -> [GhcHint]
noHints

{- *********************************************************************
*                                                                      *
                  Outputting ImportError messages
*                                                                      *
**********************************************************************-}

instance Outputable ImportError where
  ppr :: ImportError -> SDoc
ppr (MissingModule ModuleName
mod_name) =
    [SDoc] -> SDoc
hsep
      [ String -> SDoc
text String
"NB: no module named"
      , SDoc -> SDoc
quotes (ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod_name)
      , String -> SDoc
text String
"is imported."
      ]
  ppr  (ModulesDoNotExport NonEmpty Module
mods OccName
occ_name)
    | Module
mod NE.:| [] <- NonEmpty Module
mods
    = [SDoc] -> SDoc
hsep
        [ String -> SDoc
text String
"NB: the module"
        , SDoc -> SDoc
quotes (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod)
        , String -> SDoc
text String
"does not export"
        , SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ_name) SDoc -> SDoc -> SDoc
<> SDoc
dot ]
    | Bool
otherwise
    = [SDoc] -> SDoc
hsep
        [ String -> SDoc
text String
"NB: neither"
        , [SDoc] -> SDoc
quotedListWithNor ((Module -> SDoc) -> [Module] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([Module] -> [SDoc]) -> [Module] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ NonEmpty Module -> [Module]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Module
mods)
        , String -> SDoc
text String
"export"
        , SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
occ_name) SDoc -> SDoc -> SDoc
<> SDoc
dot ]

{- *********************************************************************
*                                                                      *
             Suggested fixes for implication constraints
*                                                                      *
**********************************************************************-}

-- TODO: these functions should use GhcHint instead.

show_fixes :: [SDoc] -> SDoc
show_fixes :: [SDoc] -> SDoc
show_fixes []     = SDoc
empty
show_fixes (SDoc
f:[SDoc]
fs) = [SDoc] -> SDoc
sep [ String -> SDoc
text String
"Possible fix:"
                        , Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
vcat (SDoc
f SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: (SDoc -> SDoc) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> SDoc
text String
"or" SDoc -> SDoc -> SDoc
<+>) [SDoc]
fs))]

ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc]
ctxtFixes :: Bool -> Type -> [Implication] -> [SDoc]
ctxtFixes Bool
has_ambig_tvs Type
pred [Implication]
implics
  | Bool -> Bool
not Bool
has_ambig_tvs
  , Type -> Bool
isTyVarClassPred Type
pred
  , (SkolemInfoAnon
skol:[SkolemInfoAnon]
skols) <- [Implication] -> Type -> [SkolemInfoAnon]
usefulContext [Implication]
implics Type
pred
  , let what :: SDoc
what | [SkolemInfoAnon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SkolemInfoAnon]
skols
             , SigSkol (PatSynCtxt {}) Type
_ [(Name, TcTyVar)]
_ <- SkolemInfoAnon
skol
             = String -> SDoc
text String
"\"required\""
             | Bool
otherwise
             = SDoc
empty
  = [[SDoc] -> SDoc
sep [ String -> SDoc
text String
"add" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
pprParendType Type
pred
           SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"to the" SDoc -> SDoc -> SDoc
<+> SDoc
what SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"context of"
         , Int -> SDoc -> SDoc
nest Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ SkolemInfoAnon -> SDoc
ppr_skol SkolemInfoAnon
skol SDoc -> SDoc -> SDoc
$$
                    [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"or" SDoc -> SDoc -> SDoc
<+> SkolemInfoAnon -> SDoc
ppr_skol SkolemInfoAnon
skol
                         | SkolemInfoAnon
skol <- [SkolemInfoAnon]
skols ] ] ]
  | Bool
otherwise = []
  where
    ppr_skol :: SkolemInfoAnon -> SDoc
ppr_skol (PatSkol (RealDataCon DataCon
dc) HsMatchContext GhcTc
_) = String -> SDoc
text String
"the data constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc)
    ppr_skol (PatSkol (PatSynCon PatSyn
ps)   HsMatchContext GhcTc
_) = String -> SDoc
text String
"the pattern synonym"  SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (PatSyn -> SDoc
forall a. Outputable a => a -> SDoc
ppr PatSyn
ps)
    ppr_skol SkolemInfoAnon
skol_info = SkolemInfoAnon -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfoAnon
skol_info

usefulContext :: [Implication] -> PredType -> [SkolemInfoAnon]
-- usefulContext picks out the implications whose context
-- the programmer might plausibly augment to solve 'pred'
usefulContext :: [Implication] -> Type -> [SkolemInfoAnon]
usefulContext [Implication]
implics Type
pred
  = [Implication] -> [SkolemInfoAnon]
go [Implication]
implics
  where
    pred_tvs :: TyVarSet
pred_tvs = Type -> TyVarSet
tyCoVarsOfType Type
pred
    go :: [Implication] -> [SkolemInfoAnon]
go [] = []
    go (Implication
ic : [Implication]
ics)
       | Implication -> Bool
implausible Implication
ic = [SkolemInfoAnon]
rest
       | Bool
otherwise      = Implication -> SkolemInfoAnon
ic_info Implication
ic SkolemInfoAnon -> [SkolemInfoAnon] -> [SkolemInfoAnon]
forall a. a -> [a] -> [a]
: [SkolemInfoAnon]
rest
       where
          -- Stop when the context binds a variable free in the predicate
          rest :: [SkolemInfoAnon]
rest | (TcTyVar -> Bool) -> [TcTyVar] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TcTyVar -> TyVarSet -> Bool
`elemVarSet` TyVarSet
pred_tvs) (Implication -> [TcTyVar]
ic_skols Implication
ic) = []
               | Bool
otherwise                                 = [Implication] -> [SkolemInfoAnon]
go [Implication]
ics

    implausible :: Implication -> Bool
implausible Implication
ic
      | [TcTyVar] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Implication -> [TcTyVar]
ic_skols Implication
ic)            = Bool
True
      | SkolemInfoAnon -> Bool
implausible_info (Implication -> SkolemInfoAnon
ic_info Implication
ic) = Bool
True
      | Bool
otherwise                     = Bool
False

    implausible_info :: SkolemInfoAnon -> Bool
implausible_info (SigSkol (InfSigCtxt {}) Type
_ [(Name, TcTyVar)]
_) = Bool
True
    implausible_info SkolemInfoAnon
_                             = Bool
False
    -- Do not suggest adding constraints to an *inferred* type signature

pp_givens :: [Implication] -> [SDoc]
pp_givens :: [Implication] -> [SDoc]
pp_givens [Implication]
givens
   = case [Implication]
givens of
         []     -> []
         (Implication
g:[Implication]
gs) ->      SDoc -> Implication -> SDoc
ppr_given (String -> SDoc
text String
"from the context:") Implication
g
                 SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: (Implication -> SDoc) -> [Implication] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SDoc -> Implication -> SDoc
ppr_given (String -> SDoc
text String
"or from:")) [Implication]
gs
    where
       ppr_given :: SDoc -> Implication -> SDoc
ppr_given SDoc
herald implic :: Implication
implic@(Implic { ic_given :: Implication -> [TcTyVar]
ic_given = [TcTyVar]
gs, ic_info :: Implication -> SkolemInfoAnon
ic_info = SkolemInfoAnon
skol_info })
           = SDoc -> Int -> SDoc -> SDoc
hang (SDoc
herald SDoc -> SDoc -> SDoc
<+> [TcTyVar] -> SDoc
pprEvVarTheta ((TcTyVar -> Type) -> [TcTyVar] -> [TcTyVar]
forall a. (a -> Type) -> [a] -> [a]
mkMinimalBySCs TcTyVar -> Type
evVarPred [TcTyVar]
gs))
             -- See Note [Suppress redundant givens during error reporting]
             -- for why we use mkMinimalBySCs above.
                Int
2 ([SDoc] -> SDoc
sep [ String -> SDoc
text String
"bound by" SDoc -> SDoc -> SDoc
<+> SkolemInfoAnon -> SDoc
forall a. Outputable a => a -> SDoc
ppr SkolemInfoAnon
skol_info
                       , String -> SDoc
text String
"at" SDoc -> SDoc -> SDoc
<+> RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TcLclEnv -> RealSrcSpan
getLclEnvLoc (Implication -> TcLclEnv
ic_env Implication
implic)) ])

{- *********************************************************************
*                                                                      *
                       CtOrigin information
*                                                                      *
**********************************************************************-}

levelString :: TypeOrKind -> String
levelString :: TypeOrKind -> String
levelString TypeOrKind
TypeLevel = String
"type"
levelString TypeOrKind
KindLevel = String
"kind"

pprArising :: CtOrigin -> SDoc
-- Used for the main, top-level error message
-- We've done special processing for TypeEq, KindEq, givens
pprArising :: CtOrigin -> SDoc
pprArising (TypeEqOrigin {})         = SDoc
empty
pprArising (KindEqOrigin {})         = SDoc
empty
pprArising (AmbiguityCheckOrigin {}) = SDoc
empty  -- the "In the ambiguity check" context
                                              -- is sufficient; this would just be
                                              -- repetitive
pprArising CtOrigin
orig | CtOrigin -> Bool
isGivenOrigin CtOrigin
orig = SDoc
empty
                | Bool
otherwise          = CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig

-- Add the "arising from..." part to a message
addArising :: CtOrigin -> SDoc -> SDoc
addArising :: CtOrigin -> SDoc -> SDoc
addArising CtOrigin
orig SDoc
msg = SDoc -> Int -> SDoc -> SDoc
hang SDoc
msg Int
2 (CtOrigin -> SDoc
pprArising CtOrigin
orig)

pprWithArising :: [Ct] -> SDoc
-- Print something like
--    (Eq a) arising from a use of x at y
--    (Show a) arising from a use of p at q
-- Also return a location for the error message
-- Works for Wanted/Derived only
pprWithArising :: [Ct] -> SDoc
pprWithArising []
  = String -> SDoc
forall a. String -> a
panic String
"pprWithArising"
pprWithArising (Ct
ct:[Ct]
cts)
  | [Ct] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Ct]
cts
  = CtOrigin -> SDoc -> SDoc
addArising (CtLoc -> CtOrigin
ctLocOrigin CtLoc
loc) ([Type] -> SDoc
pprTheta [Ct -> Type
ctPred Ct
ct])
  | Bool
otherwise
  = [SDoc] -> SDoc
vcat ((Ct -> SDoc) -> [Ct] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Ct -> SDoc
ppr_one (Ct
ctCt -> [Ct] -> [Ct]
forall a. a -> [a] -> [a]
:[Ct]
cts))
  where
    loc :: CtLoc
loc = Ct -> CtLoc
ctLoc Ct
ct
    ppr_one :: Ct -> SDoc
ppr_one Ct
ct' = SDoc -> Int -> SDoc -> SDoc
hang (SDoc -> SDoc
parens (Type -> SDoc
pprType (Ct -> Type
ctPred Ct
ct')))
                     Int
2 (CtLoc -> SDoc
pprCtLoc (Ct -> CtLoc
ctLoc Ct
ct'))

{- *********************************************************************
*                                                                      *
                           SkolemInfo
*                                                                      *
**********************************************************************-}


tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
tidySkolemInfo TidyEnv
env (SkolemInfo Unique
u SkolemInfoAnon
sk_anon) = Unique -> SkolemInfoAnon -> SkolemInfo
SkolemInfo Unique
u (TidyEnv -> SkolemInfoAnon -> SkolemInfoAnon
tidySkolemInfoAnon TidyEnv
env SkolemInfoAnon
sk_anon)

----------------
tidySkolemInfoAnon :: TidyEnv -> SkolemInfoAnon -> SkolemInfoAnon
tidySkolemInfoAnon :: TidyEnv -> SkolemInfoAnon -> SkolemInfoAnon
tidySkolemInfoAnon TidyEnv
env (DerivSkol Type
ty)         = Type -> SkolemInfoAnon
DerivSkol (TidyEnv -> Type -> Type
tidyType TidyEnv
env Type
ty)
tidySkolemInfoAnon TidyEnv
env (SigSkol UserTypeCtxt
cx Type
ty [(Name, TcTyVar)]
tv_prs) = TidyEnv
-> UserTypeCtxt -> Type -> [(Name, TcTyVar)] -> SkolemInfoAnon
tidySigSkol TidyEnv
env UserTypeCtxt
cx Type
ty [(Name, TcTyVar)]
tv_prs
tidySkolemInfoAnon TidyEnv
env (InferSkol [(Name, Type)]
ids)        = [(Name, Type)] -> SkolemInfoAnon
InferSkol ((Type -> Type) -> [(Name, Type)] -> [(Name, Type)]
forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd (TidyEnv -> Type -> Type
tidyType TidyEnv
env) [(Name, Type)]
ids)
tidySkolemInfoAnon TidyEnv
env (UnifyForAllSkol Type
ty)   = Type -> SkolemInfoAnon
UnifyForAllSkol (TidyEnv -> Type -> Type
tidyType TidyEnv
env Type
ty)
tidySkolemInfoAnon TidyEnv
_   SkolemInfoAnon
info                   = SkolemInfoAnon
info

tidySigSkol :: TidyEnv -> UserTypeCtxt
            -> TcType -> [(Name,TcTyVar)] -> SkolemInfoAnon
-- We need to take special care when tidying SigSkol
-- See Note [SigSkol SkolemInfo] in "GHC.Tc.Types.Origin"
tidySigSkol :: TidyEnv
-> UserTypeCtxt -> Type -> [(Name, TcTyVar)] -> SkolemInfoAnon
tidySigSkol TidyEnv
env UserTypeCtxt
cx Type
ty [(Name, TcTyVar)]
tv_prs
  = UserTypeCtxt -> Type -> [(Name, TcTyVar)] -> SkolemInfoAnon
SigSkol UserTypeCtxt
cx (TidyEnv -> Type -> Type
tidy_ty TidyEnv
env Type
ty) [(Name, TcTyVar)]
tv_prs'
  where
    tv_prs' :: [(Name, TcTyVar)]
tv_prs' = (TcTyVar -> TcTyVar) -> [(Name, TcTyVar)] -> [(Name, TcTyVar)]
forall b c a. (b -> c) -> [(a, b)] -> [(a, c)]
mapSnd (TidyEnv -> TcTyVar -> TcTyVar
tidyTyCoVarOcc TidyEnv
env) [(Name, TcTyVar)]
tv_prs
    inst_env :: NameEnv TcTyVar
inst_env = [(Name, TcTyVar)] -> NameEnv TcTyVar
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(Name, TcTyVar)]
tv_prs'

    tidy_ty :: TidyEnv -> Type -> Type
tidy_ty TidyEnv
env (ForAllTy (Bndr TcTyVar
tv ArgFlag
vis) Type
ty)
      = VarBndr TcTyVar ArgFlag -> Type -> Type
ForAllTy (TcTyVar -> ArgFlag -> VarBndr TcTyVar ArgFlag
forall var argf. var -> argf -> VarBndr var argf
Bndr TcTyVar
tv' ArgFlag
vis) (TidyEnv -> Type -> Type
tidy_ty TidyEnv
env' Type
ty)
      where
        (TidyEnv
env', TcTyVar
tv') = TidyEnv -> TcTyVar -> (TidyEnv, TcTyVar)
tidy_tv_bndr TidyEnv
env TcTyVar
tv

    tidy_ty TidyEnv
env ty :: Type
ty@(FunTy AnonArgFlag
InvisArg Type
w Type
arg Type
res) -- Look under  c => t
      = Type
ty { ft_mult :: Type
ft_mult = TidyEnv -> Type -> Type
tidy_ty TidyEnv
env Type
w,
             ft_arg :: Type
ft_arg = TidyEnv -> Type -> Type
tidyType TidyEnv
env Type
arg,
             ft_res :: Type
ft_res = TidyEnv -> Type -> Type
tidy_ty TidyEnv
env Type
res }

    tidy_ty TidyEnv
env Type
ty = TidyEnv -> Type -> Type
tidyType TidyEnv
env Type
ty

    tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
    tidy_tv_bndr :: TidyEnv -> TcTyVar -> (TidyEnv, TcTyVar)
tidy_tv_bndr env :: TidyEnv
env@(TidyOccEnv
occ_env, VarEnv TcTyVar
subst) TcTyVar
tv
      | Just TcTyVar
tv' <- NameEnv TcTyVar -> Name -> Maybe TcTyVar
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv TcTyVar
inst_env (TcTyVar -> Name
tyVarName TcTyVar
tv)
      = ((TidyOccEnv
occ_env, VarEnv TcTyVar -> TcTyVar -> TcTyVar -> VarEnv TcTyVar
forall a. VarEnv a -> TcTyVar -> a -> VarEnv a
extendVarEnv VarEnv TcTyVar
subst TcTyVar
tv TcTyVar
tv'), TcTyVar
tv')

      | Bool
otherwise
      = TidyEnv -> TcTyVar -> (TidyEnv, TcTyVar)
tidyVarBndr TidyEnv
env TcTyVar
tv

pprSkols :: SolverReportErrCtxt -> [(SkolemInfoAnon, [TcTyVar])] -> SDoc
pprSkols :: SolverReportErrCtxt -> [(SkolemInfoAnon, [TcTyVar])] -> SDoc
pprSkols SolverReportErrCtxt
ctxt [(SkolemInfoAnon, [TcTyVar])]
zonked_ty_vars
  =
      let tidy_ty_vars :: [(SkolemInfoAnon, [TcTyVar])]
tidy_ty_vars = ((SkolemInfoAnon, [TcTyVar]) -> (SkolemInfoAnon, [TcTyVar]))
-> [(SkolemInfoAnon, [TcTyVar])] -> [(SkolemInfoAnon, [TcTyVar])]
forall a b. (a -> b) -> [a] -> [b]
map ((SkolemInfoAnon -> SkolemInfoAnon)
-> ([TcTyVar] -> [TcTyVar])
-> (SkolemInfoAnon, [TcTyVar])
-> (SkolemInfoAnon, [TcTyVar])
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (TidyEnv -> SkolemInfoAnon -> SkolemInfoAnon
tidySkolemInfoAnon (SolverReportErrCtxt -> TidyEnv
cec_tidy SolverReportErrCtxt
ctxt)) [TcTyVar] -> [TcTyVar]
forall a. a -> a
id) [(SkolemInfoAnon, [TcTyVar])]
zonked_ty_vars
      in [SDoc] -> SDoc
vcat (((SkolemInfoAnon, [TcTyVar]) -> SDoc)
-> [(SkolemInfoAnon, [TcTyVar])] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SkolemInfoAnon, [TcTyVar]) -> SDoc
pp_one [(SkolemInfoAnon, [TcTyVar])]
tidy_ty_vars)
  where

    no_msg :: SDoc
no_msg = String -> SDoc
text String
"No skolem info - we could not find the origin of the following variables" SDoc -> SDoc -> SDoc
<+> [(SkolemInfoAnon, [TcTyVar])] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(SkolemInfoAnon, [TcTyVar])]
zonked_ty_vars
       SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"This should not happen, please report it as a bug following the instructions at:"
       SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug"


    pp_one :: (SkolemInfoAnon, [TcTyVar]) -> SDoc
pp_one (UnkSkol CallStack
cs, [TcTyVar]
tvs)
      = [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang ([TcTyVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [TcTyVar]
tvs)
                 Int
2 ([TcTyVar] -> String -> String -> SDoc
forall {a}. [a] -> String -> String -> SDoc
is_or_are [TcTyVar]
tvs String
"a" String
"(rigid, skolem)")
             , Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"of unknown origin")
             , Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"bound at" SDoc -> SDoc -> SDoc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([TcTyVar] -> SrcSpan
skolsSpan [TcTyVar]
tvs))
             , SDoc
no_msg
             , CallStack -> SDoc
prettyCallStackDoc CallStack
cs
             ]
    pp_one (SkolemInfoAnon
RuntimeUnkSkol, [TcTyVar]
tvs)
      = SDoc -> Int -> SDoc -> SDoc
hang ([TcTyVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [TcTyVar]
tvs)
           Int
2 ([TcTyVar] -> String -> String -> SDoc
forall {a}. [a] -> String -> String -> SDoc
is_or_are [TcTyVar]
tvs String
"an" String
"unknown runtime")
    pp_one (SkolemInfoAnon
skol_info, [TcTyVar]
tvs)
      = [SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang ([TcTyVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
pprQuotedList [TcTyVar]
tvs)
                  Int
2 ([TcTyVar] -> String -> String -> SDoc
forall {a}. [a] -> String -> String -> SDoc
is_or_are [TcTyVar]
tvs String
"a"  String
"rigid" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"bound by")
             , Int -> SDoc -> SDoc
nest Int
2 (SkolemInfoAnon -> SDoc
pprSkolInfo SkolemInfoAnon
skol_info)
             , Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"at" SDoc -> SDoc -> SDoc
<+> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([TcTyVar] -> SrcSpan
skolsSpan [TcTyVar]
tvs)) ]

    is_or_are :: [a] -> String -> String -> SDoc
is_or_are [a
_] String
article String
adjective = String -> SDoc
text String
"is" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
article SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
adjective
                                      SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"type variable"
    is_or_are [a]
_   String
_       String
adjective = String -> SDoc
text String
"are" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
adjective
                                      SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"type variables"

skolsSpan :: [TcTyVar] -> SrcSpan
skolsSpan :: [TcTyVar] -> SrcSpan
skolsSpan [TcTyVar]
skol_tvs = (SrcSpan -> SrcSpan -> SrcSpan) -> [SrcSpan] -> SrcSpan
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans ((TcTyVar -> SrcSpan) -> [TcTyVar] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map TcTyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan [TcTyVar]
skol_tvs)

{- *********************************************************************
*                                                                      *
                Utilities for expected/actual messages
*                                                                      *
**********************************************************************-}

mk_supplementary_ea_msg :: SolverReportErrCtxt -> TypeOrKind
                        -> Type -> Type -> CtOrigin -> Either [TcSolverReportInfo] TcSolverReportMsg
mk_supplementary_ea_msg :: SolverReportErrCtxt
-> TypeOrKind
-> Type
-> Type
-> CtOrigin
-> Either [TcSolverReportInfo] TcSolverReportMsg
mk_supplementary_ea_msg SolverReportErrCtxt
ctxt TypeOrKind
level Type
ty1 Type
ty2 CtOrigin
orig
  | TypeEqOrigin { uo_expected :: CtOrigin -> Type
uo_expected = Type
exp, uo_actual :: CtOrigin -> Type
uo_actual = Type
act } <- CtOrigin
orig
  , Bool -> Bool
not (Type -> Type -> Type -> Type -> Bool
ea_looks_same Type
ty1 Type
ty2 Type
exp Type
act)
  = SolverReportErrCtxt
-> Maybe ErrorItem
-> TypeOrKind
-> CtOrigin
-> Either [TcSolverReportInfo] TcSolverReportMsg
mk_ea_msg SolverReportErrCtxt
ctxt Maybe ErrorItem
forall a. Maybe a
Nothing TypeOrKind
level CtOrigin
orig
  | Bool
otherwise
  = [TcSolverReportInfo]
-> Either [TcSolverReportInfo] TcSolverReportMsg
forall a b. a -> Either a b
Left []

ea_looks_same :: Type -> Type -> Type -> Type -> Bool
-- True if the faulting types (ty1, ty2) look the same as
-- the expected/actual types (exp, act).
-- If so, we don't want to redundantly report the latter
ea_looks_same :: Type -> Type -> Type -> Type -> Bool
ea_looks_same Type
ty1 Type
ty2 Type
exp Type
act
  = (Type
act Type -> Type -> Bool
`looks_same` Type
ty1 Bool -> Bool -> Bool
&& Type
exp Type -> Type -> Bool
`looks_same` Type
ty2) Bool -> Bool -> Bool
||
    (Type
exp Type -> Type -> Bool
`looks_same` Type
ty1 Bool -> Bool -> Bool
&& Type
act Type -> Type -> Bool
`looks_same` Type
ty2)
  where
    looks_same :: Type -> Type -> Bool
looks_same Type
t1 Type
t2 = Type
t1 Type -> Type -> Bool
`pickyEqType` Type
t2
                    Bool -> Bool -> Bool
|| Type
t1 Type -> Type -> Bool
`eqType` Type
liftedTypeKind Bool -> Bool -> Bool
&& Type
t2 Type -> Type -> Bool
`eqType` Type
liftedTypeKind
      -- pickyEqType is sensitive to synonyms, so only replies True
      -- when the types really look the same.  However,
      -- (TYPE 'LiftedRep) and Type both print the same way.

mk_ea_msg :: SolverReportErrCtxt -> Maybe ErrorItem -> TypeOrKind
          -> CtOrigin -> Either [TcSolverReportInfo] TcSolverReportMsg
-- Constructs a "Couldn't match" message
-- The (Maybe ErrorItem) says whether this is the main top-level message (Just)
--     or a supplementary message (Nothing)
mk_ea_msg :: SolverReportErrCtxt
-> Maybe ErrorItem
-> TypeOrKind
-> CtOrigin
-> Either [TcSolverReportInfo] TcSolverReportMsg
mk_ea_msg SolverReportErrCtxt
ctxt Maybe ErrorItem
at_top TypeOrKind
level
  (TypeEqOrigin { uo_actual :: CtOrigin -> Type
uo_actual = Type
act, uo_expected :: CtOrigin -> Type
uo_expected = Type
exp, uo_thing :: CtOrigin -> Maybe TypedThing
uo_thing = Maybe TypedThing
mb_thing })
  | Just TypedThing
thing <- Maybe TypedThing
mb_thing
  , TypeOrKind
KindLevel <- TypeOrKind
level
  = TcSolverReportMsg -> Either [TcSolverReportInfo] TcSolverReportMsg
forall a b. b -> Either a b
Right (TcSolverReportMsg
 -> Either [TcSolverReportInfo] TcSolverReportMsg)
-> TcSolverReportMsg
-> Either [TcSolverReportInfo] TcSolverReportMsg
forall a b. (a -> b) -> a -> b
$ KindMismatch { kmismatch_what :: TypedThing
kmismatch_what     = TypedThing
thing
                         , kmismatch_expected :: Type
kmismatch_expected = Type
exp
                         , kmismatch_actual :: Type
kmismatch_actual   = Type
act }
  | Just ErrorItem
item <- Maybe ErrorItem
at_top
  , let mismatch :: TcSolverReportMsg
mismatch =
          Mismatch
            { mismatch_ea :: Bool
mismatch_ea   = Bool
True
            , mismatch_item :: ErrorItem
mismatch_item = ErrorItem
item
            , mismatch_ty1 :: Type
mismatch_ty1  = Type
exp
            , mismatch_ty2 :: Type
mismatch_ty2  = Type
act }
  = TcSolverReportMsg -> Either [TcSolverReportInfo] TcSolverReportMsg
forall a b. b -> Either a b
Right (TcSolverReportMsg
 -> Either [TcSolverReportInfo] TcSolverReportMsg)
-> TcSolverReportMsg
-> Either [TcSolverReportInfo] TcSolverReportMsg
forall a b. (a -> b) -> a -> b
$
    if Bool
expanded_syns
    then TcSolverReportMsg -> [TcSolverReportInfo] -> TcSolverReportMsg
mkTcReportWithInfo TcSolverReportMsg
mismatch [TcSolverReportInfo
ea_expanded]
    else TcSolverReportMsg
mismatch
  | Bool
otherwise
  = [TcSolverReportInfo]
-> Either [TcSolverReportInfo] TcSolverReportMsg
forall a b. a -> Either a b
Left ([TcSolverReportInfo]
 -> Either [TcSolverReportInfo] TcSolverReportMsg)
-> [TcSolverReportInfo]
-> Either [TcSolverReportInfo] TcSolverReportMsg
forall a b. (a -> b) -> a -> b
$
    if Bool
expanded_syns
    then [TcSolverReportInfo
ea,TcSolverReportInfo
ea_expanded]
    else [TcSolverReportInfo
ea]

  where
    ea :: TcSolverReportInfo
ea = ExpectedActual { ea_expected :: Type
ea_expected = Type
exp, ea_actual :: Type
ea_actual = Type
act }
    ea_expanded :: TcSolverReportInfo
ea_expanded =
      ExpectedActualAfterTySynExpansion
        { ea_expanded_expected :: Type
ea_expanded_expected = Type
expTy1
        , ea_expanded_actual :: Type
ea_expanded_actual   = Type
expTy2 }

    expanded_syns :: Bool
expanded_syns = SolverReportErrCtxt -> Bool
cec_expand_syns SolverReportErrCtxt
ctxt
                 Bool -> Bool -> Bool
&& Bool -> Bool
not (Type
expTy1 Type -> Type -> Bool
`pickyEqType` Type
exp Bool -> Bool -> Bool
&& Type
expTy2 Type -> Type -> Bool
`pickyEqType` Type
act)
    (Type
expTy1, Type
expTy2) = Type -> Type -> (Type, Type)
expandSynonymsToMatch Type
exp Type
act
mk_ea_msg SolverReportErrCtxt
_ Maybe ErrorItem
_ TypeOrKind
_ CtOrigin
_ = [TcSolverReportInfo]
-> Either [TcSolverReportInfo] TcSolverReportMsg
forall a b. a -> Either a b
Left []

{- Note [Expanding type synonyms to make types similar]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

In type error messages, if -fprint-expanded-types is used, we want to expand
type synonyms to make expected and found types as similar as possible, but we
shouldn't expand types too much to make type messages even more verbose and
harder to understand. The whole point here is to make the difference in expected
and found types clearer.

`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms
only as much as necessary. Given two types t1 and t2:

  * If they're already same, it just returns the types.

  * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are
    type constructors), it expands C1 and C2 if they're different type synonyms.
    Then it recursively does the same thing on expanded types. If C1 and C2 are
    same, then it applies the same procedure to arguments of C1 and arguments of
    C2 to make them as similar as possible.

    Most important thing here is to keep number of synonym expansions at
    minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3,
    Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and
    `T (T3, T3, Bool)`.

  * Otherwise types don't have same shapes and so the difference is clearly
    visible. It doesn't do any expansions and show these types.

Note that we only expand top-layer type synonyms. Only when top-layer
constructors are the same we start expanding inner type synonyms.

Suppose top-layer type synonyms of t1 and t2 can expand N and M times,
respectively. If their type-synonym-expanded forms will meet at some point (i.e.
will have same shapes according to `sameShapes` function), it's possible to find
where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M))
comparisons. We first collect all the top-layer expansions of t1 and t2 in two
lists, then drop the prefix of the longer list so that they have same lengths.
Then we search through both lists in parallel, and return the first pair of
types that have same shapes. Inner types of these two types with same shapes
are then expanded using the same algorithm.

In case they don't meet, we return the last pair of types in the lists, which
has top-layer type synonyms completely expanded. (in this case the inner types
are not expanded at all, as the current form already shows the type error)
-}

-- | Expand type synonyms in given types only enough to make them as similar as
-- possible. Returned types are the same in terms of used type synonyms.
--
-- To expand all synonyms, see 'Type.expandTypeSynonyms'.
--
-- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for
-- some examples of how this should work.
expandSynonymsToMatch :: Type -> Type -> (Type, Type)
expandSynonymsToMatch :: Type -> Type -> (Type, Type)
expandSynonymsToMatch Type
ty1 Type
ty2 = (Type
ty1_ret, Type
ty2_ret)
  where
    (Type
ty1_ret, Type
ty2_ret) = Type -> Type -> (Type, Type)
go Type
ty1 Type
ty2

    -- Returns (type synonym expanded version of first type,
    --          type synonym expanded version of second type)
    go :: Type -> Type -> (Type, Type)
    go :: Type -> Type -> (Type, Type)
go Type
t1 Type
t2
      | Type
t1 Type -> Type -> Bool
`pickyEqType` Type
t2 =
        -- Types are same, nothing to do
        (Type
t1, Type
t2)

    go (TyConApp TyCon
tc1 [Type]
tys1) (TyConApp TyCon
tc2 [Type]
tys2)
      | TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2
      , [Type]
tys1 [Type] -> [Type] -> Bool
forall a b. [a] -> [b] -> Bool
`equalLength` [Type]
tys2 =
        -- Type constructors are same. They may be synonyms, but we don't
        -- expand further. The lengths of tys1 and tys2 must be equal;
        -- for example, with type S a = a, we don't want
        -- to zip (S Monad Int) and (S Bool).
        let ([Type]
tys1', [Type]
tys2') =
              [(Type, Type)] -> ([Type], [Type])
forall a b. [(a, b)] -> ([a], [b])
unzip (String
-> (Type -> Type -> (Type, Type))
-> [Type]
-> [Type]
-> [(Type, Type)]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"expandSynonymsToMatch" Type -> Type -> (Type, Type)
go [Type]
tys1 [Type]
tys2)
         in (TyCon -> [Type] -> Type
TyConApp TyCon
tc1 [Type]
tys1', TyCon -> [Type] -> Type
TyConApp TyCon
tc2 [Type]
tys2')

    go (AppTy Type
t1_1 Type
t1_2) (AppTy Type
t2_1 Type
t2_2) =
      let (Type
t1_1', Type
t2_1') = Type -> Type -> (Type, Type)
go Type
t1_1 Type
t2_1
          (Type
t1_2', Type
t2_2') = Type -> Type -> (Type, Type)
go Type
t1_2 Type
t2_2
       in (Type -> Type -> Type
mkAppTy Type
t1_1' Type
t1_2', Type -> Type -> Type
mkAppTy Type
t2_1' Type
t2_2')

    go ty1 :: Type
ty1@(FunTy AnonArgFlag
_ Type
w1 Type
t1_1 Type
t1_2) ty2 :: Type
ty2@(FunTy AnonArgFlag
_ Type
w2 Type
t2_1 Type
t2_2) | Type
w1 Type -> Type -> Bool
`eqType` Type
w2 =
      let (Type
t1_1', Type
t2_1') = Type -> Type -> (Type, Type)
go Type
t1_1 Type
t2_1
          (Type
t1_2', Type
t2_2') = Type -> Type -> (Type, Type)
go Type
t1_2 Type
t2_2
       in ( Type
ty1 { ft_arg :: Type
ft_arg = Type
t1_1', ft_res :: Type
ft_res = Type
t1_2' }
          , Type
ty2 { ft_arg :: Type
ft_arg = Type
t2_1', ft_res :: Type
ft_res = Type
t2_2' })

    go (ForAllTy VarBndr TcTyVar ArgFlag
b1 Type
t1) (ForAllTy VarBndr TcTyVar ArgFlag
b2 Type
t2) =
      -- NOTE: We may have a bug here, but we just can't reproduce it easily.
      -- See D1016 comments for details and our attempts at producing a test
      -- case. Short version: We probably need RnEnv2 to really get this right.
      let (Type
t1', Type
t2') = Type -> Type -> (Type, Type)
go Type
t1 Type
t2
       in (VarBndr TcTyVar ArgFlag -> Type -> Type
ForAllTy VarBndr TcTyVar ArgFlag
b1 Type
t1', VarBndr TcTyVar ArgFlag -> Type -> Type
ForAllTy VarBndr TcTyVar ArgFlag
b2 Type
t2')

    go (CastTy Type
ty1 KindCoercion
_) Type
ty2 = Type -> Type -> (Type, Type)
go Type
ty1 Type
ty2
    go Type
ty1 (CastTy Type
ty2 KindCoercion
_) = Type -> Type -> (Type, Type)
go Type
ty1 Type
ty2

    go Type
t1 Type
t2 =
      -- See Note [Expanding type synonyms to make types similar] for how this
      -- works
      let
        t1_exp_tys :: [Type]
t1_exp_tys = Type
t1 Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
tyExpansions Type
t1
        t2_exp_tys :: [Type]
t2_exp_tys = Type
t2 Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: Type -> [Type]
tyExpansions Type
t2
        t1_exps :: Int
t1_exps    = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
t1_exp_tys
        t2_exps :: Int
t2_exps    = [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
t2_exp_tys
        dif :: Int
dif        = Int -> Int
forall a. Num a => a -> a
abs (Int
t1_exps Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
t2_exps)
      in
        [(Type, Type)] -> (Type, Type)
followExpansions ([(Type, Type)] -> (Type, Type)) -> [(Type, Type)] -> (Type, Type)
forall a b. (a -> b) -> a -> b
$
          String -> [Type] -> [Type] -> [(Type, Type)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"expandSynonymsToMatch.go"
            (if Int
t1_exps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
t2_exps then Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop Int
dif [Type]
t1_exp_tys else [Type]
t1_exp_tys)
            (if Int
t2_exps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
t1_exps then Int -> [Type] -> [Type]
forall a. Int -> [a] -> [a]
drop Int
dif [Type]
t2_exp_tys else [Type]
t2_exp_tys)

    -- Expand the top layer type synonyms repeatedly, collect expansions in a
    -- list. The list does not include the original type.
    --
    -- Example, if you have:
    --
    --   type T10 = T9
    --   type T9  = T8
    --   ...
    --   type T0  = Int
    --
    -- `tyExpansions T10` returns [T9, T8, T7, ... Int]
    --
    -- This only expands the top layer, so if you have:
    --
    --   type M a = Maybe a
    --
    -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded)
    tyExpansions :: Type -> [Type]
    tyExpansions :: Type -> [Type]
tyExpansions = (Type -> Maybe (Type, Type)) -> Type -> [Type]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (\Type
t -> (\Type
x -> (Type
x, Type
x)) (Type -> (Type, Type)) -> Maybe Type -> Maybe (Type, Type)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Type -> Maybe Type
tcView Type
t)

    -- Drop the type pairs until types in a pair look alike (i.e. the outer
    -- constructors are the same).
    followExpansions :: [(Type, Type)] -> (Type, Type)
    followExpansions :: [(Type, Type)] -> (Type, Type)
followExpansions [] = String -> SDoc -> (Type, Type)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"followExpansions" SDoc
empty
    followExpansions [(Type
t1, Type
t2)]
      | Type -> Type -> Bool
sameShapes Type
t1 Type
t2 = Type -> Type -> (Type, Type)
go Type
t1 Type
t2 -- expand subtrees
      | Bool
otherwise        = (Type
t1, Type
t2) -- the difference is already visible
    followExpansions ((Type
t1, Type
t2) : [(Type, Type)]
tss)
      -- Traverse subtrees when the outer shapes are the same
      | Type -> Type -> Bool
sameShapes Type
t1 Type
t2 = Type -> Type -> (Type, Type)
go Type
t1 Type
t2
      -- Otherwise follow the expansions until they look alike
      | Bool
otherwise = [(Type, Type)] -> (Type, Type)
followExpansions [(Type, Type)]
tss

    sameShapes :: Type -> Type -> Bool
    sameShapes :: Type -> Type -> Bool
sameShapes AppTy{}          AppTy{}          = Bool
True
    sameShapes (TyConApp TyCon
tc1 [Type]
_) (TyConApp TyCon
tc2 [Type]
_) = TyCon
tc1 TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
tc2
    sameShapes (FunTy {})       (FunTy {})       = Bool
True
    sameShapes (ForAllTy {})    (ForAllTy {})    = Bool
True
    sameShapes (CastTy Type
ty1 KindCoercion
_)   Type
ty2              = Type -> Type -> Bool
sameShapes Type
ty1 Type
ty2
    sameShapes Type
ty1              (CastTy Type
ty2 KindCoercion
_)   = Type -> Type -> Bool
sameShapes Type
ty1 Type
ty2
    sameShapes Type
_                Type
_                = Bool
False

{-
************************************************************************
*                                                                      *
\subsection{Contexts for renaming errors}
*                                                                      *
************************************************************************
-}

withHsDocContext :: HsDocContext -> SDoc -> SDoc
withHsDocContext :: HsDocContext -> SDoc -> SDoc
withHsDocContext HsDocContext
ctxt SDoc
doc = SDoc
doc SDoc -> SDoc -> SDoc
$$ HsDocContext -> SDoc
inHsDocContext HsDocContext
ctxt

inHsDocContext :: HsDocContext -> SDoc
inHsDocContext :: HsDocContext -> SDoc
inHsDocContext HsDocContext
ctxt = String -> SDoc
text String
"In" SDoc -> SDoc -> SDoc
<+> HsDocContext -> SDoc
pprHsDocContext HsDocContext
ctxt

pprHsDocContext :: HsDocContext -> SDoc
pprHsDocContext :: HsDocContext -> SDoc
pprHsDocContext (GenericCtx SDoc
doc)      = SDoc
doc
pprHsDocContext (TypeSigCtx SDoc
doc)      = String -> SDoc
text String
"the type signature for" SDoc -> SDoc -> SDoc
<+> SDoc
doc
pprHsDocContext (StandaloneKindSigCtx SDoc
doc) = String -> SDoc
text String
"the standalone kind signature for" SDoc -> SDoc -> SDoc
<+> SDoc
doc
pprHsDocContext HsDocContext
PatCtx                = String -> SDoc
text String
"a pattern type-signature"
pprHsDocContext HsDocContext
SpecInstSigCtx        = String -> SDoc
text String
"a SPECIALISE instance pragma"
pprHsDocContext HsDocContext
DefaultDeclCtx        = String -> SDoc
text String
"a `default' declaration"
pprHsDocContext HsDocContext
DerivDeclCtx          = String -> SDoc
text String
"a deriving declaration"
pprHsDocContext (RuleCtx FieldLabelString
name)        = String -> SDoc
text String
"the rewrite rule" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
doubleQuotes (FieldLabelString -> SDoc
ftext FieldLabelString
name)
pprHsDocContext (TyDataCtx LocatedN RdrName
tycon)     = String -> SDoc
text String
"the data type declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LocatedN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedN RdrName
tycon)
pprHsDocContext (FamPatCtx LocatedN RdrName
tycon)     = String -> SDoc
text String
"a type pattern of family instance for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LocatedN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedN RdrName
tycon)
pprHsDocContext (TySynCtx LocatedN RdrName
name)       = String -> SDoc
text String
"the declaration for type synonym" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LocatedN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedN RdrName
name)
pprHsDocContext (TyFamilyCtx LocatedN RdrName
name)    = String -> SDoc
text String
"the declaration for type family" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LocatedN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedN RdrName
name)
pprHsDocContext (ClassDeclCtx LocatedN RdrName
name)   = String -> SDoc
text String
"the declaration for class" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LocatedN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedN RdrName
name)
pprHsDocContext HsDocContext
ExprWithTySigCtx      = String -> SDoc
text String
"an expression type signature"
pprHsDocContext HsDocContext
TypBrCtx              = String -> SDoc
text String
"a Template-Haskell quoted type"
pprHsDocContext HsDocContext
HsTypeCtx             = String -> SDoc
text String
"a type argument"
pprHsDocContext HsDocContext
HsTypePatCtx          = String -> SDoc
text String
"a type argument in a pattern"
pprHsDocContext HsDocContext
GHCiCtx               = String -> SDoc
text String
"GHCi input"
pprHsDocContext (SpliceTypeCtx LHsType GhcPs
hs_ty) = String -> SDoc
text String
"the spliced type" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (GenLocated SrcSpanAnnA (HsType GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr LHsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs)
hs_ty)
pprHsDocContext HsDocContext
ClassInstanceCtx      = String -> SDoc
text String
"GHC.Tc.Gen.Splice.reifyInstances"

pprHsDocContext (ForeignDeclCtx LocatedN RdrName
name)
   = String -> SDoc
text String
"the foreign declaration for" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LocatedN RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedN RdrName
name)
pprHsDocContext (ConDeclCtx [LocatedN Name
name])
   = String -> SDoc
text String
"the definition of data constructor" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (LocatedN Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr LocatedN Name
name)
pprHsDocContext (ConDeclCtx [LocatedN Name]
names)
   = String -> SDoc
text String
"the definition of data constructors" SDoc -> SDoc -> SDoc
<+> [LocatedN Name] -> SDoc
forall a. Outputable a => [a] -> SDoc
interpp'SP [LocatedN Name]
names