Fix testsuite

Author: wz1000

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

@@ -20,6 +20,13 @@ module Development.IDE.GHC.Compat.Outputable (
 #if MIN_VERSION_ghc(9,3,0)
     DiagnosticReason(..),
     renderDiagnosticMessageWithHints,
+    pprMsgEnvelopeBagWithLoc,
+    Error.getMessages,
+    renderWithContext,
+    defaultSDocContext,
+    errMsgDiagnostic,
+    unDecorated,
+    diagnosticMessage,
 #else
     pprWarning,
     pprError,
@@ -29,6 +36,7 @@ module Development.IDE.GHC.Compat.Outputable (
     MsgEnvelope,
     ErrMsg,
     WarnMsg,
+    SourceError(..),
     errMsgSpan,
     errMsgSeverity,
     formatErrorWithQual,

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Util.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE ScopedTypeVariables       #-}
+{-# LANGUAGE CPP                       #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 -- |Debug utilities
@@ -11,15 +12,16 @@ module Ide.Plugin.Eval.Util (
     logWith,
 ) where
 
-import           Control.Exception               (SomeException, evaluate)
+import           Control.Exception               (SomeException, evaluate, fromException)
 import           Control.Monad.IO.Class          (MonadIO (liftIO))
 import           Control.Monad.Trans.Except      (ExceptT (..), runExceptT)
 import           Data.Aeson                      (Value (Null))
 import           Data.String                     (IsString (fromString))
 import qualified Data.Text                       as T
 import           Development.IDE                 (IdeState, Priority (..),
                                                   ideLogger, logPriority)
-import           Development.IDE.GHC.Compat.Util (MonadCatch, catch)
+import           Development.IDE.GHC.Compat.Util (MonadCatch, catch, bagToList)
+import           Development.IDE.GHC.Compat.Outputable
 import           GHC.Exts                        (toList)
 import           GHC.Stack                       (HasCallStack, callStack,
                                                   srcLocFile, srcLocStartCol,
@@ -79,4 +81,17 @@ gevaluate :: MonadIO m => a -> m a
 gevaluate = liftIO . evaluate
 
 showErr :: Monad m => SomeException -> m (Either String b)
-showErr = return . Left . show
+showErr e =
+#if MIN_VERSION_ghc(9,3,0)
+  case fromException e of
+    -- On GHC 9.4+, the show instance adds the error message span
+    -- We don't want this for the plugin
+    -- So render without the span.
+    Just (SourceError msgs) -> return $ Left $ renderWithContext defaultSDocContext
+                                             $ vcat
+                                             $ bagToList
+                                             $ fmap (vcat . unDecorated . diagnosticMessage . errMsgDiagnostic)
+                                             $ getMessages msgs
+    _ ->
+#endif
+      return . Left . show $ e

plugins/hls-eval-plugin/test/Main.hs

@@ -81,11 +81,11 @@ tests =
       evalInFile "T8.hs" "-- >>> 3 `div` 0" "-- divide by zero" -- The default for marking exceptions is False
   , goldenWithEval "Applies file LANGUAGE extensions" "T9" "hs"
   , goldenWithEval' "Evaluate a type with :kind!" "T10" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected")
-  , goldenWithEval' "Reports an error for an incorrect type with :kind!" "T11" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
+  , goldenWithEval' "Reports an error for an incorrect type with :kind!" "T11" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected")
   , goldenWithEval' "Shows a kind with :kind" "T12" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected")
-  , goldenWithEval' "Reports an error for an incorrect type with :kind" "T13" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
+  , goldenWithEval' "Reports an error for an incorrect type with :kind" "T13" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected")
   , goldenWithEval "Returns a fully-instantiated type for :type" "T14" "hs"
-  , knownBrokenForGhcVersions [GHC92] "type +v does not work anymore with 9.2" $ goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs"
+  , knownBrokenForGhcVersions [GHC92, GHC94] "type +v does not work anymore with 9.2" $ goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs"
   , goldenWithEval "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" "T16" "hs"
   , goldenWithEval' ":type reports an error when given with unknown +x option" "T17" "hs" (if ghcVersion >= GHC92 then "ghc92.expected" else "expected")
   , goldenWithEval "Reports an error when given with unknown command" "T18" "hs"
@@ -135,7 +135,7 @@ tests =
   , goldenWithEval "The default language extensions for the eval plugin are the same as those for ghci" "TSameDefaultLanguageExtensionsAsGhci" "hs"
   , goldenWithEval "IO expressions are supported, stdout/stderr output is ignored" "TIO" "hs"
   , goldenWithEval "Property checking" "TProperty" "hs"
-  , goldenWithEval "Property checking with exception" "TPropertyError" "hs"
+  , goldenWithEval' "Property checking with exception" "TPropertyError" "hs" (if ghcVersion >= GHC94 then "ghc94.expected" else "expected")
   , goldenWithEval "Prelude has no special treatment, it is imported as stated in the module" "TPrelude" "hs"
   , goldenWithEval "Don't panic on {-# UNPACK #-} pragma" "TUNPACK" "hs"
   , goldenWithEval "Can handle eval inside nested comment properly" "TNested" "hs"