Use -fno-show-error-context from GHC 9.8

ghcide/session-loader/Development/IDE/Session.hs

@@ -638,7 +638,7 @@
                  [] -> error $ "GHC version could not be parsed: " <> version
                  ((runTime, _):_)
                    | compileTime == runTime -> do
                      atomicModifyIORef' cradle_files (\xs -> (cfp:xs,()))
                      session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)
                    | otherwise -> return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])
              -- Failure case, either a cradle error or the none cradle
@@ -886,7 +886,7 @@
             x <- bagToList $ mapBag errMsgDiagnostic $ unionManyBags $ map Compat.getMessages closure_errs
             DriverHomePackagesNotClosed us <- pure x
             pure us
         isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units
     -- Whenever we spin up a session on Linux, dynamically load libm.so.6
     -- in. We need this in case the binary is statically linked, in which
     -- case the interactive session will fail when trying to load
@@ -1161,6 +1161,9 @@
               Just wdir -> compRoot </> wdir
         let dflags''' =
               setWorkingDirectory root $
+#if MIN_VERSION_ghc(9,8,0)
+              setNoShowErrorContext $
+#endif
               disableWarningsAsErrors $
               -- disabled, generated directly by ghcide instead
               flip gopt_unset Opt_WriteInterface $
@@ -1175,6 +1178,12 @@
               dflags''
         return (dflags''', targets)
 
+#if MIN_VERSION_ghc(9,8,0)
+setNoShowErrorContext :: DynFlags -> DynFlags
+setNoShowErrorContext df =
+    gopt_unset df Opt_ShowErrorContext
+#endif
+
 setIgnoreInterfacePragmas :: DynFlags -> DynFlags
 setIgnoreInterfacePragmas df =
     gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges

ghcide/src/Development/IDE/GHC/Util.hs

@@ -27,7 +27,8 @@ module Development.IDE.GHC.Util(
     dontWriteHieFiles,
     disableWarningsAsErrors,
     printOutputable,
-    getExtensions
+    getExtensions,
+    textInRange
     ) where
 
 import           Control.Concurrent
@@ -272,3 +273,21 @@ printOutputable =
 
 getExtensions :: ParsedModule -> [Extension]
 getExtensions = toList . extensionFlags . ms_hspp_opts . pm_mod_summary
+
+-- | Returns [start .. end[
+textInRange :: Range -> T.Text -> T.Text
+textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCol)) (Position (fromIntegral -> endRow) (fromIntegral -> endCol))) text =
+    case compare startRow endRow of
+      LT ->
+        let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine
+            (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of
+              [] -> ("", [])
+              firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)
+            maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines
+        in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)
+      EQ ->
+        let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)
+        in T.take (endCol - startCol) (T.drop startCol line)
+      GT -> ""
+    where
+      linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)

plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP             #-}
 {-# LANGUAGE GADTs           #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -203,7 +204,11 @@ isClassNodeIdentifier (Right i) ident  | 'C':':':_ <- unpackFS $ occNameFS $ occ
 isClassNodeIdentifier _ _ = False
 
 isClassMethodWarning :: T.Text -> Bool
+#if MIN_VERSION_ghc(9,8,0)
+isClassMethodWarning = T.isPrefixOf "No explicit implementation for"
+#else
 isClassMethodWarning = T.isPrefixOf "• No explicit implementation for"
+#endif
 
 isInstanceValBind :: ContextInfo -> Bool
 isInstanceValBind (ValBind InstanceBind _ _) = True
@@ -242,4 +247,3 @@ minDefToMethodGroups hsc gblEnv range sigs minDef = makeMethodGroup <$> go minDe
         go (Or ms)    = concatMap (go . unLoc) ms
         go (And ms)   = foldr (liftA2 (<>) . go . unLoc) [[]] ms
         go (Parens m) = go (unLoc m)
-

plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs

@@ -52,7 +52,8 @@ import           Development.IDE.GHC.Error
 import           Development.IDE.GHC.ExactPrint
 import qualified Development.IDE.GHC.ExactPrint                    as E
 import           Development.IDE.GHC.Util                          (printOutputable,
-                                                                    printRdrName)
+                                                                    printRdrName,
+                                                                    textInRange)
 import           Development.IDE.Plugin.CodeAction.Args
 import           Development.IDE.Plugin.CodeAction.ExactPrint
 import           Development.IDE.Plugin.CodeAction.PositionIndexed
