diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index 8e870c8ff1..48ed1e3319 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -83,7 +83,6 @@ library , hiedb ^>= 0.6.0.0 , hls-graph == 2.9.0.1 , hls-plugin-api == 2.9.0.1 - , http-conduit , implicit-hie >= 0.1.4.0 && < 0.1.5 , lens , lens-aeson @@ -136,7 +135,6 @@ 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 deleted file mode 100644 index 55660cb6ef..0000000000 --- a/ghcide/src/Development/IDE/Core/HaskellErrorIndex.hs +++ /dev/null @@ -1,104 +0,0 @@ --- Retrieve the list of errors from the HaskellErrorIndex via its API -{-# LANGUAGE CPP #-} - -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.Driver.Errors.Types (GhcMessage) -#if MIN_VERSION_ghc(9,5,0) -import GHC.Types.Error (diagnosticCode) -#endif -import Ide.Logger (Pretty (..), Priority (..), - Recorder, WithPriority, - logWith, vcat) -import Language.LSP.Protocol.Types (CodeDescription (..), - Uri (..)) -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) -#if MIN_VERSION_ghc(9,5,0) -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 -#else -initHaskellErrorIndex recorder = pure Nothing -#endif - -heiGetError :: HaskellErrorIndex -> GhcMessage -> Maybe HEIError -#if MIN_VERSION_ghc(9,5,0) -heiGetError (HaskellErrorIndex index) msg - | Just code <- diagnosticCode msg - = showGhcCode code `M.lookup` index - | otherwise - = Nothing -#else -heiGetError (HaskellErrorIndex index) msg - = Nothing -#endif - -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 index ef569b7758..8ba0248fa7 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -83,7 +83,7 @@ import Control.Concurrent.STM.Stats (atomicallyNamed) import Control.Concurrent.Strict import Control.DeepSeq import Control.Exception.Extra hiding (bracket_) -import Control.Lens (over, (%~), (&), (?~)) +import Control.Lens ((&), (?~), (%~)) import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Reader @@ -121,8 +121,6 @@ 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 @@ -198,7 +196,6 @@ data Log | LogShakeGarbageCollection !T.Text !Int !Seconds -- * OfInterest Log messages | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)] - | LogInitializeHaskellErrorIndex !HaskellErrorIndex.Log deriving Show instance Pretty Log where @@ -242,8 +239,6 @@ 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 @@ -339,8 +334,6 @@ 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. @@ -711,7 +704,6 @@ 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 @@ -1332,25 +1324,24 @@ traceA (A Failed{}) = "Failed" traceA (A Stale{}) = "Stale" traceA (A Succeeded{}) = "Success" -updateFileDiagnostics - :: Recorder (WithPriority Log) +updateFileDiagnostics :: MonadIO m + => Recorder (WithPriority Log) -> NormalizedFilePath -> Maybe Int32 -> Key -> ShakeExtras -> [FileDiagnostic] -- ^ current results - -> Action () + -> m () 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 @@ -1374,15 +1365,6 @@ 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 heiError <- hei `heiGetError` errMsgDiagnostic msg - = pure $ diag & fdLspDiagnosticL %~ attachHeiErrorCodeDescription heiError - | otherwise - = 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 index 8f19b13d8a..780192a579 100644 --- a/ghcide/src/Development/IDE/Types/Diagnostics.hs +++ b/ghcide/src/Development/IDE/Types/Diagnostics.hs @@ -119,6 +119,8 @@ showGhcCode = T.pack . show 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"