haskell · dylan-thinnes · Jun 8, 2024 · Jun 8, 2024 · Jun 9, 2024 · Jun 9, 2024
@@ -150,6 +150,7 @@ library
     Development.IDE.GHC.Compat
     Development.IDE.GHC.Compat.Core
     Development.IDE.GHC.Compat.CmdLine
+    Development.IDE.GHC.Compat.Driver
     Development.IDE.GHC.Compat.Env
     Development.IDE.GHC.Compat.Iface
     Development.IDE.GHC.Compat.Logger

@@ -600,10 +600,11 @@
                         this_flags = (this_error_env, this_dep_info)
                         this_error_env = ([this_error], Nothing)
                         this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp
-                                       $ T.unlines
-                                       [ "No cradle target found. Is this file listed in the targets of your cradle?"
-                                       , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section"
-                                       ]
+                                       (T.unlines
+                                         [ "No cradle target found. Is this file listed in the targets of your cradle?"
+                                         , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section"
+                                         ])
+                                       Nothing
 
           void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map
           void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets))
@@ -660,7 +661,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
@@ -840,10 +841,10 @@
 -- GHC had an implementation of this function, but it was horribly inefficient
 -- We should move back to the GHC implementation on compilers where
 -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/12162 is included
-checkHomeUnitsClosed' ::  UnitEnv -> OS.Set UnitId -> [DriverMessages]
+checkHomeUnitsClosed' ::  UnitEnv -> OS.Set UnitId -> Maybe (Compat.MsgEnvelope DriverMessage)
 checkHomeUnitsClosed' ue home_id_set
-    | OS.null bad_unit_ids = []
-    | otherwise = [singleMessage $ GHC.mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (OS.toList bad_unit_ids)]
+    | OS.null bad_unit_ids = Nothing
+    | otherwise = Just (GHC.mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (OS.toList bad_unit_ids))
   where
     bad_unit_ids = upwards_closure OS.\\ home_id_set
     rootLoc = mkGeneralSrcSpan (Compat.fsLit "<command line>")
@@ -921,11 +922,25 @@
     hscEnv' <- -- Set up a multi component session with the other units on GHC 9.4
               Compat.initUnits dfs hsc_env
 
-#if MIN_VERSION_ghc(9,3,0)
-    let closure_errs = checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')
-        multi_errs = map (ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp . T.pack . Compat.printWithoutUniques) closure_errs
+#if MIN_VERSION_ghc(9,6,1)
+    let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')
+        -- TODO: Is this the right thing to do here, to produce an error for each DriverMessage generated?
+        closure_err_to_multi_err err =
+            ideErrorWithSource
+                (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp
+                (T.pack (Compat.printWithoutUniques (singleMessage err)))
+                (Just (fmap GhcDriverMessage err))
+        multi_errs = map closure_err_to_multi_err closure_errs
+        bad_units = OS.fromList $ concat $ do
+            x <- map errMsgDiagnostic closure_errs
+            DriverHomePackagesNotClosed us <- pure x
+            pure us
+        isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units
+#elif MIN_VERSION_ghc(9,3,0)
+    let closure_errs = maybeToList $ checkHomeUnitsClosed' (hsc_unit_env hscEnv') (hsc_all_home_unit_ids hscEnv')
+        multi_errs = map (\diag -> ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Warning) _cfp (T.pack (Compat.printWithoutUniques (singleMessage diag))) Nothing) closure_errs
         bad_units = OS.fromList $ concat $ do
-            x <- bagToList $ mapBag errMsgDiagnostic $ unionManyBags $ map Compat.getMessages closure_errs
+            x <- map errMsgDiagnostic closure_errs
             DriverHomePackagesNotClosed us <- pure x
             pure us
         isBad ci = (homeUnitId_ (componentDynFlags ci)) `OS.member` bad_units
@@ -1309,6 +1324,6 @@
     , "failed to load packages:", message <> "."
     , "\nPlease ensure that ghcide is compiled with the same GHC installation as the project."]
 
