Set CodeDescription from HaskellErrorIndex when available

dylan-thinnes · dylan-thinnes · commit 414c845a74ef · 2024-06-24T18:20:12.000+01:00
diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal
@@ -83,6 +83,7 @@ library
     , hiedb                        ^>= 0.6.0.0
     , hls-graph                    == 2.9.0.0
     , hls-plugin-api               == 2.9.0.0
+    , http-conduit
     , implicit-hie                 >= 0.1.4.0 && < 0.1.5
     , lens
     , lens-aeson
@@ -135,6 +136,7 @@ library
     Development.IDE.Core.Debouncer
     Development.IDE.Core.FileStore
     Development.IDE.Core.FileUtils
+    Development.IDE.Core.HaskellErrorIndex
     Development.IDE.Core.IdeConfiguration
     Development.IDE.Core.OfInterest
     Development.IDE.Core.PluginUtils
diff --git a/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs b/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs
@@ -0,0 +1,80 @@
+-- Retrieve the list of errors from the HaskellErrorIndex via its API
+module Development.IDE.Core.HaskellErrorIndex where
+
+import           Control.Exception                 (tryJust)
+import           Data.Aeson                        (FromJSON (..), (.:), withObject)
+import qualified Data.Map                          as M
+import qualified Data.Text                         as T
+import           Development.IDE.Types.Diagnostics
+import           GHC.Types.Error                   (DiagnosticCode)
+import           Ide.Logger                        (Recorder, Pretty (..), WithPriority, logWith, Priority (..), vcat)
+import           Language.LSP.Protocol.Types       (Uri (..), CodeDescription (..))
+import           Network.HTTP.Simple               (HttpException, JSONException, getResponseBody, httpJSON)
+
+data Log
+  = LogHaskellErrorIndexInitialized
+  | LogHaskellErrorIndexJSONError JSONException
+  | LogHaskellErrorIndexHTTPError HttpException
+  deriving (Show)
+
+instance Pretty Log where
+  pretty = \case
+    LogHaskellErrorIndexInitialized -> "Initialized Haskell Error Index from internet"
+    LogHaskellErrorIndexJSONError err ->
+      vcat
+        [ "Failed to initialize Haskell Error Index due to a JSON error:"
+        , pretty (show err)
+        ]
+    LogHaskellErrorIndexHTTPError err ->
+      vcat
+        [ "Failed to initialize Haskell Error Index due to an HTTP error:"
+        , pretty (show err)
+        ]
+
+newtype HaskellErrorIndex = HaskellErrorIndex (M.Map T.Text HEIError)
+  deriving (Show, Eq, Ord)
+
+data HEIError = HEIError
+  { code :: T.Text
+  , route :: T.Text
+  }
+  deriving (Show, Eq, Ord)
+
+errorsToIndex :: [HEIError] -> HaskellErrorIndex
+errorsToIndex errs = HaskellErrorIndex $ M.fromList $ map (\err -> (code err, err)) errs
+
+instance FromJSON HEIError where
+  parseJSON =
+    withObject "HEIError" $ \v ->
+      HEIError
+        <$> v .: "code"
+        <*> v .: "route"
+
+instance FromJSON HaskellErrorIndex where
+  parseJSON = fmap errorsToIndex <$> parseJSON
+
+initHaskellErrorIndex :: Recorder (WithPriority Log) -> IO (Maybe HaskellErrorIndex)
+initHaskellErrorIndex recorder = do
+  res <- tryJust handleJSONError $ tryJust handleHttpError $ httpJSON "https://errors.haskell.org/api/errors.json"
+  case res of
+    Left jsonErr -> do
+      logWith recorder Info (LogHaskellErrorIndexJSONError jsonErr)
+      pure Nothing
+    Right (Left httpErr) -> do
+      logWith recorder Info (LogHaskellErrorIndexHTTPError httpErr)
+      pure Nothing
+    Right (Right res) -> pure $ Just (getResponseBody res)
+  where
+    handleJSONError :: JSONException -> Maybe JSONException
+    handleJSONError = Just
+    handleHttpError :: HttpException -> Maybe HttpException
+    handleHttpError = Just
+
+heiGetError :: HaskellErrorIndex -> DiagnosticCode -> Maybe HEIError
+heiGetError (HaskellErrorIndex index) code = showGhcCode code `M.lookup` index
+
+attachHeiErrorCodeDescription :: HEIError -> Diagnostic -> Diagnostic
+attachHeiErrorCodeDescription heiError diag =
+  diag
+    { _codeDescription = Just $ CodeDescription $ Uri $ "https://errors.haskell.org/" <> route heiError
+    }
diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs
@@ -82,7 +82,7 @@ import           Control.Concurrent.STM.Stats           (atomicallyNamed)
 import           Control.Concurrent.Strict
 import           Control.DeepSeq
 import           Control.Exception.Extra                hiding (bracket_)
