Don't show error context

Author: sol

src/DeepSeek.hs

@@ -25,7 +25,7 @@ import           Network.HTTP.Simple
 import           Builder (Builder)
 import qualified Builder
 import           Sensei.API (Instructions(..))
-import           GHC.Diagnostic (Diagnostic, Span, Location)
+import           GHC.Diagnostic (Diagnostic, Span, Location, ShowErrorContext(..))
 import qualified GHC.Diagnostic.Type as Diagnostic
 import qualified Config.DeepSeek as Config
 import           DeepSeek.Types
@@ -146,7 +146,7 @@ createPrompt dir span instructions = do
         , "The GHC diagnostics message:"
         , ""
         , "```console"
-        , Builder.fromText . Text.stripEnd . pack $ Diagnostic.format diagnostic
+        , Builder.fromText . Text.stripEnd . pack $ Diagnostic.format ShowErrorContext diagnostic
         , "```"
         ]
 

src/GHC/Diagnostic.hs

@@ -39,9 +39,9 @@ import           GHC.Diagnostic.Type as Diagnostic
 import           GHC.Diagnostic.Annotated
 import           GHC.Diagnostic.Util
 
-formatAnnotated :: Int -> Annotated -> (Int, Text)
-formatAnnotated start annotated = case formatSolutions start annotated.solutions of
-  (next, solutions) -> (next, Builder.toText $ fromString (format annotated.diagnostic) <> solutions)
+formatAnnotated :: ShowErrorContext -> Int -> Annotated -> (Int, Text)
+formatAnnotated showErrorContext start annotated = case formatSolutions start annotated.solutions of
+  (next, solutions) -> (next, Builder.toText $ fromString (format showErrorContext annotated.diagnostic) <> solutions)
 
 formatSolutions :: Int -> [Solution] -> (Int, Builder)
 formatSolutions start = zipWith formatNumbered [start..] >>> reverse >>> \ case

src/GHC/Diagnostic/Type.hs

@@ -6,6 +6,8 @@ module GHC.Diagnostic.Type (
 , Severity(..)
 , Reason(..)
 , parse
+
+, ShowErrorContext(..)
 , format
 ) where
 
