Add GHC Structured Error compatibility module

Add compatibility module for GHC's structured error messages.
Introduce 'Prism's and 'Lens's to easily access nested structures.
Expand documentation for 'StructuredMessage'

Author: fendor

ghcide/ghcide.cabal

@@ -153,6 +153,7 @@ library
     Development.IDE.GHC.Compat.CmdLine
     Development.IDE.GHC.Compat.Driver
     Development.IDE.GHC.Compat.Env
+    Development.IDE.GHC.Compat.Error
     Development.IDE.GHC.Compat.Iface
     Development.IDE.GHC.Compat.Logger
     Development.IDE.GHC.Compat.Outputable

ghcide/src/Development/IDE/GHC/Compat/Error.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Development.IDE.GHC.Compat.Error (
+  -- * Top-level error types and lens for easy access
+  MsgEnvelope(..),
+  msgEnvelopeErrorL,
+  GhcMessage(..),
+  -- * Tc - Rn phase error messages
+  TcRnMessage (..),
+  TcRnMessageDetailed (..),
+  flatTcRnMessage,
+  -- * Parsing error message
+  PsMessage(..),
+  -- * Desugaring diagnostic
+  DsMessage (..),
+  -- * Driver error message
+  DriverMessage (..),
+  -- * Unkown errors
+  UnknownDiagnostic(..),
+  -- * General Diagnostics
+  Diagnostic(..),
+  -- * Prisms for error selection
+  _TcRnMessage,
+  _GhcPsMessage,
+  _GhcDsMessage,
+  _GhcDriverMessage,
+  _GhcUnknownMessage,
+  ) 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' GhcTcRnMessage (\case
+  GhcTcRnMessage tcRnMsg -> Just tcRnMsg
+  _ -> Nothing)
+
+_GhcPsMessage :: Prism' GhcMessage PsMessage
+_GhcPsMessage = prism' GhcPsMessage (\case
+  GhcPsMessage psMsg -> Just psMsg
+  _ -> Nothing)
+
+_GhcDsMessage :: Prism' GhcMessage DsMessage
+_GhcDsMessage = prism' GhcDsMessage (\case
+  GhcDsMessage dsMsg -> Just dsMsg
+  _ -> Nothing)
+
+_GhcDriverMessage :: Prism' GhcMessage DriverMessage
+_GhcDriverMessage = prism' GhcDriverMessage (\case
+  GhcDriverMessage driverMsg -> Just driverMsg
+  _ -> Nothing)
+
+_GhcUnknownMessage :: Prism' GhcMessage UnknownDiagnostic
+_GhcUnknownMessage = prism' GhcUnknownMessage (\case
+  GhcUnknownMessage unknownMsg -> Just unknownMsg
+  _ -> 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. @'flatTcRnMessage'@ recursively unwraps these constructors,
+-- until there are no more constructors with additional context.
+--
+flatTcRnMessage :: TcRnMessage -> TcRnMessage
+flatTcRnMessage = \case
+  TcRnWithHsDocContext _ tcMsg -> flatTcRnMessage tcMsg
+  TcRnMessageWithInfo _ (TcRnMessageDetailed _ tcMsg) -> flatTcRnMessage tcMsg
+  msg -> msg
+
+msgEnvelopeErrorL :: Lens' (MsgEnvelope e) e
+msgEnvelopeErrorL = lens errMsgDiagnostic (\envelope e -> envelope { errMsgDiagnostic = e } )

ghcide/src/Development/IDE/Types/Diagnostics.hs

@@ -14,6 +14,8 @@ module Development.IDE.Types.Diagnostics (
   fdShouldShowDiagnosticL,
   fdStructuredMessageL,
   StructuredMessage(..),
+  _NoStructuredMessage,
+  _SomeStructuredMessage,
   IdeResult,
   LSP.DiagnosticSeverity(..),
   DiagnosticStore,
@@ -192,6 +194,23 @@ instance NFData ShowDiagnostic where
 -- force the GhcMessage inside, so that we can derive Show, Eq, Ord, NFData on
 -- FileDiagnostic. FileDiagnostic only uses this as metadata so we can safely
 -- ignore it in fields.
+--
+-- Instead of pattern matching on these constructors directly, consider 'Prism' from
+-- the 'lens' package. This allows to conveniently pattern match deeply into the 'MsgEnvelope GhcMessage'
+-- constructor.
+-- The module 'Development.IDE.GHC.Compat.Error' implements additional 'Lens's and 'Prism's,
+-- allowing you to avoid importing GHC modules directly.
+--
+-- For example, to pattern match on a 'TcRnMessage' you can use the lens:
+--
+-- @
+--   message ^? _SomeStructuredMessage . msgEnvelopeErrorL . _TcRnMessage
+-- @
+--
+-- This produces a value of type `Maybe TcRnMessage`.
+--
+-- Further, consider utility functions such as 'flatTcRnMessage', which strip
+-- context from error messages which may be more convenient in certain situations.
 data StructuredMessage
   = NoStructuredMessage
   | SomeStructuredMessage (MsgEnvelope GhcMessage)
@@ -244,10 +263,6 @@ data FileDiagnostic = FileDiagnostic
 
 instance NFData FileDiagnostic
 
-makeLensesWith
-    (lensRules & lensField .~ mappingNamer (pure . (++ "L")))
-    ''FileDiagnostic
-
 prettyRange :: Range -> Doc Terminal.AnsiStyle
 prettyRange Range{..} = f _start <> "-" <> f _end
     where f Position{..} = pretty (show $ _line+1) <> colon <> pretty (show $ _character+1)
@@ -314,3 +329,9 @@ srenderColored =
 
 defaultTermWidth :: Int
 defaultTermWidth = 80
+
+makePrisms ''StructuredMessage
+
+makeLensesWith
+    (lensRules & lensField .~ mappingNamer (pure . (++ "L")))
+    ''FileDiagnostic