@@ -343,12 +344,13 @@ findSigOfBinds range = go
             findSigOfBind range (unLoc lHsBindLR)
     go _ = Nothing
 
-findInstanceHead :: (Outputable (HsType p), p ~ GhcPass p0) => DynFlags -> String -> [LHsDecl p] -> Maybe (LHsType p)
-findInstanceHead df instanceHead decls =
+findInstanceHead :: (p ~ GhcPass p0) => Range -> [LHsDecl p] -> Maybe (LHsType p)
+findInstanceHead diagnosticLocation decls =
   listToMaybe
     [ hsib_body
-      | L _ (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig {sig_body = hsib_body})})) <- decls,
-        showSDoc df (ppr hsib_body) == instanceHead
+      | L (locA -> instanceLocation) (InstD _ (ClsInstD _ ClsInstDecl {cid_poly_ty = (unLoc -> HsSig {sig_body = hsib_body})})) <- decls
+      , Just instanceRange <- [srcSpanToRange instanceLocation]
+      , (subRange diagnosticLocation instanceRange)
     ]
 
 #if MIN_VERSION_ghc(9,9,0)
@@ -832,7 +834,15 @@ suggestAddTypeAnnotationToSatisfyConstraints sourceOpt Diagnostic{_range=_range,
     | otherwise = []
     where
       makeAnnotatedLit ty lit = "(" <> lit <> " :: " <> ty <> ")"
-#if MIN_VERSION_ghc(9,4,0)
+#if MIN_VERSION_ghc(9,8,0)
+      pat multiple at _ _ = T.concat [ ".*Defaulting the type variable "
+                                       , ".*to type ‘([^ ]+)’ "
+                                       , "in the following constraint"
+                                       , if multiple then "s" else " "
+                                       , ".*arising from the literal ‘(.+)’"
+                                       , if at then ".+at ([^ ]*)" else ""
+                                       ]
+#elif MIN_VERSION_ghc(9,4,0)
       pat multiple at inArg inExpr = T.concat [ ".*Defaulting the type variable "
                                        , ".*to type ‘([^ ]+)’ "
                                        , "in the following constraint"
@@ -1246,7 +1256,7 @@ suggestConstraint df ps diag@Diagnostic {..}
 #endif
         codeAction = if _message =~ ("the type signature for:" :: String)
                         then suggestFunctionConstraint df parsedSource
-                        else suggestInstanceConstraint df parsedSource
+                        else suggestInstanceConstraint parsedSource
      in codeAction diag missingConstraint
   | otherwise = []
     where
@@ -1268,9 +1278,9 @@ suggestConstraint df ps diag@Diagnostic {..}
         in getCorrectGroup <$> match
 
 -- | Suggests a constraint for an instance declaration for which a constraint is missing.
-suggestInstanceConstraint :: DynFlags -> ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)]
+suggestInstanceConstraint :: ParsedSource -> Diagnostic -> T.Text -> [(T.Text, Rewrite)]
 
-suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint
+suggestInstanceConstraint (L _ HsModule {hsmodDecls}) Diagnostic {..} missingConstraint
   | Just instHead <- instanceHead
   = [(actionTitle missingConstraint , appendConstraint (T.unpack missingConstraint) instHead)]
   | otherwise = []
@@ -1282,8 +1292,7 @@ suggestInstanceConstraint df (L _ HsModule {hsmodDecls}) Diagnostic {..} missing
         -- • In the expression: x == y
         --   In an equation for ‘==’: (Wrap x) == (Wrap y) = x == y
         --   In the instance declaration for ‘Eq (Wrap a)’
-        | Just [instanceDeclaration] <- matchRegexUnifySpaces _message "In the instance declaration for ‘([^`]*)’"
-        , Just instHead <- findInstanceHead df (T.unpack instanceDeclaration) hsmodDecls
+        | Just instHead <- findInstanceHead _range hsmodDecls
         = Just instHead
         -- Suggests a constraint for an instance declaration with one or more existing constraints.
         -- • Could not deduce (Eq b) arising from a use of ‘==’