-import           Control.Lens                           ((&), (?~), (%~))
+import           Control.Lens                           ((&), (?~), (%~), over)
 import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import           Control.Monad.Reader
@@ -120,6 +120,8 @@ import           Data.Vector                            (Vector)
 import qualified Data.Vector                            as Vector
 import           Development.IDE.Core.Debouncer
 import           Development.IDE.Core.FileUtils         (getModTime)
+import           Development.IDE.Core.HaskellErrorIndex hiding (Log)
+import qualified Development.IDE.Core.HaskellErrorIndex as HaskellErrorIndex
 import           Development.IDE.Core.PositionMapping
 import           Development.IDE.Core.ProgressReporting
 import           Development.IDE.Core.RuleTypes
@@ -151,6 +153,7 @@ import           Development.IDE.Types.Shake
 import qualified Focus
 import           GHC.Fingerprint
 import           GHC.Stack                              (HasCallStack)
+import           GHC.Types.Error                        (diagnosticCode, errMsgDiagnostic)
 import           HieDb.Types
 import           Ide.Logger                             hiding (Priority)
 import qualified Ide.Logger                             as Logger
@@ -194,6 +197,7 @@ data Log
   | LogShakeGarbageCollection !T.Text !Int !Seconds
   -- * OfInterest Log messages
   | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)]
+  | LogInitializeHaskellErrorIndex !HaskellErrorIndex.Log
   deriving Show
 
 instance Pretty Log where
@@ -237,6 +241,8 @@ instance Pretty Log where
     LogSetFilesOfInterest ofInterest ->
         "Set files of interst to" <> Pretty.line
             <> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest)
+    LogInitializeHaskellErrorIndex hei ->
+        "Haskell Error Index:" <+> pretty hei
 
 -- | We need to serialize writes to the database, so we send any function that
 -- needs to write to the database over the channel, where it will be picked up by
@@ -332,6 +338,8 @@ data ShakeExtras = ShakeExtras
       -- ^ Queue of restart actions to be run.
     , loaderQueue :: TQueue (IO ())
       -- ^ Queue of loader actions to be run.
+    , haskellErrorIndex :: Maybe HaskellErrorIndex
+      -- ^ List of errors in the Haskell Error Index (errors.haskell.org)
     }
 
 type WithProgressFunc = forall a.
@@ -702,6 +710,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
         dirtyKeys <- newTVarIO mempty
         -- Take one VFS snapshot at the start
         vfsVar <- newTVarIO =<< vfsSnapshot lspEnv
+        haskellErrorIndex <- initHaskellErrorIndex (cmapWithPrio LogInitializeHaskellErrorIndex recorder)
         pure ShakeExtras{shakeRecorder = recorder, ..}
     shakeDb  <-
         shakeNewDatabase
@@ -1321,24 +1330,25 @@ traceA (A Failed{})    = "Failed"
 traceA (A Stale{})     = "Stale"
 traceA (A Succeeded{}) = "Success"
 
-updateFileDiagnostics :: MonadIO m
-  => Recorder (WithPriority Log)
+updateFileDiagnostics
+  :: Recorder (WithPriority Log)
   -> NormalizedFilePath
   -> Maybe Int32
   -> Key
   -> ShakeExtras
   -> [FileDiagnostic] -- ^ current results
-  -> m ()
+  -> Action ()
 updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, debouncer, lspEnv, ideTesting} current0 = do
+  hei <- haskellErrorIndex <$> getShakeExtras
   liftIO $ withTrace ("update diagnostics " <> fromString(fromNormalizedFilePath fp)) $ \ addTag -> do
     addTag "key" (show k)
