{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE UndecidableInstances #-}

module GHC.Tc.Types.ErrCtxt
  ( ErrCtxt, ErrCtxtMsg(..)
  , UserSigType(..), FunAppCtxtFunArg(..)
  , TyConInstFlavour(..)
  )
  where

import GHC.Prelude
import GHC.Hs.Expr
import GHC.Hs.Extension

import GHC.Parser.Annotation ( LocatedN, SrcSpanAnnA )

import GHC.Tc.Errors.Types.PromotionErr ( TermLevelUseCtxt )
import GHC.Tc.Types.Origin   ( CtOrigin, UserTypeCtxt, ExpectedFunTyOrigin )
import GHC.Tc.Utils.TcType   ( TcType, TcTyCon )
import GHC.Tc.Zonk.Monad     ( ZonkM )

import GHC.Types.Basic       ( TyConFlavour )
import GHC.Types.Name        ( Name )
import GHC.Types.SrcLoc      ( SrcSpan )
import GHC.Types.Var         ( Id, TyCoVar )
import GHC.Types.Var.Env     ( TidyEnv )

import GHC.Unit.Types ( Module, InstantiatedModule )

import GHC.Core.Class    ( Class )
import GHC.Core.ConLike  ( ConLike )
import GHC.Core.PatSyn   ( PatSyn )
import GHC.Core.TyCon    ( TyCon )
import GHC.Core.TyCo.Rep ( Type, ThetaType, PredType )

import GHC.Unit.State ( UnitState )

import GHC.Data.FastString  ( FastString )
import GHC.Utils.Outputable ( Outputable(..) )

import Language.Haskell.Syntax.Basic ( FieldLabelString(..) )
import Language.Haskell.Syntax
import GHC.Boot.TH.Syntax qualified as TH

import qualified Data.List.NonEmpty as NE

--------------------------------------------------------------------------------

-- | Additional context to include in an error message, e.g.
-- "In the type signature ...", "In the ambiguity check for ...", etc.
type ErrCtxt = (Bool, TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg))
        -- Monadic so that we have a chance
        -- to deal with bound type variables just before error
        -- message construction

        -- Bool:  True <=> this is a landmark context; do not
        --                 discard it when trimming for display

--------------------------------------------------------------------------------
-- Error message contexts

data UserSigType p
  = UserLHsSigType !(LHsSigType p)
  | UserLHsType !(LHsType p)

instance OutputableBndrId p => Outputable (UserSigType (GhcPass p)) where
  ppr (UserLHsSigType ty) = ppr ty
  ppr (UserLHsType ty) = ppr ty

data FunAppCtxtFunArg
  = FunAppCtxtExpr !(HsExpr GhcRn) !(HsExpr GhcRn)
  | FunAppCtxtTy   !(LHsType GhcRn) !(LHsType GhcRn)

-- | Like 'TyConFlavour' but for instance declarations, with
-- the additional information of whether this we are dealing with
-- a default declaration.
data TyConInstFlavour
  = TyConInstFlavour
  { tyConInstFlavour :: !(TyConFlavour TyCon)
  , tyConInstIsDefault :: !Bool
  }

