GHC/Tc/Types/Origin.hs

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE LambdaCase #-}

    {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
    {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}

    -- | Describes the provenance of types as they flow through the type-checker.
    -- The datatypes here are mainly used for error message generation.
    module GHC.Tc.Types.Origin (
      -- UserTypeCtxt
      UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe,

      -- SkolemInfo
      SkolemInfo(..), pprSigSkolInfo, pprSkolInfo,

      -- CtOrigin
      CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,
      isVisibleOrigin, toInvisibleOrigin,
      pprCtOrigin, isGivenOrigin

      ) where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Tc.Utils.TcType

    import GHC.Hs

    import GHC.Types.Id
    import GHC.Core.DataCon
    import GHC.Core.ConLike
    import GHC.Core.TyCon
    import GHC.Core.InstEnv
    import GHC.Core.PatSyn
    import GHC.Core.Multiplicity ( scaledThing )

    import GHC.Unit.Module
    import GHC.Types.Name
    import GHC.Types.Name.Reader

    import GHC.Types.SrcLoc
    import GHC.Data.FastString
    import GHC.Utils.Outputable
    import GHC.Types.Basic

    {- *********************************************************************
    *                                                                      *
              UserTypeCtxt
    *                                                                      *
    ********************************************************************* -}

    -------------------------------------
    -- | UserTypeCtxt describes the origin of the polymorphic type
    -- in the places where we need an expression to have that type
    data UserTypeCtxt
      = FunSigCtxt      -- Function type signature, when checking the type
                        -- Also used for types in SPECIALISE pragmas
           Name              -- Name of the function
           Bool              -- True <=> report redundant constraints
                                -- This is usually True, but False for
                                --   * Record selectors (not important here)
                                --   * Class and instance methods.  Here
                                --     the code may legitimately be more
                                --     polymorphic than the signature
                                --     generated from the class
                                --     declaration

      | InfSigCtxt Name     -- Inferred type for function
      | ExprSigCtxt         -- Expression type signature
      | KindSigCtxt         -- Kind signature
      | StandaloneKindSigCtxt  -- Standalone kind signature
           Name                -- Name of the type/class
      | TypeAppCtxt         -- Visible type application
      | ConArgCtxt Name     -- Data constructor argument
      | TySynCtxt Name      -- RHS of a type synonym decl
      | PatSynCtxt Name     -- Type sig for a pattern synonym
      | PatSigCtxt          -- Type sig in pattern
                            --   eg  f (x::t) = ...
                            --   or  (x::t, y) = e
      | RuleSigCtxt Name    -- LHS of a RULE forall
                            --    RULE "foo" forall (x :: a -> a). f (Just x) = ...
      | ResSigCtxt          -- Result type sig
                            --      f x :: t = ....
      | ForSigCtxt Name     -- Foreign import or export signature
      | DefaultDeclCtxt     -- Types in a default declaration
      | InstDeclCtxt Bool   -- An instance declaration
                            --    True:  stand-alone deriving
                            --    False: vanilla instance declaration
      | SpecInstCtxt        -- SPECIALISE instance pragma
      | ThBrackCtxt         -- Template Haskell type brackets [t| ... |]
      | GenSigCtxt          -- Higher-rank or impredicative situations
                            -- e.g. (f e) where f has a higher-rank type
                            -- We might want to elaborate this
      | GhciCtxt Bool       -- GHCi command :kind <type>
                            -- The Bool indicates if we are checking the outermost
                            -- type application.
                            -- See Note [Unsaturated type synonyms in GHCi] in
                            -- GHC.Tc.Validity.

      | ClassSCCtxt Name    -- Superclasses of a class
      | SigmaCtxt           -- Theta part of a normal for-all type
                            --      f :: <S> => a -> a
      | DataTyCtxt Name     -- The "stupid theta" part of a data decl
                            --      data <S> => T a = MkT a
      | DerivClauseCtxt     -- A 'deriving' clause
      | TyVarBndrKindCtxt Name  -- The kind of a type variable being bound
      | DataKindCtxt Name   -- The kind of a data/newtype (instance)
      | TySynKindCtxt Name  -- The kind of the RHS of a type synonym
      | TyFamResKindCtxt Name   -- The result kind of a type family

    {-
    -- Notes re TySynCtxt
    -- We allow type synonyms that aren't types; e.g.  type List = []
    --
    -- If the RHS mentions tyvars that aren't in scope, we'll
    -- quantify over them:
    --      e.g.    type T = a->a
    -- will become  type T = forall a. a->a
    --
    -- With gla-exts that's right, but for H98 we should complain.
    -}

    pprUserTypeCtxt :: UserTypeCtxt -> SDoc
    pprUserTypeCtxt (FunSigCtxt n _)  = text "the type signature for" <+> quotes (ppr n)
    pprUserTypeCtxt (InfSigCtxt n)    = text "the inferred type for" <+> quotes (ppr n)
    pprUserTypeCtxt (RuleSigCtxt n)   = text "the type signature for" <+> quotes (ppr n)
    pprUserTypeCtxt ExprSigCtxt       = text "an expression type signature"
    pprUserTypeCtxt KindSigCtxt       = text "a kind signature"
    pprUserTypeCtxt (StandaloneKindSigCtxt n) = text "a standalone kind signature for" <+> quotes (ppr n)
    pprUserTypeCtxt TypeAppCtxt       = text "a type argument"
    pprUserTypeCtxt (ConArgCtxt c)    = text "the type of the constructor" <+> quotes (ppr c)
    pprUserTypeCtxt (TySynCtxt c)     = text "the RHS of the type synonym" <+> quotes (ppr c)
    pprUserTypeCtxt ThBrackCtxt       = text "a Template Haskell quotation [t|...|]"
    pprUserTypeCtxt PatSigCtxt        = text "a pattern type signature"
    pprUserTypeCtxt ResSigCtxt        = text "a result type signature"
    pprUserTypeCtxt (ForSigCtxt n)    = text "the foreign declaration for" <+> quotes (ppr n)
    pprUserTypeCtxt DefaultDeclCtxt   = text "a type in a `default' declaration"
    pprUserTypeCtxt (InstDeclCtxt False) = text "an instance declaration"
    pprUserTypeCtxt (InstDeclCtxt True)  = text "a stand-alone deriving instance declaration"
    pprUserTypeCtxt SpecInstCtxt      = text "a SPECIALISE instance pragma"
    pprUserTypeCtxt GenSigCtxt        = text "a type expected by the context"
    pprUserTypeCtxt (GhciCtxt {})     = text "a type in a GHCi command"
    pprUserTypeCtxt (ClassSCCtxt c)   = text "the super-classes of class" <+> quotes (ppr c)
    pprUserTypeCtxt SigmaCtxt         = text "the context of a polymorphic type"
    pprUserTypeCtxt (DataTyCtxt tc)   = text "the context of the data type declaration for" <+> quotes (ppr tc)
    pprUserTypeCtxt (PatSynCtxt n)    = text "the signature for pattern synonym" <+> quotes (ppr n)
    pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause"
    pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type variable" <+> quotes (ppr n)
    pprUserTypeCtxt (DataKindCtxt n)  = text "the kind annotation on the declaration for" <+> quotes (ppr n)
    pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n)
    pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n)

    isSigMaybe :: UserTypeCtxt -> Maybe Name
    isSigMaybe (FunSigCtxt n _) = Just n
    isSigMaybe (ConArgCtxt n)   = Just n
    isSigMaybe (ForSigCtxt n)   = Just n
    isSigMaybe (PatSynCtxt n)   = Just n
    isSigMaybe _                = Nothing

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

    -- SkolemInfo gives the origin of *given* constraints
    --   a) type variables are skolemised
    --   b) an implication constraint is generated
    data SkolemInfo
      = SigSkol -- A skolem that is created by instantiating
                -- a programmer-supplied type signature
                -- Location of the binding site is on the TyVar
                -- See Note [SigSkol SkolemInfo]
           UserTypeCtxt        -- What sort of signature
           TcType              -- Original type signature (before skolemisation)
           [(Name,TcTyVar)]    -- Maps the original name of the skolemised tyvar
                               -- to its instantiated version

      | SigTypeSkol UserTypeCtxt
                     -- like SigSkol, but when we're kind-checking the *type*
                     -- hence, we have less info

      | ForAllSkol  -- Bound by a user-written "forall".
           SDoc        -- Shows the entire forall type
           SDoc        -- Shows just the binders, used when reporting a bad telescope
                       -- See Note [Checking telescopes] in GHC.Tc.Types.Constraint

      | DerivSkol Type      -- Bound by a 'deriving' clause;
                            -- the type is the instance we are trying to derive

      | InstSkol            -- Bound at an instance decl
      | InstSC TypeSize     -- A "given" constraint obtained by superclass selection.
                            -- If (C ty1 .. tyn) is the largest class from
                            --    which we made a superclass selection in the chain,
                            --    then TypeSize = sizeTypes [ty1, .., tyn]
                            -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance

      | FamInstSkol         -- Bound at a family instance decl
      | PatSkol             -- An existential type variable bound by a pattern for
          ConLike           -- a data constructor with an existential type.
          (HsMatchContext GhcRn)
                 -- e.g.   data T = forall a. Eq a => MkT a
                 --        f (MkT x) = ...
                 -- The pattern MkT x will allocate an existential type
                 -- variable for 'a'.

      | ArrowSkol           -- An arrow form (see GHC.Tc.Gen.Arrow)

      | IPSkol [HsIPName]   -- Binding site of an implicit parameter

      | RuleSkol RuleName   -- The LHS of a RULE

      | InferSkol [(Name,TcType)]
                            -- We have inferred a type for these (mutually-recursivive)
                            -- polymorphic Ids, and are now checking that their RHS
                            -- constraints are satisfied.

      | BracketSkol         -- Template Haskell bracket

      | UnifyForAllSkol     -- We are unifying two for-all types
           TcType           -- The instantiated type *inside* the forall

      | TyConSkol TyConFlavour Name  -- bound in a type declaration of the given flavour

      | DataConSkol Name    -- bound as an existential in a Haskell98 datacon decl or
                            -- as any variable in a GADT datacon decl

      | ReifySkol           -- Bound during Template Haskell reification

      | QuantCtxtSkol       -- Quantified context, e.g.
                            --   f :: forall c. (forall a. c a => c [a]) => blah

      | RuntimeUnkSkol      -- Runtime skolem from the GHCi debugger      #14628

      | UnkSkol             -- Unhelpful info (until I improve it)

    instance Outputable SkolemInfo where
      ppr = pprSkolInfo

    pprSkolInfo :: SkolemInfo -> SDoc
    -- Complete the sentence "is a rigid type variable bound by..."
    pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty
    pprSkolInfo (SigTypeSkol cx)  = pprUserTypeCtxt cx
    pprSkolInfo (ForAllSkol pt _) = quotes pt
    pprSkolInfo (IPSkol ips)      = text "the implicit-parameter binding" <> plural ips <+> text "for"
                                     <+> pprWithCommas ppr ips
    pprSkolInfo (DerivSkol pred)  = text "the deriving clause for" <+> quotes (ppr pred)
    pprSkolInfo InstSkol          = text "the instance declaration"
    pprSkolInfo (InstSC n)        = text "the instance declaration" <> whenPprDebug (parens (ppr n))
    pprSkolInfo FamInstSkol       = text "a family instance declaration"
    pprSkolInfo BracketSkol       = text "a Template Haskell bracket"
    pprSkolInfo (RuleSkol name)   = text "the RULE" <+> pprRuleName name
    pprSkolInfo ArrowSkol         = text "an arrow form"
    pprSkolInfo (PatSkol cl mc)   = sep [ pprPatSkolInfo cl
                                        , text "in" <+> pprMatchContext mc ]
    pprSkolInfo (InferSkol ids)   = hang (text "the inferred type" <> plural ids <+> text "of")
                                       2 (vcat [ ppr name <+> dcolon <+> ppr ty
                                                       | (name,ty) <- ids ])
    pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty
    pprSkolInfo (TyConSkol flav name) = text "the" <+> ppr flav <+> text "declaration for" <+> quotes (ppr name)
    pprSkolInfo (DataConSkol name)= text "the data constructor" <+> quotes (ppr name)
    pprSkolInfo ReifySkol         = text "the type being reified"

    pprSkolInfo (QuantCtxtSkol {}) = text "a quantified context"
    pprSkolInfo RuntimeUnkSkol     = text "Unknown type from GHCi runtime"

    -- UnkSkol
    -- For type variables the others are dealt with by pprSkolTvBinding.
    -- For Insts, these cases should not happen
    pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) text "UnkSkol"

    pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc
    -- The type is already tidied
    pprSigSkolInfo ctxt ty
      = case ctxt of
           FunSigCtxt f _ -> vcat [ text "the type signature for:"
                                  , nest 2 (pprPrefixOcc f <+> dcolon <+> ppr ty) ]
           PatSynCtxt {}  -> pprUserTypeCtxt ctxt  -- See Note [Skolem info for pattern synonyms]
           _              -> vcat [ pprUserTypeCtxt ctxt <> colon
                                  , nest 2 (ppr ty) ]

    pprPatSkolInfo :: ConLike -> SDoc
    pprPatSkolInfo (RealDataCon dc)
      = sdocWithDynFlags (\dflags ->
          sep [ text "a pattern with constructor:"
              , nest 2 $ ppr dc <+> dcolon
                <+> pprType (dataConDisplayType dflags dc) <> comma ])
                -- pprType prints forall's regardless of -fprint-explicit-foralls
                -- which is what we want here, since we might be saying
                -- type variable 't' is bound by ...

    pprPatSkolInfo (PatSynCon ps)
      = sep [ text "a pattern with pattern synonym:"
            , nest 2 $ ppr ps <+> dcolon
                       <+> pprPatSynType ps <> comma ]

    {- Note [Skolem info for pattern synonyms]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    For pattern synonym SkolemInfo we have
       SigSkol (PatSynCtxt p) ty _
    but the type 'ty' is not very helpful.  The full pattern-synonym type
    has the provided and required pieces, which it is inconvenient to
    record and display here. So we simply don't display the type at all,
    contenting outselves with just the name of the pattern synonym, which
    is fine.  We could do more, but it doesn't seem worth it.

    Note [SigSkol SkolemInfo]
    ~~~~~~~~~~~~~~~~~~~~~~~~~
    Suppose we skolemise a type
       f :: forall a. Eq a => forall b. b -> a
    Then we'll instantiate [a :-> a', b :-> b'], and with the instantiated
          a' -> b' -> a.
    But when, in an error message, we report that "b is a rigid type
    variable bound by the type signature for f", we want to show the foralls
    in the right place.  So we proceed as follows:

    * In SigSkol we record
        - the original signature forall a. a -> forall b. b -> a
        - the instantiation mapping [a :-> a', b :-> b']

    * Then when tidying in GHC.Tc.Utils.TcMType.tidySkolemInfo, we first tidy a' to
      whatever it tidies to, say a''; and then we walk over the type
      replacing the binder a by the tidied version a'', to give
           forall a''. Eq a'' => forall b''. b'' -> a''
      We need to do this under (=>) arrows, to match what topSkolemise
      does.

    * Typically a'' will have a nice pretty name like "a", but the point is
      that the foral-bound variables of the signature we report line up with
      the instantiated skolems lying  around in other types.

    ************************************************************************
    *                                                                      *
                CtOrigin
    *                                                                      *
    ************************************************************************
    -}

    data CtOrigin
      = GivenOrigin SkolemInfo

      -- All the others are for *wanted* constraints
      | OccurrenceOf Name              -- Occurrence of an overloaded identifier
      | OccurrenceOfRecSel RdrName     -- Occurrence of a record selector
      | AppOrigin                      -- An application of some kind

      | SpecPragOrigin UserTypeCtxt    -- Specialisation pragma for
                                       -- function or instance

      | TypeEqOrigin { uo_actual   :: TcType
                     , uo_expected :: TcType
                     , uo_thing    :: Maybe SDoc
                           -- ^ The thing that has type "actual"
                     , uo_visible  :: Bool
                           -- ^ Is at least one of the three elements above visible?
                           -- (Errors from the polymorphic subsumption check are considered
                           -- visible.) Only used for prioritizing error messages.
                     }

      | KindEqOrigin
          TcType (Maybe TcType)     -- A kind equality arising from unifying these two types
          CtOrigin                  -- originally arising from this
          (Maybe TypeOrKind)        -- the level of the eq this arises from

      | IPOccOrigin  HsIPName       -- Occurrence of an implicit parameter
      | OverLabelOrigin FastString  -- Occurrence of an overloaded label

      | LiteralOrigin (HsOverLit GhcRn)     -- Occurrence of a literal
      | NegateOrigin                        -- Occurrence of syntactic negation

      | ArithSeqOrigin (ArithSeqInfo GhcRn) -- [x..], [x..y] etc
      | AssocFamPatOrigin   -- When matching the patterns of an associated
                            -- family instance with that of its parent class
      | SectionOrigin
      | TupleOrigin         -- (..,..)
      | ExprSigOrigin       -- e :: ty
      | PatSigOrigin        -- p :: ty
      | PatOrigin           -- Instantiating a polytyped pattern at a constructor
      | ProvCtxtOrigin      -- The "provided" context of a pattern synonym signature
            (PatSynBind GhcRn GhcRn) -- Information about the pattern synonym, in
                                     -- particular the name and the right-hand side
      | RecordUpdOrigin
      | ViewPatOrigin

      | ScOrigin TypeSize   -- Typechecking superclasses of an instance declaration
                            -- If the instance head is C ty1 .. tyn
                            --    then TypeSize = sizeTypes [ty1, .., tyn]
                            -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance

      | DerivClauseOrigin   -- Typechecking a deriving clause (as opposed to
                            -- standalone deriving).
      | DerivOriginDC DataCon Int Bool
          -- Checking constraints arising from this data con and field index. The
          -- Bool argument in DerivOriginDC and DerivOriginCoerce is True if
          -- standalong deriving (with a wildcard constraint) is being used. This
          -- is used to inform error messages on how to recommended fixes (e.g., if
          -- the argument is True, then don't recommend "use standalone deriving",
          -- but rather "fill in the wildcard constraint yourself").
          -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer
      | DerivOriginCoerce Id Type Type Bool
                            -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from
                            -- `ty1` to `ty2`.
      | StandAloneDerivOrigin -- Typechecking stand-alone deriving. Useful for
                              -- constraints coming from a wildcard constraint,
                              -- e.g., deriving instance _ => Eq (Foo a)
                              -- See Note [Inferring the instance context]
                              -- in GHC.Tc.Deriv.Infer
      | DefaultOrigin       -- Typechecking a default decl
      | DoOrigin            -- Arising from a do expression
      | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in
                                 -- a do expression
      | MCompOrigin         -- Arising from a monad comprehension
      | MCompPatOrigin (LPat GhcRn) -- Arising from a failable pattern in a
                                    -- monad comprehension
      | IfOrigin            -- Arising from an if statement
      | ProcOrigin          -- Arising from a proc expression
      | AnnOrigin           -- An annotation

      | FunDepOrigin1       -- A functional dependency from combining
            PredType CtOrigin RealSrcSpan      -- This constraint arising from ...
            PredType CtOrigin RealSrcSpan      -- and this constraint arising from ...

      | FunDepOrigin2       -- A functional dependency from combining
            PredType CtOrigin   -- This constraint arising from ...
            PredType SrcSpan    -- and this top-level instance
            -- We only need a CtOrigin on the first, because the location
            -- is pinned on the entire error message

      | ExprHoleOrigin OccName   -- from an expression hole
      | TypeHoleOrigin OccName   -- from a type hole (partial type signature)
      | PatCheckOrigin      -- normalisation of a type during pattern-match checking
      | UnboundOccurrenceOf OccName
      | ListOrigin          -- An overloaded list
      | BracketOrigin       -- An overloaded quotation bracket
      | StaticOrigin        -- A static form
      | Shouldn'tHappenOrigin String
                                -- the user should never see this one,
                                -- unless ImpredicativeTypes is on, where all
                                -- bets are off
      | InstProvidedOrigin Module ClsInst
            -- Skolem variable arose when we were testing if an instance
            -- is solvable or not.
      | NonLinearPatternOrigin
      | UsageEnvironmentOf Name

    -- An origin is visible if the place where the constraint arises is manifest
    -- in user code. Currently, all origins are visible except for invisible
    -- TypeEqOrigins. This is used when choosing which error of
    -- several to report
    isVisibleOrigin :: CtOrigin -> Bool
    isVisibleOrigin (TypeEqOrigin { uo_visible = vis }) = vis
    isVisibleOrigin (KindEqOrigin _ _ sub_orig _)       = isVisibleOrigin sub_orig
    isVisibleOrigin _                                   = True

    -- Converts a visible origin to an invisible one, if possible. Currently,
    -- this works only for TypeEqOrigin
    toInvisibleOrigin :: CtOrigin -> CtOrigin
    toInvisibleOrigin orig@(TypeEqOrigin {}) = orig { uo_visible = False }
    toInvisibleOrigin orig                   = orig

    isGivenOrigin :: CtOrigin -> Bool
    isGivenOrigin (GivenOrigin {})              = True
    isGivenOrigin (FunDepOrigin1 _ o1 _ _ o2 _) = isGivenOrigin o1 && isGivenOrigin o2
    isGivenOrigin (FunDepOrigin2 _ o1 _ _)      = isGivenOrigin o1
    isGivenOrigin _                             = False

    instance Outputable CtOrigin where
      ppr = pprCtOrigin

    ctoHerald :: SDoc
    ctoHerald = text "arising from"

    -- | Extract a suitable CtOrigin from a HsExpr
    lexprCtOrigin :: LHsExpr GhcRn -> CtOrigin
    lexprCtOrigin (L _ e) = exprCtOrigin e

    exprCtOrigin :: HsExpr GhcRn -> CtOrigin
    exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name
    exprCtOrigin (HsUnboundVar _ uv)  = UnboundOccurrenceOf uv
    exprCtOrigin (HsConLikeOut {})    = panic "exprCtOrigin HsConLikeOut"
    exprCtOrigin (HsRecFld _ f)       = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f)
    exprCtOrigin (HsOverLabel _ _ l)  = OverLabelOrigin l
    exprCtOrigin (HsIPVar _ ip)       = IPOccOrigin ip
    exprCtOrigin (HsOverLit _ lit)    = LiteralOrigin lit
    exprCtOrigin (HsLit {})           = Shouldn'tHappenOrigin "concrete literal"
    exprCtOrigin (HsLam _ matches)    = matchesCtOrigin matches
    exprCtOrigin (HsLamCase _ ms)     = matchesCtOrigin ms
    exprCtOrigin (HsApp _ e1 _)       = lexprCtOrigin e1
    exprCtOrigin (HsAppType _ e1 _)   = lexprCtOrigin e1
    exprCtOrigin (OpApp _ _ op _)     = lexprCtOrigin op
    exprCtOrigin (NegApp _ e _)       = lexprCtOrigin e
    exprCtOrigin (HsPar _ e)          = lexprCtOrigin e
    exprCtOrigin (SectionL _ _ _)     = SectionOrigin
    exprCtOrigin (SectionR _ _ _)     = SectionOrigin
    exprCtOrigin (ExplicitTuple {})   = Shouldn'tHappenOrigin "explicit tuple"
    exprCtOrigin ExplicitSum{}        = Shouldn'tHappenOrigin "explicit sum"
    exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches
    exprCtOrigin (HsIf {})           = Shouldn'tHappenOrigin "if expression"
    exprCtOrigin (HsMultiIf _ rhs)   = lGRHSCtOrigin rhs
    exprCtOrigin (HsLet _ _ e)       = lexprCtOrigin e
    exprCtOrigin (HsDo {})           = DoOrigin
    exprCtOrigin (ExplicitList {})   = Shouldn'tHappenOrigin "list"
    exprCtOrigin (RecordCon {})      = Shouldn'tHappenOrigin "record construction"
    exprCtOrigin (RecordUpd {})      = Shouldn'tHappenOrigin "record update"
    exprCtOrigin (ExprWithTySig {})  = ExprSigOrigin
    exprCtOrigin (ArithSeq {})       = Shouldn'tHappenOrigin "arithmetic sequence"
    exprCtOrigin (HsPragE _ _ e)     = lexprCtOrigin e
    exprCtOrigin (HsBracket {})      = Shouldn'tHappenOrigin "TH bracket"
    exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut"
    exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut"
    exprCtOrigin (HsSpliceE {})      = Shouldn'tHappenOrigin "TH splice"
    exprCtOrigin (HsProc {})         = Shouldn'tHappenOrigin "proc"
    exprCtOrigin (HsStatic {})       = Shouldn'tHappenOrigin "static expression"
    exprCtOrigin (HsTick _ _ e)           = lexprCtOrigin e
    exprCtOrigin (HsBinTick _ _ _ e)      = lexprCtOrigin e
    exprCtOrigin (XExpr (HsExpanded a _)) = exprCtOrigin a

    -- | Extract a suitable CtOrigin from a MatchGroup
    matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin
    matchesCtOrigin (MG { mg_alts = alts })
      | L _ [L _ match] <- alts
      , Match { m_grhss = grhss } <- match
      = grhssCtOrigin grhss

      | otherwise
      = Shouldn'tHappenOrigin "multi-way match"

    -- | Extract a suitable CtOrigin from guarded RHSs
    grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin
    grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss

    -- | Extract a suitable CtOrigin from a list of guarded RHSs
    lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin
    lGRHSCtOrigin [L _ (GRHS _ _ (L _ e))] = exprCtOrigin e
    lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS"

    pprCtOrigin :: CtOrigin -> SDoc
    -- "arising from ..."
    -- Not an instance of Outputable because of the "arising from" prefix
    pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk

    pprCtOrigin (SpecPragOrigin ctxt)
      = case ctxt of
           FunSigCtxt n _ -> text "for" <+> quotes (ppr n)
           SpecInstCtxt   -> text "a SPECIALISE INSTANCE pragma"
           _              -> text "a SPECIALISE pragma"  -- Never happens I think

    pprCtOrigin (FunDepOrigin1 pred1 orig1 loc1 pred2 orig2 loc2)
      = hang (ctoHerald <+> text "a functional dependency between constraints:")
           2 (vcat [ hang (quotes (ppr pred1)) 2 (pprCtOrigin orig1 <+> text "at" <+> ppr loc1)
                   , hang (quotes (ppr pred2)) 2 (pprCtOrigin orig2 <+> text "at" <+> ppr loc2) ])

    pprCtOrigin (FunDepOrigin2 pred1 orig1 pred2 loc2)
      = hang (ctoHerald <+> text "a functional dependency between:")
           2 (vcat [ hang (text "constraint" <+> quotes (ppr pred1))
                        2 (pprCtOrigin orig1 )
                   , hang (text "instance" <+> quotes (ppr pred2))
                        2 (text "at" <+> ppr loc2) ])

    pprCtOrigin (KindEqOrigin t1 (Just t2) _ _)
      = hang (ctoHerald <+> text "a kind equality arising from")
           2 (sep [ppr t1, char '~', ppr t2])

    pprCtOrigin AssocFamPatOrigin
      = text "when matching a family LHS with its class instance head"

    pprCtOrigin (KindEqOrigin t1 Nothing _ _)
      = hang (ctoHerald <+> text "a kind equality when matching")
           2 (ppr t1)

    pprCtOrigin (UnboundOccurrenceOf name)
      = ctoHerald <+> text "an undeclared identifier" <+> quotes (ppr name)

    pprCtOrigin (DerivOriginDC dc n _)
      = hang (ctoHerald <+> text "the" <+> speakNth n
              <+> text "field of" <+> quotes (ppr dc))
           2 (parens (text "type" <+> quotes (ppr (scaledThing ty))))
      where
        ty = dataConOrigArgTys dc !! (n-1)

    pprCtOrigin (DerivOriginCoerce meth ty1 ty2 _)
      = hang (ctoHerald <+> text "the coercion of the method" <+> quotes (ppr meth))
           2 (sep [ text "from type" <+> quotes (ppr ty1)
                  , nest 2 $ text "to type" <+> quotes (ppr ty2) ])

    pprCtOrigin (DoPatOrigin pat)
        = ctoHerald <+> text "a do statement"
          $$
          text "with the failable pattern" <+> quotes (ppr pat)

    pprCtOrigin (MCompPatOrigin pat)
        = ctoHerald <+> hsep [ text "the failable pattern"
               , quotes (ppr pat)
               , text "in a statement in a monad comprehension" ]

    pprCtOrigin (Shouldn'tHappenOrigin note)
      = sdocOption sdocImpredicativeTypes $ \case
          True  -> text "a situation created by impredicative types"
          False -> vcat [ text "<< This should not appear in error messages. If you see this"
                        , text "in an error message, please report a bug mentioning"
                            <+> quotes (text note) <+> text "at"
                        , text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>"
                        ]

    pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) })
      = hang (ctoHerald <+> text "the \"provided\" constraints claimed by")
           2 (text "the signature of" <+> quotes (ppr name))

    pprCtOrigin (InstProvidedOrigin mod cls_inst)
      = vcat [ text "arising when attempting to show that"
             , ppr cls_inst
             , text "is provided by" <+> quotes (ppr mod)]

    pprCtOrigin simple_origin
      = ctoHerald <+> pprCtO simple_origin

    -- | Short one-liners
    pprCtO :: CtOrigin -> SDoc
    pprCtO (OccurrenceOf name)   = hsep [text "a use of", quotes (ppr name)]
    pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)]
    pprCtO AppOrigin             = text "an application"
    pprCtO (IPOccOrigin name)    = hsep [text "a use of implicit parameter", quotes (ppr name)]
    pprCtO (OverLabelOrigin l)   = hsep [text "the overloaded label"
                                        ,quotes (char '#' <> ppr l)]
    pprCtO RecordUpdOrigin       = text "a record update"
    pprCtO ExprSigOrigin         = text "an expression type signature"
    pprCtO PatSigOrigin          = text "a pattern type signature"
    pprCtO PatOrigin             = text "a pattern"
    pprCtO ViewPatOrigin         = text "a view pattern"
    pprCtO IfOrigin              = text "an if expression"
    pprCtO (LiteralOrigin lit)   = hsep [text "the literal", quotes (ppr lit)]
    pprCtO (ArithSeqOrigin seq)  = hsep [text "the arithmetic sequence", quotes (ppr seq)]
    pprCtO SectionOrigin         = text "an operator section"
    pprCtO AssocFamPatOrigin     = text "the LHS of a family instance"
    pprCtO TupleOrigin           = text "a tuple"
    pprCtO NegateOrigin          = text "a use of syntactic negation"
    pprCtO (ScOrigin n)          = text "the superclasses of an instance declaration"
                                   <> whenPprDebug (parens (ppr n))
    pprCtO DerivClauseOrigin     = text "the 'deriving' clause of a data type declaration"
    pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration"
    pprCtO DefaultOrigin         = text "a 'default' declaration"
    pprCtO DoOrigin              = text "a do statement"
    pprCtO MCompOrigin           = text "a statement in a monad comprehension"
    pprCtO ProcOrigin            = text "a proc expression"
    pprCtO (TypeEqOrigin t1 t2 _ _)= text "a type equality" <+> sep [ppr t1, char '~', ppr t2]
    pprCtO AnnOrigin             = text "an annotation"
    pprCtO (ExprHoleOrigin occ)  = text "a use of" <+> quotes (ppr occ)
    pprCtO (TypeHoleOrigin occ)  = text "a use of wildcard" <+> quotes (ppr occ)
    pprCtO PatCheckOrigin        = text "a pattern-match completeness check"
    pprCtO ListOrigin            = text "an overloaded list"
    pprCtO StaticOrigin          = text "a static form"
    pprCtO NonLinearPatternOrigin = text "a non-linear pattern"
    pprCtO (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)]
    pprCtO BracketOrigin         = text "a quotation bracket"
    pprCtO _                     = panic "pprCtOrigin"