Fix compatibility with GHC 9.4 and rename function

haskell · Dec 1, 2024 · 6b1f66e · 6b1f66e
1 parent af9cd22
commit 6b1f66e
Show file tree

Hide file tree

Showing 3 changed files with 12 additions and 9 deletions.
diff --git a/ghcide/src/Development/IDE/GHC/Compat/Error.hs b/ghcide/src/Development/IDE/GHC/Compat/Error.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE CPP #-}
 module Development.IDE.GHC.Compat.Error (
   -- * Top-level error types and lens for easy access
   MsgEnvelope(..),
@@ -7,7 +8,7 @@ module Development.IDE.GHC.Compat.Error (
   -- * Error messages for the typechecking and renamer phase
   TcRnMessage (..),
   TcRnMessageDetailed (..),
-  flatTcRnMessage,
+  stripTcRnMessageContext,
   -- * Parsing error message
   PsMessage(..),
   -- * Desugaring diagnostic
@@ -52,13 +53,15 @@ _GhcDriverMessage = prism' GhcDriverMessage (\case
 -- | 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,
+-- the error message. @'stripTcRnMessageContext'@ 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
+stripTcRnMessageContext :: TcRnMessage -> TcRnMessage
+stripTcRnMessageContext = \case
+#if MIN_VERSION_ghc(9, 6, 1)
+  TcRnWithHsDocContext _ tcMsg -> stripTcRnMessageContext tcMsg
+#endif
+  TcRnMessageWithInfo _ (TcRnMessageDetailed _ tcMsg) -> stripTcRnMessageContext tcMsg
   msg -> msg
 
 msgEnvelopeErrorL :: Lens' (MsgEnvelope e) e

diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs
@@ -209,7 +209,7 @@ instance NFData ShowDiagnostic where
 --
 -- This produces a value of type `Maybe TcRnMessage`.
 --
--- Further, consider utility functions such as 'flatTcRnMessage', which strip
+-- Further, consider utility functions such as 'stripTcRnMessageContext', which strip
 -- context from error messages which may be more convenient in certain situations.
 data StructuredMessage
   = NoStructuredMessage

diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs
@@ -32,7 +32,7 @@ import           Development.IDE.Core.PositionMapping (fromCurrentRange)
 import           Development.IDE.GHC.Compat
 import           Development.IDE.GHC.Compat.Error     (TcRnMessage (..),
                                                        _TcRnMessage,
-                                                       flatTcRnMessage,
+                                                       stripTcRnMessageContext,
                                                        msgEnvelopeErrorL)
 import           Development.IDE.GHC.Compat.Util
 import           Development.IDE.Spans.AtPoint        (pointCommand)
@@ -196,7 +196,7 @@ isClassMethodWarning message = case message ^? _SomeStructuredMessage . msgEnvel
     Just tcRnMessage -> isUnsatisfiedMinimalDefWarning tcRnMessage
 
 isUnsatisfiedMinimalDefWarning :: TcRnMessage -> Maybe ClassMinimalDef
-isUnsatisfiedMinimalDefWarning = flatTcRnMessage >>> \case
+isUnsatisfiedMinimalDefWarning = stripTcRnMessageContext >>> \case
     TcRnUnsatisfiedMinimalDef classMinDef -> Just classMinDef
     _ -> Nothing