{-# LANGUAGE CPP             #-}
{-# LANGUAGE TemplateHaskell #-}
module Development.IDE.GHC.Compat.Error (
  -- * Top-level error types and lens for easy access
  MsgEnvelope(..),
  msgEnvelopeErrorL,
  GhcMessage(..),
  -- * Error messages for the typechecking and renamer phase
  TcRnMessage (..),
  TcRnMessageDetailed (..),
  Hole(..),
  stripTcRnMessageContext,
  -- * Parsing error message
  PsMessage(..),
  -- * Desugaring diagnostic
  DsMessage (..),
  -- * Driver error message
  DriverMessage (..),
  -- * General Diagnostics
  Diagnostic(..),
  -- * GHC Hints
  GhcHint (SuggestExtension),
  LanguageExtensionHint (..),
  -- * Prisms and lenses for error selection
  _TcRnMessage,
  _TcRnMessageWithCtx,
  _GhcPsMessage,
  _GhcDsMessage,
  _GhcDriverMessage,
  _ReportHoleError,
  _TcRnIllegalWildcardInType,
  _TcRnPartialTypeSignatures,
  _TcRnMissingSignature,
  _TcRnSolverReport,
  _TcRnMessageWithInfo,
  _TypeHole,
  _ConstraintHole,
  reportContextL,
  reportContentL,
  _MismatchMessage,
  _TypeEqMismatchActual,
  _TypeEqMismatchExpected,
  ) where

import           Control.Lens
import           Development.IDE.GHC.Compat (Type)
import           GHC.Driver.Errors.Types
import           GHC.HsToCore.Errors.Types
import           GHC.Tc.Errors.Types
import           GHC.Tc.Types.Constraint    (Hole (..), HoleSort)
import           GHC.Types.Error

-- | Some 'TcRnMessage's are nested in other constructors for additional context.
-- For example, 'TcRnWithHsDocContext' and 'TcRnMessageWithInfo'.
-- However, in most occasions you don't need the additional context and you just want
-- the error message. @'_TcRnMessage'@ recursively unwraps these constructors,
-- until there are no more constructors with additional context.
--
-- Use @'_TcRnMessageWithCtx'@ if you need the additional context. You can always
-- strip it later using @'stripTcRnMessageContext'@.
--
_TcRnMessage :: Fold GhcMessage TcRnMessage
_TcRnMessage :: Fold GhcMessage TcRnMessage
_TcRnMessage = (TcRnMessage -> f TcRnMessage) -> GhcMessage -> f GhcMessage
Prism' GhcMessage TcRnMessage
_TcRnMessageWithCtx ((TcRnMessage -> f TcRnMessage) -> GhcMessage -> f GhcMessage)
-> ((TcRnMessage -> f TcRnMessage) -> TcRnMessage -> f TcRnMessage)
-> (TcRnMessage -> f TcRnMessage)
-> GhcMessage
-> f GhcMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TcRnMessage -> TcRnMessage)
-> (TcRnMessage -> f TcRnMessage) -> TcRnMessage -> f TcRnMessage
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to TcRnMessage -> TcRnMessage
stripTcRnMessageContext

_TcRnMessageWithCtx :: Prism' GhcMessage TcRnMessage
_TcRnMessageWithCtx :: Prism' GhcMessage TcRnMessage
_TcRnMessageWithCtx = (TcRnMessage -> GhcMessage)
-> (GhcMessage -> Maybe TcRnMessage)
-> Prism' GhcMessage TcRnMessage
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' TcRnMessage -> GhcMessage
GhcTcRnMessage (\case
  GhcTcRnMessage TcRnMessage
tcRnMsg -> TcRnMessage -> Maybe TcRnMessage
forall a. a -> Maybe a
Just TcRnMessage
tcRnMsg
  GhcMessage
_ -> Maybe TcRnMessage
forall a. Maybe a
Nothing)

_GhcPsMessage :: Prism' GhcMessage PsMessage
_GhcPsMessage :: Prism' GhcMessage PsMessage
_GhcPsMessage = (PsMessage -> GhcMessage)
-> (GhcMessage -> Maybe PsMessage) -> Prism' GhcMessage PsMessage
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' PsMessage -> GhcMessage
GhcPsMessage (\case
  GhcPsMessage PsMessage
psMsg -> PsMessage -> Maybe PsMessage
forall a. a -> Maybe a
Just PsMessage
psMsg
  GhcMessage
_ -> Maybe PsMessage
forall a. Maybe a
Nothing)

_GhcDsMessage :: Prism' GhcMessage DsMessage
_GhcDsMessage :: Prism' GhcMessage DsMessage
_GhcDsMessage = (DsMessage -> GhcMessage)
-> (GhcMessage -> Maybe DsMessage) -> Prism' GhcMessage DsMessage
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' DsMessage -> GhcMessage
GhcDsMessage (\case
  GhcDsMessage DsMessage
dsMsg -> DsMessage -> Maybe DsMessage
forall a. a -> Maybe a
Just DsMessage
dsMsg
  GhcMessage
_ -> Maybe DsMessage
forall a. Maybe a
Nothing)

_GhcDriverMessage :: Prism' GhcMessage DriverMessage
_GhcDriverMessage :: Prism' GhcMessage DriverMessage
_GhcDriverMessage = (DriverMessage -> GhcMessage)
-> (GhcMessage -> Maybe DriverMessage)
-> Prism' GhcMessage DriverMessage
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' DriverMessage -> GhcMessage
GhcDriverMessage (\case
  GhcDriverMessage DriverMessage
driverMsg -> DriverMessage -> Maybe DriverMessage
forall a. a -> Maybe a
Just DriverMessage
driverMsg
  GhcMessage
_ -> Maybe DriverMessage
forall a. Maybe a
Nothing)

-- | Some 'TcRnMessage's are nested in other constructors for additional context.
-- For example, 'TcRnWithHsDocContext' and 'TcRnMessageWithInfo'.
-- However, in some occasions you don't need the additional context and you just want
-- the error message. @'stripTcRnMessageContext'@ recursively unwraps these constructors,
-- until there are no more constructors with additional context.
--
stripTcRnMessageContext :: TcRnMessage -> TcRnMessage
stripTcRnMessageContext :: TcRnMessage -> TcRnMessage
stripTcRnMessageContext = \case
#if MIN_VERSION_ghc(9, 6, 1)
  TcRnWithHsDocContext HsDocContext
_ TcRnMessage
tcMsg -> TcRnMessage -> TcRnMessage
stripTcRnMessageContext TcRnMessage
tcMsg
#endif
  TcRnMessageWithInfo UnitState
_ (TcRnMessageDetailed ErrInfo
_ TcRnMessage
tcMsg) -> TcRnMessage -> TcRnMessage
stripTcRnMessageContext TcRnMessage
tcMsg
  TcRnMessage
msg -> TcRnMessage
msg

msgEnvelopeErrorL :: Lens' (MsgEnvelope e) e
msgEnvelopeErrorL :: forall e (f :: * -> *).
Functor f =>
(e -> f e) -> MsgEnvelope e -> f (MsgEnvelope e)
msgEnvelopeErrorL = (MsgEnvelope e -> e)
-> (MsgEnvelope e -> e -> MsgEnvelope e)
-> Lens (MsgEnvelope e) (MsgEnvelope e) e e
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens MsgEnvelope e -> e
forall e. MsgEnvelope e -> e
errMsgDiagnostic (\MsgEnvelope e
envelope e
e -> MsgEnvelope e
envelope { errMsgDiagnostic = e } )

makePrisms ''TcRnMessage

makeLensesWith
    (lensRules & lensField .~ mappingNamer (pure . (++ "L")))
    ''SolverReportWithCtxt

makePrisms ''TcSolverReportMsg

makePrisms ''HoleSort

-- | Focus 'MismatchMsg' from 'TcSolverReportMsg'. Currently, 'MismatchMsg' can be
-- extracted from 'CannotUnifyVariable' and 'Mismatch' constructors.
_MismatchMessage :: Traversal' TcSolverReportMsg MismatchMsg
_MismatchMessage :: Traversal' TcSolverReportMsg MismatchMsg
_MismatchMessage MismatchMsg -> f MismatchMsg
focus (Mismatch MismatchMsg
msg Maybe TyVarInfo
t [AmbiguityInfo]
a Maybe CoercibleMsg
c) = (\MismatchMsg
msg' -> MismatchMsg
-> Maybe TyVarInfo
-> [AmbiguityInfo]
-> Maybe CoercibleMsg
-> TcSolverReportMsg
Mismatch MismatchMsg
msg' Maybe TyVarInfo
t [AmbiguityInfo]
a Maybe CoercibleMsg
c) (MismatchMsg -> TcSolverReportMsg)
-> f MismatchMsg -> f TcSolverReportMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MismatchMsg -> f MismatchMsg
focus MismatchMsg
msg
_MismatchMessage MismatchMsg -> f MismatchMsg
focus (CannotUnifyVariable MismatchMsg
msg CannotUnifyVariableReason
a) = (MismatchMsg -> CannotUnifyVariableReason -> TcSolverReportMsg)
-> CannotUnifyVariableReason -> MismatchMsg -> TcSolverReportMsg
forall a b c. (a -> b -> c) -> b -> a -> c
flip MismatchMsg -> CannotUnifyVariableReason -> TcSolverReportMsg
CannotUnifyVariable CannotUnifyVariableReason
a (MismatchMsg -> TcSolverReportMsg)
-> f MismatchMsg -> f TcSolverReportMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MismatchMsg -> f MismatchMsg
focus MismatchMsg
msg
_MismatchMessage MismatchMsg -> f MismatchMsg
_ TcSolverReportMsg
report = TcSolverReportMsg -> f TcSolverReportMsg
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TcSolverReportMsg
report

-- | Focus 'teq_mismatch_expected' from 'TypeEqMismatch'.
_TypeEqMismatchExpected :: Traversal' MismatchMsg Type
#if MIN_VERSION_ghc(9,10,2)
_TypeEqMismatchExpected focus mismatch@(TypeEqMismatch _ _ _ expected _ _ _) =
    (\expected' -> mismatch { teq_mismatch_expected = expected' }) <$> focus expected