-renderPackageSetupException :: FilePath -> PackageSetupException -> (NormalizedFilePath, ShowDiagnostic, Diagnostic)
+renderPackageSetupException :: FilePath -> PackageSetupException -> FileDiagnostic
 renderPackageSetupException fp e =
-    ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e)
+  ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) (toNormalizedFilePath' fp) (T.pack $ showPackageSetupException e) Nothing
@@ -1,4 +1,4 @@
 {-# LANGUAGE DeriveAnyClass #-}

 module Development.IDE.Session.Diagnostics where
 import           Control.Applicative
@@ -27,11 +27,13 @@
   Depicts the cradle error in a user-friendly way.
 -}
 renderCradleError :: CradleError -> Cradle a -> NormalizedFilePath -> FileDiagnostic
-renderCradleError (CradleError deps _ec ms) cradle nfp
-  | HieBios.isCabalCradle cradle =
-      let (fp, showDiag, diag) = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage in
-        (fp, showDiag, diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}})
-  | otherwise = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp $ T.unlines $ map T.pack userFriendlyMessage
+renderCradleError (CradleError deps _ec ms) cradle nfp =
+  let noDetails =
+        ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) nfp (T.unlines $ map T.pack userFriendlyMessage) Nothing
+  in
+  if HieBios.isCabalCradle cradle
+     then flip modifyFdLspDiagnostic noDetails $ \diag -> diag{_data_ = Just $ Aeson.toJSON CradleErrorDetails{cabalProjectFiles=absDeps}}
+     else noDetails
   where
     absDeps = fmap (cradleRootDir cradle </>) deps
     userFriendlyMessage :: [String]
@@ -84,7 +86,7 @@
    surround start s end = do
      guard (listToMaybe s == Just start)
      guard (listToMaybe (reverse s) == Just end)
      pure $ drop 1 $ take (length s - 1) s

 multiCradleErrMessage :: MultiCradleErr -> [String]
 multiCradleErrMessage e =

@@ -105,6 +105,7 @@ import           System.IO.Extra                   (fixIO, newTempFileWithin)
 
 import qualified GHC                               as G
 import           GHC.Tc.Gen.Splice
+import           GHC.Types.Error
 import           GHC.Types.ForeignStubs
 import           GHC.Types.HpcInfo
 import           GHC.Types.TypeEnv
@@ -133,6 +134,8 @@ import           GHC.Unit.Module.Warnings
 import           Development.IDE.Core.FileStore    (shareFilePath)
 #endif
 
+import           Development.IDE.GHC.Compat.Driver (hscTypecheckRenameWithDiagnostics)
+
 --Simple constants to make sure the source is consistently named
 sourceTypecheck :: T.Text
 sourceTypecheck = "typecheck"
@@ -160,8 +163,13 @@ computePackageDeps
     -> IO (Either [FileDiagnostic] [UnitId])
 computePackageDeps env pkg = do
     case lookupUnit env pkg of