@@ -65,8 +67,11 @@ data Category = Category {
 parse :: ByteString -> Maybe Diagnostic
 parse = fmap removeGhciSpecificHints . decodeThrow
 
-format :: Diagnostic -> String
-format diagnostic = render $ unlines [
+data ShowErrorContext = ShowErrorContext | NoShowErrorContext
+  deriving (Eq, Show)
+
+format :: ShowErrorContext -> Diagnostic -> String
+format showErrorContext diagnostic = render $ unlines [
     hang header 4 messageWithHints
   , ""
   , ""
@@ -109,7 +114,9 @@ format diagnostic = render $ unlines [
             ReasonCategory {} -> "-Werror="
 
     message :: Doc
-    message = bulleted $ map (verbatim . T.stripStart) diagnostic.message
+    message = bulleted $ map (verbatim . T.stripStart) case showErrorContext of
+      ShowErrorContext -> diagnostic.message
+      NoShowErrorContext -> dropErrorContext diagnostic.message
 
     hints :: [Doc]
     hints = map verbatim diagnostic.hints
@@ -151,3 +158,15 @@ removeGhciSpecificHints diagnostic = diagnostic { hints = map processHint diagno
       hint : "You may enable these language extensions in GHCi with:" : ghciHints
         | all isSetLanguageExtension ghciHints -> hint
       _ -> input
+
+dropErrorContext :: [Text] -> [Text]
+dropErrorContext = filter \ m -> not $ or $ map ($ m) [
+    startsWith "  defined at "
+  , startsWith "In an equation for "
+  , startsWith "In a stmt of a "
+  , startsWith "In the expression: "
+  , startsWith "In the Template Haskell quotation "
+  ]
+  where
+    startsWith :: Text -> Text -> Bool
+    startsWith = T.isPrefixOf

src/Language/Haskell/GhciWrapper.hs

@@ -31,7 +31,7 @@ import           System.Exit (exitFailure)
 import           Util (isWritableByOthers)
 import           ReadHandle hiding (getResult)
 import qualified ReadHandle
-import           GHC.Diagnostic (Annotated)
+import           GHC.Diagnostic (ShowErrorContext(..), Annotated)
 import qualified GHC.Diagnostic as Diagnostic
 
 data Config = Config {
@@ -196,15 +196,15 @@ extractAnnotatedDiagnostics numberForNextSolution getAvailableImports = ReadHand
       Nothing -> return Nothing
       Just diagnostic -> do
         n <- readIORef numberForNextSolution
-        let (next, formatted) = Diagnostic.formatAnnotated n diagnostic
+        let (next, formatted) = Diagnostic.formatAnnotated NoShowErrorContext n diagnostic
         writeIORef numberForNextSolution next
         return $ Just (diagnostic, T.encodeUtf8 formatted)
 }
 
 extractDiagnostics :: ReadHandle.Extract Diagnostic.Diagnostic
 extractDiagnostics = ReadHandle.Extract {
   isPartialMessage = ByteString.isPrefixOf "{"
-, parseMessage = \ input -> return $ (id &&& encodeUtf8 . Diagnostic.format) <$> Diagnostic.parse input
+, parseMessage = \ input -> return $ (id &&& encodeUtf8 . Diagnostic.format NoShowErrorContext) <$> Diagnostic.parse input
 }
 
 getResult :: Extract a -> Interpreter -> IO (String, [a])

test/GHC/DiagnosticSpec.hs

@@ -77,7 +77,10 @@ testWith :: HasCallStack => FilePath -> GHC -> [String] -> String -> Maybe Annot
 testWith name requiredVersion extraArgs (unindent -> code) annotation solutions = it name do
   unless (T.null code) do
     ensureFile src $ T.encodeUtf8 code
+
   err <- translate <$> ghc ["-fno-diagnostics-show-caret"]
+  errNoContext <- translate <$> ghc ["-fno-diagnostics-show-caret", "-fno-show-error-context"]
+
   json <- pretty <$> ghc ["-fdiagnostics-as-json", "--interactive", "-ignore-dot-ghci"]
   ensureFile (dir </> "err.out") (encodeUtf8 err)
   ensureFile (dir </> "err.yaml") (encodeUtf8 $ normalizeGhcVersion json)
@@ -86,7 +89,9 @@ testWith name requiredVersion extraArgs (unindent -> code) annotation solutions
       expectationFailure $ "Parsing JSON failed:\n\n" <> json
     Just annotated -> addAnnotation (separator <> err <> separator) do
       whenGhc requiredVersion do
-        format annotated.diagnostic `shouldBe` err
+        format ShowErrorContext annotated.diagnostic `shouldBe` err
+        format NoShowErrorContext annotated.diagnostic `shouldBe` errNoContext
+
       annotated.annotation `shouldBe` annotation
       annotated.solutions `shouldBe` solutions
   where
@@ -467,7 +472,7 @@ spec = do
 
     it "formats an annotated diagnostic message" do
       Just annotated <- B.readFile "test/fixtures/not-in-scope/err.yaml" >>= parseAnnotated getAvailableImports
-      stripAnsi . unpack <$> formatAnnotated 1 annotated `shouldBe` (2, unlines [
+      stripAnsi . unpack <$> formatAnnotated NoShowErrorContext 1 annotated `shouldBe` (2, unlines [
           "test/fixtures/not-in-scope/Foo.hs:2:7: error: [GHC-88464]"
         , "    Variable not in scope: catMaybes"
         , ""
@@ -477,7 +482,7 @@ spec = do
 
     it "formats an annotated diagnostic message" do
       Just annotated <- B.readFile "test/fixtures/not-in-scope-operator/err.yaml" >>= parseAnnotated getAvailableImports
-      stripAnsi . unpack <$> formatAnnotated 1 annotated `shouldBe` (5, unlines [
+      stripAnsi . unpack <$> formatAnnotated NoShowErrorContext 1 annotated `shouldBe` (5, unlines [
           "test/fixtures/not-in-scope-operator/Foo.hs:2:7: error: [GHC-88464]"
         , "    Variable not in scope: <&>"
         , "    Suggested fix:"