{-# 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 (..),
  stripTcRnMessageContext,
  -- * Parsing error message
  PsMessage(..),
  -- * Desugaring diagnostic
  DsMessage (..),
  -- * Driver error message
  DriverMessage (..),
  -- * General Diagnostics
  Diagnostic(..),
  -- * Prisms for error selection
  _TcRnMessage,
  _GhcPsMessage,
  _GhcDsMessage,
  _GhcDriverMessage,
  ) where

import           Control.Lens
import           GHC.Driver.Errors.Types
import           GHC.HsToCore.Errors.Types
import           GHC.Tc.Errors.Types
import           GHC.Types.Error

_TcRnMessage :: Prism' GhcMessage TcRnMessage
_TcRnMessage :: Prism' GhcMessage TcRnMessage
_TcRnMessage = (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 } )