-        Nothing -> return $ Left [ideErrorText (toNormalizedFilePath' noFilePath) $
-            T.pack $ "unknown package: " ++ show pkg]
+        Nothing ->
+          return $ Left
+            [ ideErrorText
+                Nothing
+                (toNormalizedFilePath' noFilePath)
+                (T.pack $ "unknown package: " ++ show pkg)
+            ]
         Just pkgInfo -> return $ Right $ unitDepends pkgInfo
 
 newtype TypecheckHelpers
@@ -182,20 +190,18 @@ typecheckModule (IdeDefer defer) hsc tc_helpers pm = do
         case initialized of
           Left errs -> return (errs, Nothing)
           Right (modSummary', hscEnv) -> do
-            (warnings, etcm) <- withWarnings sourceTypecheck $ \tweak ->
-                let
-                  session = tweak (hscSetFlags dflags hscEnv)
-                   -- TODO: maybe settings ms_hspp_opts is unnecessary?
-                  mod_summary'' = modSummary' { ms_hspp_opts = hsc_dflags session}
-                in
-                  catchSrcErrors (hsc_dflags hscEnv) sourceTypecheck $ do
-                    tcRnModule session tc_helpers $ demoteIfDefer pm{pm_mod_summary = mod_summary''}
-            let errorPipeline = unDefer . hideDiag dflags . tagDiag
-                diags = map errorPipeline warnings
-                deferredError = any fst diags
+            etcm <-
+                catchSrcErrors (hsc_dflags hscEnv) sourceTypecheck $ do
+                  tcRnModule hscEnv tc_helpers $ demoteIfDefer pm{pm_mod_summary = modSummary'}
             case etcm of
-              Left errs -> return (map snd diags ++ errs, Nothing)
-              Right tcm -> return (map snd diags, Just $ tcm{tmrDeferredError = deferredError})
+              Left errs -> return (errs, Nothing)
+              Right tcm ->
+                let addReason diag = map (Just (diagnosticReason (errMsgDiagnostic diag)),) $ diagFromErrMsg sourceTypecheck (hsc_dflags hscEnv) diag
+                    errorPipeline = map (unDefer . hideDiag dflags . tagDiag) . addReason
+                    diags = concatMap errorPipeline $ Compat.getMessages $ tmrWarnings tcm
+                    deferredError = any fst diags
+                in
+                return (map snd diags, Just $ tcm{tmrDeferredError = deferredError})
     where
         demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id
 
@@ -408,9 +414,9 @@ tcRnModule hsc_env tc_helpers pmod = do
   let ms = pm_mod_summary pmod
       hsc_env_tmp = hscSetFlags (ms_hspp_opts ms) hsc_env
 
-  ((tc_gbl_env', mrn_info), splices, mod_env)
+  (((tc_gbl_env', mrn_info), warning_messages), splices, mod_env)
       <- captureSplicesAndDeps tc_helpers hsc_env_tmp $ \hscEnvTmp ->
-             do  hscTypecheckRename hscEnvTmp ms $
+             do  hscTypecheckRenameWithDiagnostics hscEnvTmp ms $
                           HsParsedModule { hpm_module = parsedSource pmod,
                                            hpm_src_files = pm_extra_src_files pmod,
                                            hpm_annotations = pm_annotations pmod }
@@ -422,7 +428,7 @@ tcRnModule hsc_env tc_helpers pmod = do
       mod_env_anns = map (\(mod, hash) -> Annotation (ModuleTarget mod) $ toSerialized BS.unpack hash)
                          (moduleEnvToList mod_env)
       tc_gbl_env = tc_gbl_env' { tcg_ann_env = extendAnnEnvList (tcg_ann_env tc_gbl_env') mod_env_anns }
-  pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env)
+  pure (TcModuleResult pmod rn_info tc_gbl_env splices False mod_env warning_messages)
 
 
 -- Note [Clearing mi_globals after generating an iface]
@@ -599,8 +605,14 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do
     source = "compile"
     catchErrs x = x `catches`
       [ Handler $ return . (,Nothing) . diagFromGhcException source dflags
-      , Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "<internal>")
-      . (("Error during " ++ T.unpack source) ++) . show @SomeException
+      , Handler $ \diag ->
+          return
+            ( diagFromString
+                source DiagnosticSeverity_Error (noSpan "<internal>")
+                ("Error during " ++ T.unpack source ++ show @SomeException diag)
+                Nothing
+            , Nothing
+            )
       ]
 
 -- | Whether we should run the -O0 simplifier when generating core.
@@ -739,20 +751,20 @@ unDefer (Reason Opt_WarnDeferredOutOfScopeVariables, fd) = (True, upgradeWarning
 unDefer ( _                                        , fd) = (False, fd)
 
 upgradeWarningToError :: FileDiagnostic -> FileDiagnostic
-upgradeWarningToError (nfp, sh, fd) =
-  (nfp, sh, fd{_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message fd}) where
+upgradeWarningToError fd =
+  modifyFdLspDiagnostic (\diag -> diag {_severity = Just DiagnosticSeverity_Error, _message = warn2err $ _message diag}) fd where
   warn2err :: T.Text -> T.Text
   warn2err = T.intercalate ": error:" . T.splitOn ": warning:"
 
 #if MIN_VERSION_ghc(9,3,0)
 hideDiag :: DynFlags -> (Maybe DiagnosticReason, FileDiagnostic) -> (Maybe DiagnosticReason, FileDiagnostic)
-hideDiag originalFlags (w@(Just (WarningWithFlag warning)), (nfp, _sh, fd))
+hideDiag originalFlags (w@(Just (WarningWithFlag warning)), fd)
 #else
 hideDiag :: DynFlags -> (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
-hideDiag originalFlags (w@(Reason warning), (nfp, _sh, fd))
+hideDiag originalFlags (w@(Reason warning), fd)
 #endif
   | not (wopt warning originalFlags)
-  = (w, (nfp, HideDiag, fd))
+  = (w, fd { fdShouldShowDiagnostic = HideDiag })
 hideDiag _originalFlags t = t
 
 -- | Warnings which lead to a diagnostic tag
@@ -780,20 +792,20 @@ tagDiag :: (WarnReason, FileDiagnostic) -> (WarnReason, FileDiagnostic)
 #endif
 
 #if MIN_VERSION_ghc(9,7,0)
-tagDiag (w@(Just (WarningWithCategory cat)), (nfp, sh, fd))
+tagDiag (w@(Just (WarningWithCategory cat)), fd)
   | cat == defaultWarningCategory -- default warning category is for deprecations
-  = (w, (nfp, sh, fd { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags fd) }))
-tagDiag (w@(Just (WarningWithFlags warnings)), (nfp, sh, fd))
+  = (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ DiagnosticTag_Deprecated : concat (_tags diag) }) fd)
+tagDiag (w@(Just (WarningWithFlags warnings)), fd)
   | tags <- mapMaybe requiresTag (toList warnings)
-  = (w, (nfp, sh, fd { _tags = Just $ tags ++ concat (_tags fd) }))
+  = (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ tags ++ concat (_tags diag) }) fd)
 #elif MIN_VERSION_ghc(9,3,0)
-tagDiag (w@(Just (WarningWithFlag warning)), (nfp, sh, fd))
+tagDiag (w@(Just (WarningWithFlag warning)), fd)
   | Just tag <- requiresTag warning
-  = (w, (nfp, sh, fd { _tags = Just $ tag : concat (_tags fd) }))
+  = (w, modifyFdLspDiagnostic (\diag -> diag { _tags = Just $ tag : concat (_tags diag) }) fd)
 #else
-tagDiag (w@(Reason warning), (nfp, sh, fd))
+tagDiag (w@(Reason warning), fd)
   | Just tag <- requiresTag warning
-  = (w, (nfp, sh, fd { _tags = Just $ tag : concat (_tags fd) }))
+  = (w, modifyFdLspDiagnostic (\diag -> { _tags = Just $ tag : concat (_tags diag) }) fd)
 #endif
   where
     requiresTag :: WarningFlag -> Maybe DiagnosticTag
@@ -1028,16 +1040,25 @@ handleGenerationErrors :: DynFlags -> T.Text -> IO () -> IO [FileDiagnostic]
 handleGenerationErrors dflags source action =
   action >> return [] `catches`
     [ Handler $ return . diagFromGhcException source dflags
-    , Handler $ return . diagFromString source DiagnosticSeverity_Error (noSpan "<internal>")
-    . (("Error during " ++ T.unpack source) ++) . show @SomeException
+    , Handler $ \(exception :: SomeException) -> return $
+        diagFromString
+          source DiagnosticSeverity_Error (noSpan "<internal>")
+          ("Error during " ++ T.unpack source ++ show exception)
+          Nothing
     ]
 
 handleGenerationErrors' :: DynFlags -> T.Text -> IO (Maybe a) -> IO ([FileDiagnostic], Maybe a)
 handleGenerationErrors' dflags source action =
   fmap ([],) action `catches`
     [ Handler $ return . (,Nothing) . diagFromGhcException source dflags
-    , Handler $ return . (,Nothing) . diagFromString source DiagnosticSeverity_Error (noSpan "<internal>")
-    . (("Error during " ++ T.unpack source) ++) . show @SomeException
+    , Handler $ \(exception :: SomeException) ->
+        return
+          ( diagFromString
+              source DiagnosticSeverity_Error (noSpan "<internal>")
+              ("Error during " ++ T.unpack source ++ show exception)
+              Nothing
+          , Nothing
+          )
     ]
 
 
@@ -1290,12 +1311,21 @@ parseFileContents env customPreprocessor filename ms = do
              psMessages = getPsMessages pst
          in
            do
-               let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
-
-               unless (null errs) $
-                  throwE $ diagFromStrings sourceParser DiagnosticSeverity_Error errs
-
-               let preproc_warnings = diagFromStrings sourceParser DiagnosticSeverity_Warning preproc_warns
+               let IdePreprocessedSource preproc_warns preproc_errs parsed = customPreprocessor rdr_module
+               let attachNoStructuredError (span, msg) = (span, msg, Nothing)
+
+               unless (null preproc_errs) $
+                  throwE $
+                    diagFromStrings
+                      sourceParser
+                      DiagnosticSeverity_Error
+                      (fmap attachNoStructuredError preproc_errs)
+
+               let preproc_warning_file_diagnostics =
+                     diagFromStrings
+                      sourceParser
+                      DiagnosticSeverity_Warning
+                      (fmap attachNoStructuredError preproc_warns)
                (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env ms hpm_annotations parsed psMessages
                let (warns, errors) = renderMessages msgs
 
@@ -1345,7 +1375,7 @@ parseFileContents env customPreprocessor filename ms = do
 
                let pm = ParsedModule ms parsed' srcs2 hpm_annotations
                    warnings = diagFromErrMsgs sourceParser dflags warns
-               pure (warnings ++ preproc_warnings, pm)
+               pure (warnings ++ preproc_warning_file_diagnostics, pm)
 
 loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile
 loadHieFile ncu f = do

@@ -134,7 +134,7 @@ getModificationTimeImpl missingFileDiags file = do
                 `catch` \(e :: IOException) -> do
                     let err | isDoesNotExistError e = "File does not exist: " ++ file'
                             | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
-                        diag = ideErrorText file (T.pack err)
+                        diag = ideErrorText Nothing file (T.pack err)
                     if isDoesNotExistError e && not missingFileDiags
                         then return (Nothing, ([], Nothing))
                         else return (Nothing, ([diag], Nothing))

@@ -112,7 +112,7 @@ data CPPDiag
 
 diagsFromCPPLogs :: FilePath -> [CPPLog] -> [FileDiagnostic]
 diagsFromCPPLogs filename logs =
-  map (\d -> (toNormalizedFilePath' filename, ShowDiag, cppDiagToDiagnostic d)) $
+  map (\d -> ideErrorFromLspDiag (cppDiagToDiagnostic d) (toNormalizedFilePath' filename) Nothing) $
     go [] logs
   where
     -- On errors, CPP calls logAction with a real span for the initial log and

@@ -45,6 +45,7 @@ import           Ide.Logger                                   (Pretty (..),
                                                                viaShow)
 import           Language.LSP.Protocol.Types                  (Int32,
                                                                NormalizedFilePath)
+import GHC.Driver.Errors.Types (WarningMessages)
 
 data LinkableType = ObjectLinkable | BCOLinkable
   deriving (Eq,Ord,Show, Generic)
@@ -157,6 +158,7 @@ data TcModuleResult = TcModuleResult
         -- ^ Which modules did we need at runtime while compiling this file?
         -- Used for recompilation checking in the presence of TH
         -- Stores the hash of their core file
+    , tmrWarnings        :: WarningMessages
     }
 instance Show TcModuleResult where
     show = show . pm_mod_summary . tmrParsed