+    current <- traverse (attachHEI hei) $ map (over fdLspDiagnosticL diagsFromRule) current0
     let (currentShown, currentHidden) = partition ((== ShowDiag) . fdShouldShowDiagnostic) current
         uri = filePathToUri' fp
         addTagUnsafe :: String -> String -> String -> a -> a
         addTagUnsafe msg t x v = unsafePerformIO(addTag (msg <> t) x) `seq` v
         update :: (forall a. String -> String -> a -> a) -> [FileDiagnostic] -> STMDiagnosticStore -> STM [FileDiagnostic]
         update addTagUnsafeMethod new store = addTagUnsafeMethod "count" (show $ Prelude.length new) $ setStageDiagnostics addTagUnsafeMethod uri ver (renderKey k) new store
-        current = map (fdLspDiagnosticL %~ diagsFromRule) current0
     addTag "version" (show ver)
     mask_ $ do
         -- Mask async exceptions to ensure that updated diagnostics are always
@@ -1362,6 +1372,18 @@ updateFileDiagnostics recorder fp ver k ShakeExtras{diagnostics, hiddenDiagnosti
                                 LSP.PublishDiagnosticsParams (fromNormalizedUri uri') (fmap fromIntegral ver) (map fdLspDiagnostic newDiags)
                  return action
     where
+        attachHEI :: Maybe HaskellErrorIndex -> FileDiagnostic -> IO FileDiagnostic
+        attachHEI mbHei diag
+            | Just hei <- mbHei
+            , SomeStructuredMessage msg <- fdStructuredMessage diag
+            , Just code <- diagnosticCode (errMsgDiagnostic msg)
+            , Just heiError <- hei `heiGetError` code
+            = pure $ diag & fdLspDiagnosticL %~ attachHeiErrorCodeDescription heiError
+            | otherwise
+            = do
+                writeFile "/home/dylan/attachHEI" (show mbHei <> "\n" <> show diag)
+                pure diag
+
         diagsFromRule :: Diagnostic -> Diagnostic
         diagsFromRule c@Diagnostic{_range}
             | coerce ideTesting = c & L.relatedInformation ?~
diff --git a/ghcide/src/Development/IDE/Types/Diagnostics.hs b/ghcide/src/Development/IDE/Types/Diagnostics.hs
@@ -19,6 +19,7 @@ module Development.IDE.Types.Diagnostics (
   ideErrorFromLspDiag,
   showDiagnostics,
   showDiagnosticsColored,
+  showGhcCode,
   IdeResultNoDiagnosticsEarlyCutoff,
   attachReason,
   attachedReason) where
@@ -77,19 +78,20 @@ ideErrorFromLspDiag lspDiag fdFilePath origMsg =
           Just msg -> SomeStructuredMessage msg
       fdLspDiagnostic = (attachReason (fmap (diagnosticReason . errMsgDiagnostic) origMsg) lspDiag)
 #if MIN_VERSION_ghc(9,6,1)
-        { _code = fmap ghcCodeToLspCode . diagnosticCode . errMsgDiagnostic =<< origMsg
+        { _code = fmap (InR . showGhcCode) . diagnosticCode . errMsgDiagnostic =<< origMsg
         }
 #endif
+  in
+  FileDiagnostic {..}
+
 #if MIN_VERSION_ghc(9,8,1)
-      ghcCodeToLspCode :: DiagnosticCode -> Int32 LSP.|? T.Text
-      ghcCodeToLspCode = InR . T.pack . show
+showGhcCode :: DiagnosticCode -> T.Text
+showGhcCode = T.pack . show
 #elif MIN_VERSION_ghc(9,6,1)
-      -- DiagnosticCode only got a show instance in 9.8.1
-      ghcCodeToLspCode :: DiagnosticCode -> Int32 LSP.|? T.Text
-      ghcCodeToLspCode (DiagnosticCode prefix c) = InR $ T.pack $ prefix ++ "-" ++ printf "%05d" c
+-- DiagnosticCode only got a show instance in 9.8.1
+showGhcCode :: DiagnosticCode -> T.Text
+showGhcCode (DiagnosticCode prefix c) = T.pack $ prefix ++ "-" ++ printf "%05d" c
 #endif
-  in
-  FileDiagnostic {..}
 
 attachedReason :: Traversal' Diagnostic (Maybe JSON.Value)
 attachedReason = data_ . non (JSON.object []) . JSON.atKey "attachedReason"