-- | The "context" of an error message, e.g. "In the expression <...>",
-- "In the pattern <...>", or "In the equations for closed type family <...>".
data ErrCtxtMsg
  -- | In an expression.
  = ExprCtxt !(HsExpr GhcRn)
  -- | In a user-written context.
  | ThetaCtxt !UserTypeCtxt !ThetaType
  -- | In a quantified constraint.
  | QuantifiedCtCtxt !PredType
  -- | When checking an inferred type.
  | InferredTypeCtxt !Name !TcType
  -- | In an inline pragma, or a fixity signature,
  -- or a type signature, or... (see 'Sig').
  | SigCtxt !(Sig GhcRn)
  -- | In a user-written type signature.
  | UserSigCtxt !UserTypeCtxt !(UserSigType GhcRn)
  -- | In a record update.
  | RecordUpdCtxt !(NE.NonEmpty ConLike) ![Name] ![TyCoVar]
  -- | In a class method.
  | ClassOpCtxt !Id !Type
  -- | In the instance type signature of a class method.
  | MethSigCtxt !Name !TcType !TcType
  -- | In a pattern type signature.
  | PatSigErrCtxt !TcType !TcType
  -- | In a pattern.
  | PatCtxt !(Pat GhcRn)
  -- | In a pattern synonym declaration.
  | PatSynDeclCtxt !Name
  -- | In a pattern matching context, e.g. a equation for a function binding,
  -- or a case alternative, ...
  | MatchCtxt !HsMatchContextRn
  -- | In a match in a pattern matching context,
  -- either for an expression or for an arrow command.
  | forall body. (Outputable body)
  => MatchInCtxt !(Match GhcRn body)
  -- | In a function application.
  | FunAppCtxt !FunAppCtxtFunArg !Int
  -- | In a function call.
  | FunTysCtxt !ExpectedFunTyOrigin !Type !Int !Int
  -- | In the result of a function call.
  | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int
  -- | In the declaration of a type constructor.
  | TyConDeclCtxt !Name !(TyConFlavour TyCon)
  -- | In a type or data family instance (or default instance).
  | TyConInstCtxt !Name !TyConInstFlavour
  -- | In the declaration of a data constructor.
  | DataConDefCtxt !(NE.NonEmpty (LocatedN Name))
  -- | In the result type of a data constructor.
  | DataConResTyCtxt !(NE.NonEmpty (LocatedN Name))
  -- | In the equations for a closed type family.
  | ClosedFamEqnCtxt !TyCon
  -- | In the expansion of a type synonym.
  | TySynErrCtxt !TyCon
  -- | In a role annotation.
  | RoleAnnotErrCtxt !Name
  -- | In an arrow command.
  | CmdCtxt !(HsCmd GhcRn)
  -- | In an instance declaration.
  | InstDeclErrCtxt !(Either (LHsType GhcRn) PredType)
  -- | In a default declaration.
  | DefaultDeclErrCtxt { ddec_in_type_list :: !Bool }
  -- | In the body of a static form.
  | StaticFormCtxt !(LHsExpr GhcRn)
  -- | In a pattern binding.
  | forall p. OutputableBndrId p
  => PatMonoBindsCtxt !(LPat (GhcPass p)) !(GRHSs GhcRn (LHsExpr GhcRn))
  -- | In a foreign import/export declaration.
  | ForeignDeclCtxt !(ForeignDecl GhcRn)
  -- | In a record field.
  | FieldCtxt !FieldLabelString
  -- | In a type.
  | TypeCtxt !(LHsType GhcRn)
  -- | In a kind.
  | KindCtxt !(LHsKind GhcRn)
  -- | In an ambiguity check.
  | AmbiguityCheckCtxt !UserTypeCtxt !Bool

  -- | In a term-level use of a 'Name'.
  | TermLevelUseCtxt !Name !TermLevelUseCtxt

  -- | When checking the type of the @main@ function.
  | MainCtxt !Name
  -- | Warning emitted when inferring use of visible dependent quantification.
  | VDQWarningCtxt !TcTyCon

  -- | In a statement.
  | forall body.
    ( Anno (StmtLR GhcRn GhcRn body) ~ SrcSpanAnnA
    , Outputable body
    ) => StmtErrCtxt !HsStmtContextRn !(StmtLR GhcRn GhcRn body)

  -- | In an rebindable syntax expression.
  | SyntaxNameCtxt !(HsExpr GhcRn) !CtOrigin !TcType !SrcSpan
  -- | In a RULE.
  | RuleCtxt !FastString
  -- | In a subtype check.
  | SubTypeCtxt !TcType !TcType

  -- | In an export.
  | forall p. OutputableBndrId p
  => ExportCtxt (IE (GhcPass p))
  -- | In an export of a pattern synonym.
  | PatSynExportCtxt !PatSyn
  -- | In an export of a pattern synonym record field.
  | PatSynRecSelExportCtxt !PatSyn !Name

  -- | In an annotation.
  | forall p. OutputableBndrId p
  => AnnCtxt (AnnDecl (GhcPass p))

  -- | In a specialise pragma.
  | SpecPragmaCtxt !(Sig GhcRn)

  -- | In a deriving clause.
  | DerivInstCtxt !PredType
  -- | In a standalone deriving clause.
  | StandaloneDerivCtxt !(LHsSigWcType GhcRn)
  -- | When typechecking the body of a derived instance.
  | DerivBindCtxt !Id !Class ![Type]

  -- | In an untyped Template Haskell quote.
  | UntypedTHBracketCtxt !(HsQuote GhcPs)
  -- | In a typed Template Haskell quote.
  | forall p. OutputableBndrId p
  => TypedTHBracketCtxt !(LHsExpr (GhcPass p))
  -- | In an untyped Template Haskell splice or quasi-quote.
  | UntypedSpliceCtxt !(HsUntypedSplice GhcPs)
  -- | In a typed Template Haskell splice.
  | forall p. OutputableBndrId p
  => TypedSpliceCtxt !(Maybe SplicePointName) !(HsTypedSplice (GhcPass p))
  -- | In the result of a typed Template Haskell splice.
  | TypedSpliceResultCtxt !(LHsExpr GhcTc)
  -- | In an argument to the Template Haskell @reifyInstances@ function.
  | ReifyInstancesCtxt !TH.Name ![TH.Type]

  -- | While merging Backpack signatures.
  | MergeSignaturesCtxt !UnitState !ModuleName ![InstantiatedModule]
  -- | While checking that a module implements a Backpack signature.
  | CheckImplementsCtxt !UnitState !Module !InstantiatedModule