#else
_TypeEqMismatchExpected :: Traversal' MismatchMsg TcType
_TypeEqMismatchExpected TcType -> f TcType
focus mismatch :: MismatchMsg
mismatch@(TypeEqMismatch Bool
_ ErrorItem
_ TcType
_ TcType
_ TcType
expected TcType
_ Maybe TypedThing
_ Maybe SameOccInfo
_) =
    (\TcType
expected' -> MismatchMsg
mismatch { teq_mismatch_expected = expected' }) (TcType -> MismatchMsg) -> f TcType -> f MismatchMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcType -> f TcType
focus TcType
expected
#endif
_TypeEqMismatchExpected TcType -> f TcType
_ MismatchMsg
mismatch = MismatchMsg -> f MismatchMsg
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MismatchMsg
mismatch

-- | Focus 'teq_mismatch_actual' from 'TypeEqMismatch'.
_TypeEqMismatchActual :: Traversal' MismatchMsg Type
#if MIN_VERSION_ghc(9,10,2)
_TypeEqMismatchActual focus mismatch@(TypeEqMismatch _ _ _ _ actual _ _) =
    (\actual' -> mismatch { teq_mismatch_actual = actual' }) <$> focus actual
#else
_TypeEqMismatchActual :: Traversal' MismatchMsg TcType
_TypeEqMismatchActual TcType -> f TcType
focus mismatch :: MismatchMsg
mismatch@(TypeEqMismatch Bool
_ ErrorItem
_ TcType
_ TcType
_ TcType
_ TcType
actual Maybe TypedThing
_ Maybe SameOccInfo
_) =
    (\TcType
actual' -> MismatchMsg
mismatch { teq_mismatch_expected = actual' }) (TcType -> MismatchMsg) -> f TcType -> f MismatchMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TcType -> f TcType
focus TcType
actual
#endif
_TypeEqMismatchActual TcType -> f TcType
_ MismatchMsg
mismatch = MismatchMsg -> f MismatchMsg
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MismatchMsg
mismatch