{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} 
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 () 
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))
        
        
        
        
        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  
                                       
                | 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
            
            
            | 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"
            
            
            | 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 
    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{}
    
    
    
    
    -> [GhcHint]
noHints
  DerivErrDunnoHowToDeriveForType{}
    -> [GhcHint]
noHints
  DerivErrMustBeEnumType TyCon
rep_tc
    
    | 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  
                -> 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 ]
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 
                                -> 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 
                          -> 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)
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 ])
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
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
      = 
        [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
      = 
        [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 -> 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
      | 
        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
      
      | 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)
           
           
           
        -> 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   
                         
               , 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
    
    
    
    
    
    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 }) =
      
      (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 ]
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    confusing_cast :: Type -> Bool
    confusing_cast :: Type -> Bool
confusing_cast Type
ty =
      case Type
ty of
        CastTy Type
inner_ty KindCoercion
_
          
          
          -> 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" 
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
                 
                 , 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
$
            
            
        [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)))
            
      , [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
    
    ([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)
         
         
    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
    
    
    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  
               , [Type
_,Type
ty] <- [Type]
tys                        
               , 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
$
       
       
       
       
       
       
         [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
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))
    ]
potentialInstancesErrMsg :: PotentialInstances -> SDoc
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
potentials_msg_with_options :: PotentialInstances
                            -> Bool 
                            -> 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 
            (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
       
       
       
    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 
      | 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 
                 (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)"
overlapping_but_not_more_specific_msg :: [ClsInst] -> SDoc
overlapping_but_not_more_specific_msg :: [ClsInst] -> SDoc
overlapping_but_not_more_specific_msg [ClsInst]
insts
  
  
  | (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
          
          , ClsInst
one:[ClsInst]
others <- [ClsInst] -> [[ClsInst]]
forall a. [a] -> [[a]]
tails [ClsInst]
these 
          , ClsInst
other <- [ClsInst]
others           
          
          , 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
          
          , 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])
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  
        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 
      = 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 
      = 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  
      = 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" ])
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 
      | 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)  
    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 
                               
      = 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)
                      
                      
    expr_hole_hint :: SDoc
expr_hole_hint                       
         | FieldLabelString -> Int
lengthFS (OccName -> FieldLabelString
occNameFS OccName
hole_occ) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1  
         = 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  
       | Bool
otherwise  
       = (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)
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
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 ]
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 :: [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
          
          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
    
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))
             
             
                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)) ])
levelString :: TypeOrKind -> String
levelString :: TypeOrKind -> String
levelString TypeOrKind
TypeLevel = String
"type"
levelString TypeOrKind
KindLevel = String
"kind"
pprArising :: CtOrigin -> SDoc
pprArising :: CtOrigin -> SDoc
pprArising (TypeEqOrigin {})         = SDoc
empty
pprArising (KindEqOrigin {})         = SDoc
empty
pprArising (AmbiguityCheckOrigin {}) = SDoc
empty  
                                              
                                              
pprArising CtOrigin
orig | CtOrigin -> Bool
isGivenOrigin CtOrigin
orig = SDoc
empty
                | Bool
otherwise          = CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig
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
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'))
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
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) 
      = 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)
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
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
      
      
      
mk_ea_msg :: SolverReportErrCtxt -> Maybe ErrorItem -> TypeOrKind
          -> CtOrigin -> Either [TcSolverReportInfo] TcSolverReportMsg
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 []
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
    
    
    go :: Type -> Type -> (Type, Type)
    go :: Type -> Type -> (Type, Type)
go Type
t1 Type
t2
      | Type
t1 Type -> Type -> Bool
`pickyEqType` Type
t2 =
        
        (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 =
        
        
        
        
        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) =
      
      
      
      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 =
      
      
      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)
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    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)
    
    
    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 
      | Bool
otherwise        = (Type
t1, Type
t2) 
    followExpansions ((Type
t1, Type
t2) : [(Type, Type)]
tss)
      
      | Type -> Type -> Bool
sameShapes Type
t1 Type
t2 = Type -> Type -> (Type, Type)
go Type
t1 Type
t2
      
      | 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
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