@@ -1939,24 +1948,6 @@ splitTextAtPosition (Position (fromIntegral -> row) (fromIntegral -> col)) x
         = (T.intercalate "\n" $ preRow ++ [preCol], T.intercalate "\n" $ postCol : postRow)
     | otherwise = (x, T.empty)
 
--- | Returns [start .. end[
-textInRange :: Range -> T.Text -> T.Text
-textInRange (Range (Position (fromIntegral -> startRow) (fromIntegral -> startCol)) (Position (fromIntegral -> endRow) (fromIntegral -> endCol))) text =
-    case compare startRow endRow of
-      LT ->
-        let (linesInRangeBeforeEndLine, endLineAndFurtherLines) = splitAt (endRow - startRow) linesBeginningWithStartLine
-            (textInRangeInFirstLine, linesBetween) = case linesInRangeBeforeEndLine of
-              [] -> ("", [])
-              firstLine:linesInBetween -> (T.drop startCol firstLine, linesInBetween)
-            maybeTextInRangeInEndLine = T.take endCol <$> listToMaybe endLineAndFurtherLines
-        in T.intercalate "\n" (textInRangeInFirstLine : linesBetween ++ maybeToList maybeTextInRangeInEndLine)
-      EQ ->
-        let line = fromMaybe "" (listToMaybe linesBeginningWithStartLine)
-        in T.take (endCol - startCol) (T.drop startCol line)
-      GT -> ""
-    where
-      linesBeginningWithStartLine = drop startRow (T.splitOn "\n" text)
-
 -- | Returns the ranges for a binding in an import declaration
 rangesForBindingImport :: ImportDecl GhcPs -> String -> [Range]
 #if MIN_VERSION_ghc(9,5,0)
@@ -1991,14 +1982,18 @@ smallerRangesForBindingExport lies b =
   where
     unqualify = snd . breakOnEnd "."
     b' = wrapOperatorInParens $ unqualify b
+
 #if MIN_VERSION_ghc(9,9,0)
     ranges' (L _ (IEThingWith _ thing _  inners _))
+      | T.unpack (printOutputable thing) == b' = []
+      | otherwise =
+          [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b']
 #else
     ranges' (L _ (IEThingWith _ thing _  inners))
-#endif
       | T.unpack (printOutputable thing) == b' = []
       | otherwise =
           [ locA l' | L l' x <- inners, T.unpack (printOutputable x) == b']
+#endif
     ranges' _ = []
 
 rangesForBinding' :: String -> LIE GhcPs -> [SrcSpan]

plugins/hls-refactor-plugin/src/Development/IDE/Plugin/Plugins/FillHole.hs

@@ -5,22 +5,26 @@ module Development.IDE.Plugin.Plugins.FillHole
 import           Control.Monad                             (guard)
 import           Data.Char
 import qualified Data.Text                                 as T
+import           Development.IDE.GHC.Util                  (textInRange)
 import           Development.IDE.Plugin.Plugins.Diagnostic
 import           Language.LSP.Protocol.Types               (Diagnostic (..),
                                                             TextEdit (TextEdit))
 import           Text.Regex.TDFA                           (MatchResult (..),
                                                             (=~))
 
-suggestFillHole :: Diagnostic -> [(T.Text, TextEdit)]
-suggestFillHole Diagnostic{_range=_range,..}
+suggestFillHole :: Maybe T.Text -> Diagnostic -> [(T.Text, TextEdit)]
+suggestFillHole contents Diagnostic{_range=_range,..}
     | Just holeName <- extractHoleName _message
     , (holeFits, refFits) <- processHoleSuggestions (T.lines _message) =
-      let isInfixHole = _message =~ addBackticks holeName :: Bool in
+      let isInfixHole = textInDiagnosticRange =~ addBackticks holeName :: Bool in
         map (proposeHoleFit holeName False isInfixHole) holeFits
         ++ map (proposeHoleFit holeName True isInfixHole) refFits
     | otherwise = []
     where
       extractHoleName = fmap (headOrThrow "impossible") . flip matchRegexUnifySpaces "Found hole: ([^ ]*)"
+      textInDiagnosticRange = case contents of
+        Nothing   -> ""
+        Just text -> textInRange _range text
       addBackticks text = "`" <> text <> "`"
       addParens text = "(" <> text <> ")"
       proposeHoleFit holeName parenthise isInfixHole name =