From 663385b183cd8d1934a8c844a00ec93d8e9f5892 Mon Sep 17 00:00:00 2001 From: vidit-od Date: Sat, 18 Apr 2026 16:48:49 +0530 Subject: [PATCH 1/3] Send Cradle info Sends Cradle Info to vsCode extension. Mechanism to populate status bar items --- ghcide-test/exe/CradleTests.hs | 45 +++++++++++++- .../session-loader/Development/IDE/Session.hs | 61 ++++++++++++++++++- 2 files changed, 104 insertions(+), 2 deletions(-) diff --git a/ghcide-test/exe/CradleTests.hs b/ghcide-test/exe/CradleTests.hs index ac9d42c483..5247e44d05 100644 --- a/ghcide-test/exe/CradleTests.hs +++ b/ghcide-test/exe/CradleTests.hs @@ -17,11 +17,14 @@ import qualified Data.Text as T import Development.IDE.GHC.Util import Development.IDE.Plugin.Test (TestRequest (..), WaitForIdeRuleResult (..)) +import Development.IDE.Session (CradleInfo (..), + cradleInfoNotificationMethod) import Development.IDE.Test (expectDiagnostics, expectDiagnosticsWithTags, expectNoMoreDiagnostics, isReferenceReady, - waitForAction) + waitForAction, + waitForCustomMessage) import Development.IDE.Types.Location import GHC.TypeLits (symbolVal) import Ide.Types (Config (..), @@ -34,6 +37,7 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test +import System.Directory (removeFile) import System.FilePath import Test.Hls (TestConfig (..), def, runSessionWithTestConfig, @@ -48,6 +52,7 @@ import Test.Tasty.HUnit tests :: TestTree tests = testGroup "cradle" [testGroup "dependencies" [sessionDepsArePickedUp] + ,testGroup "info" [explicitCradleInfo, implicitCradleInfo] ,testGroup "ignore-fatal" [ignoreFatalWarning] ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] ,testGroup "regression.batch" batchLoadRegressionTests @@ -108,6 +113,44 @@ cradleLoadedMessage = satisfy $ \case cradleLoadedMethod :: String cradleLoadedMethod = "ghcide/cradle/loaded" +-- | Waits for the cradle information notification emitted for an opened file. +waitForCradleInfo :: Session CradleInfo +waitForCradleInfo = + waitForCustomMessage cradleInfoNotificationMethod $ \value -> + case A.fromJSON value of + A.Success cradleInfo -> Just cradleInfo + A.Error _ -> Nothing + +-- | Checks that explicit cradle configuration is reported to clients. +explicitCradleInfo :: TestTree +explicitCradleInfo = + testCase "explicit cradle info" $ runWithExtraFiles "cabal-exe" $ \dir -> do + let mainPath = dir "a/src/Main.hs" + _ <- openDoc mainPath "haskell" + cradleInfo <- waitForCradleInfo + liftIO $ cradleInfoType cradleInfo @?= "cabal" + liftIO $ cradleInfoInferred cradleInfo @?= False + liftIO $ assertBool "file path should match the opened file" $ + equalFilePath (cradleInfoFile cradleInfo) mainPath + liftIO $ assertBool "root dir should match the workspace fixture" $ + equalFilePath (cradleInfoRootDir cradleInfo) dir + +-- | Checks that implicit cradle inference is reported to clients. +implicitCradleInfo :: TestTree +implicitCradleInfo = + testCase "implicit cradle info" $ runWithExtraFiles "cabal-exe" $ \dir -> do + let hieYamlPath = dir "hie.yaml" + mainPath = dir "a/src/Main.hs" + liftIO $ removeFile hieYamlPath + _ <- openDoc mainPath "haskell" + cradleInfo <- waitForCradleInfo + liftIO $ cradleInfoType cradleInfo @?= "cabal" + liftIO $ cradleInfoInferred cradleInfo @?= True + liftIO $ assertBool "file path should match the opened file" $ + equalFilePath (cradleInfoFile cradleInfo) mainPath + liftIO $ assertBool "root dir should match the workspace fixture" $ + equalFilePath (cradleInfoRootDir cradleInfo) dir + ignoreFatalWarning :: TestTree ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do let srcPath = dir "IgnoreFatal.hs" diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 7e1a062a7a..e8c55b1757 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -6,6 +6,8 @@ The logic for setting up a ghcide session by tapping into hie-bios. module Development.IDE.Session (SessionLoadingOptions(..) ,CacheDirs(..) + ,CradleInfo(..) + ,cradleInfoNotificationMethod ,loadSessionWithOptions ,getInitialGhcLibDirDefault ,getHieDbLoc @@ -695,6 +697,60 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let absFile = toAbsolutePath file absolutePathsCradleDeps <$> lookupOrWaitCache recorder sessionState absFile +data CradleInfo = CradleInfo + { cradleInfoFile :: FilePath + , cradleInfoRootDir :: FilePath + , cradleInfoType :: T.Text + , cradleInfoInferred :: Bool + } + +instance ToJSON CradleInfo where + toJSON (CradleInfo file rootDir cradleType inferred) = + object + [ "file" .= file + , "rootDir" .= rootDir + , "cradleType" .= cradleType + , "inferred" .= inferred + ] + +instance FromJSON CradleInfo where + parseJSON = withObject "CradleInfo" $ \obj -> + CradleInfo + <$> obj .: "file" + <*> obj .: "rootDir" + <*> obj .: "cradleType" + <*> obj .: "inferred" + +-- | Names the custom notification that reports the loaded cradle to clients. +cradleInfoNotificationMethod :: T.Text +cradleInfoNotificationMethod = "ghcide/cradle/info" + +-- | Builds the small cradle summary that editors can display to users. +mkCradleInfo :: FilePath -> Maybe FilePath -> Cradle a -> CradleInfo +mkCradleInfo file hieYaml cradle = + CradleInfo + { cradleInfoFile = file + , cradleInfoRootDir = cradleRootDir cradle + , cradleInfoType = cradleTypeLabel cradle + , cradleInfoInferred = isNothing hieYaml + } + +-- | Converts the cradle action into a stable, editor-friendly label. +cradleTypeLabel :: Cradle a -> T.Text +cradleTypeLabel cradle = case actionName (cradleOptsProg cradle) of + Cabal -> "cabal" + Stack -> "stack" + Direct -> "direct" + Default -> "default" + _ -> "bios" + +-- | Sends the current cradle summary to interested LSP clients when available. +sendCradleInfoNotification :: Maybe (LanguageContextEnv Config) -> CradleInfo -> IO () +sendCradleInfoNotification lspEnv cradleInfo = + for_ lspEnv $ \env -> + void $ runLspT env $ + sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/info")) (toJSON cradleInfo) + -- | Given a file, this function will return the HscEnv and the dependencies -- it would look up the cache first, if the cache is not available, it would -- submit a request to the getOptionsLoop to get the options for the file @@ -1008,9 +1064,12 @@ loadCradleWithNotifications recorder sessionState hieYaml cfp = do loadingOptions <- asks sessionLoadingOptions cradle <- liftIO $ loadCradle loadingOptions recorder hieYaml rootDir + -- Expose the loaded cradle so clients can surface it in their UI. + lspEnv <- asks sessionLspContext + liftIO $ sendCradleInfoNotification lspEnv (mkCradleInfo cfp hieYaml cradle) + -- Test notification for better observability. IdeTesting isTesting <- asks (optTesting . sessionIdeOptions) - lspEnv <- asks sessionLspContext when isTesting $ mRunLspT lspEnv $ sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp) From 4c3ccd3b05db5662d389d023ef6f645401f86336 Mon Sep 17 00:00:00 2001 From: vidit-od Date: Fri, 8 May 2026 11:57:48 +0530 Subject: [PATCH 2/3] Hls sends status to vscode extension --- ghcide-test/exe/CradleTests.hs | 78 +++++++--- .../session-loader/Development/IDE/Session.hs | 138 +++++++++++------- .../src/Development/IDE/LSP/Notifications.hs | 4 + 3 files changed, 143 insertions(+), 77 deletions(-) diff --git a/ghcide-test/exe/CradleTests.hs b/ghcide-test/exe/CradleTests.hs index 5247e44d05..2cf4c4a4dc 100644 --- a/ghcide-test/exe/CradleTests.hs +++ b/ghcide-test/exe/CradleTests.hs @@ -17,8 +17,9 @@ import qualified Data.Text as T import Development.IDE.GHC.Util import Development.IDE.Plugin.Test (TestRequest (..), WaitForIdeRuleResult (..)) -import Development.IDE.Session (CradleInfo (..), - cradleInfoNotificationMethod) +import Development.IDE.Session (HlsReadyPayload (..), + HlsStatus (..), + hlsStatusNotificationMethod) import Development.IDE.Test (expectDiagnostics, expectDiagnosticsWithTags, expectNoMoreDiagnostics, @@ -47,12 +48,14 @@ import Test.Hls.Util (EnvSpec (..), OS (..), ignoreInEnv) import Test.Tasty import Test.Tasty.HUnit +import Data.Maybe (isJust) tests :: TestTree tests = testGroup "cradle" [testGroup "dependencies" [sessionDepsArePickedUp] ,testGroup "info" [explicitCradleInfo, implicitCradleInfo] + ,testGroup "status" [hlsStatusLifecycle] ,testGroup "ignore-fatal" [ignoreFatalWarning] ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] ,testGroup "regression.batch" batchLoadRegressionTests @@ -92,6 +95,11 @@ retryFailedCradle = testWithDummyPluginEmpty' "retry failed" $ \dir -> do liftIO $ atomicFileWriteString hiePath hieContents let aPath = dir "A.hs" doc <- createDoc aPath "haskell" "main = return ()" + status <- waitForHlsStatus (T.pack "error") + liftIO $ assertBool "status file should match the opened file" $ + maybe False (`equalFilePath` aPath) (hlsStatusFile status) + liftIO $ assertBool "error status should include a payload" $ + isJust (hlsStatusPayload status) WaitForIdeRuleResult {..} <- waitForAction "TypeCheck" doc liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess @@ -113,27 +121,52 @@ cradleLoadedMessage = satisfy $ \case cradleLoadedMethod :: String cradleLoadedMethod = "ghcide/cradle/loaded" --- | Waits for the cradle information notification emitted for an opened file. -waitForCradleInfo :: Session CradleInfo -waitForCradleInfo = - waitForCustomMessage cradleInfoNotificationMethod $ \value -> +-- | Waits for the ready payload emitted when setup finishes. +waitForReadyPayload :: Session HlsReadyPayload +waitForReadyPayload = do + status <- waitForHlsStatus (T.pack "ready") + case hlsStatusPayload status of + Just payload + | A.Success readyPayload <- A.fromJSON payload -> pure readyPayload + _ -> liftIO $ assertFailure "ready status did not include ready payload" + +-- | Waits for a specific HLS status notification. +waitForHlsStatus :: T.Text -> Session HlsStatus +waitForHlsStatus expectedStatus = + waitForCustomMessage hlsStatusNotificationMethod $ \value -> case A.fromJSON value of - A.Success cradleInfo -> Just cradleInfo - A.Error _ -> Nothing - --- | Checks that explicit cradle configuration is reported to clients. + A.Success status | hlsStatusStatus status == expectedStatus -> Just status + _ -> Nothing + +-- | Checks that HLS reports the coarse setup lifecycle clients need for UI state. +hlsStatusLifecycle :: TestTree +hlsStatusLifecycle = + testCase "setup lifecycle" $ runWithExtraFiles "cabal-exe" $ \dir -> do + started <- waitForHlsStatus (T.pack "started") + liftIO $ hlsStatusFile started @?= Nothing + liftIO $ assertBool "root dir should match the workspace fixture" $ + maybe False (`equalFilePath` dir) (hlsStatusRootDir started) + let mainPath = dir "a/src/Main.hs" + _ <- openDoc mainPath "haskell" + loading <- waitForHlsStatus (T.pack "loading") + liftIO $ assertBool "loading file should match the opened file" $ + maybe False (`equalFilePath` mainPath) (hlsStatusFile loading) + ready <- waitForHlsStatus (T.pack "ready") + liftIO $ assertBool "ready file should match the opened file" $ + maybe False (`equalFilePath` mainPath) (hlsStatusFile ready) + liftIO $ assertBool "ready status should include ready payload" $ + hlsStatusPayload ready /= Nothing + +-- | Checks that explicit cradle setup is reported to clients. explicitCradleInfo :: TestTree explicitCradleInfo = testCase "explicit cradle info" $ runWithExtraFiles "cabal-exe" $ \dir -> do let mainPath = dir "a/src/Main.hs" _ <- openDoc mainPath "haskell" - cradleInfo <- waitForCradleInfo - liftIO $ cradleInfoType cradleInfo @?= "cabal" - liftIO $ cradleInfoInferred cradleInfo @?= False - liftIO $ assertBool "file path should match the opened file" $ - equalFilePath (cradleInfoFile cradleInfo) mainPath - liftIO $ assertBool "root dir should match the workspace fixture" $ - equalFilePath (cradleInfoRootDir cradleInfo) dir + readyPayload <- waitForReadyPayload + liftIO $ hlsReadyPayloadInferred readyPayload @?= False + liftIO $ assertBool "GHC version should be reported" $ + not $ null $ hlsReadyPayloadGhcVersion readyPayload -- | Checks that implicit cradle inference is reported to clients. implicitCradleInfo :: TestTree @@ -143,13 +176,10 @@ implicitCradleInfo = mainPath = dir "a/src/Main.hs" liftIO $ removeFile hieYamlPath _ <- openDoc mainPath "haskell" - cradleInfo <- waitForCradleInfo - liftIO $ cradleInfoType cradleInfo @?= "cabal" - liftIO $ cradleInfoInferred cradleInfo @?= True - liftIO $ assertBool "file path should match the opened file" $ - equalFilePath (cradleInfoFile cradleInfo) mainPath - liftIO $ assertBool "root dir should match the workspace fixture" $ - equalFilePath (cradleInfoRootDir cradleInfo) dir + readyPayload <- waitForReadyPayload + liftIO $ hlsReadyPayloadInferred readyPayload @?= True + liftIO $ assertBool "GHC version should be reported" $ + not $ null $ hlsReadyPayloadGhcVersion readyPayload ignoreFatalWarning :: TestTree ignoreFatalWarning = testCase "ignore-fatal-warning" $ runWithExtraFiles "ignore-fatal" $ \dir -> do diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index e8c55b1757..a1040bdeb7 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -6,8 +6,11 @@ The logic for setting up a ghcide session by tapping into hie-bios. module Development.IDE.Session (SessionLoadingOptions(..) ,CacheDirs(..) - ,CradleInfo(..) - ,cradleInfoNotificationMethod + ,HlsStatus(..) + ,HlsReadyPayload(..) + ,hlsStatusNotificationMethod + ,mkHlsStatus + ,sendHlsStatusNotification ,loadSessionWithOptions ,getInitialGhcLibDirDefault ,getHieDbLoc @@ -558,6 +561,10 @@ getPendingFiles state = atomically $ S.toHashSet (pendingFiles state) -- | Handle errors during session loading by recording file as having error and removing from pending handleSingleFileProcessingError' :: SessionState -> Maybe FilePath -> FilePath -> PackageSetupException -> SessionM () handleSingleFileProcessingError' state hieYaml file e = do + lspEnv <- asks sessionLspContext + rootDir <- asks sessionRootDir + liftIO $ sendHlsStatusNotification lspEnv $ + mkHlsStatus (T.pack "error") (Just file) (Just rootDir) (Just $ errorStatusPayload $ T.pack $ showPackageSetupException e) handleSingleFileProcessingError state hieYaml file [renderPackageSetupException file e] mempty -- | Common pattern: Insert file flags, insert file mapping, and remove from pending @@ -697,59 +704,73 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do let absFile = toAbsolutePath file absolutePathsCradleDeps <$> lookupOrWaitCache recorder sessionState absFile -data CradleInfo = CradleInfo - { cradleInfoFile :: FilePath - , cradleInfoRootDir :: FilePath - , cradleInfoType :: T.Text - , cradleInfoInferred :: Bool +data HlsReadyPayload = HlsReadyPayload + { hlsReadyPayloadInferred :: Bool + , hlsReadyPayloadGhcVersion :: String } + deriving (Eq, Show) -instance ToJSON CradleInfo where - toJSON (CradleInfo file rootDir cradleType inferred) = +instance ToJSON HlsReadyPayload where + toJSON (HlsReadyPayload inferred ghcVersion) = object - [ "file" .= file - , "rootDir" .= rootDir - , "cradleType" .= cradleType - , "inferred" .= inferred + [ "inferred" .= inferred + , "ghcVersion" .= ghcVersion ] -instance FromJSON CradleInfo where - parseJSON = withObject "CradleInfo" $ \obj -> - CradleInfo - <$> obj .: "file" - <*> obj .: "rootDir" - <*> obj .: "cradleType" - <*> obj .: "inferred" - --- | Names the custom notification that reports the loaded cradle to clients. -cradleInfoNotificationMethod :: T.Text -cradleInfoNotificationMethod = "ghcide/cradle/info" - --- | Builds the small cradle summary that editors can display to users. -mkCradleInfo :: FilePath -> Maybe FilePath -> Cradle a -> CradleInfo -mkCradleInfo file hieYaml cradle = - CradleInfo - { cradleInfoFile = file - , cradleInfoRootDir = cradleRootDir cradle - , cradleInfoType = cradleTypeLabel cradle - , cradleInfoInferred = isNothing hieYaml +instance FromJSON HlsReadyPayload where + parseJSON = withObject "HlsReadyPayload" $ \obj -> + HlsReadyPayload + <$> obj .: "inferred" + <*> obj .: "ghcVersion" + +mkReadyPayload :: Maybe FilePath -> String -> HlsReadyPayload +mkReadyPayload hieYaml ghcVersion = + HlsReadyPayload + { hlsReadyPayloadInferred = isNothing hieYaml + , hlsReadyPayloadGhcVersion = ghcVersion } --- | Converts the cradle action into a stable, editor-friendly label. -cradleTypeLabel :: Cradle a -> T.Text -cradleTypeLabel cradle = case actionName (cradleOptsProg cradle) of - Cabal -> "cabal" - Stack -> "stack" - Direct -> "direct" - Default -> "default" - _ -> "bios" - --- | Sends the current cradle summary to interested LSP clients when available. -sendCradleInfoNotification :: Maybe (LanguageContextEnv Config) -> CradleInfo -> IO () -sendCradleInfoNotification lspEnv cradleInfo = +data HlsStatus = HlsStatus + { hlsStatusStatus :: T.Text + , hlsStatusFile :: Maybe FilePath + , hlsStatusRootDir :: Maybe FilePath + , hlsStatusPayload :: Maybe Value + } + deriving (Eq, Show) + +instance ToJSON HlsStatus where + toJSON (HlsStatus status file rootDir payload) = + object + [ "status" .= status + , "file" .= file + , "rootDir" .= rootDir + , "payload" .= payload + ] + +instance FromJSON HlsStatus where + parseJSON = withObject "HlsStatus" $ \obj -> + HlsStatus + <$> obj .: "status" + <*> obj .:? "file" + <*> obj .:? "rootDir" + <*> obj .:? "payload" + +-- | Names the custom notification that reports HLS setup state to clients. +hlsStatusNotificationMethod :: T.Text +hlsStatusNotificationMethod = T.pack "ghcide/status" + +mkHlsStatus :: T.Text -> Maybe FilePath -> Maybe FilePath -> Maybe Value -> HlsStatus +mkHlsStatus = HlsStatus + +errorStatusPayload :: T.Text -> Value +errorStatusPayload msg = + object ["message" .= msg] + +sendHlsStatusNotification :: Maybe (LanguageContextEnv Config) -> HlsStatus -> IO () +sendHlsStatusNotification lspEnv status = for_ lspEnv $ \env -> void $ runLspT env $ - sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/info")) (toJSON cradleInfo) + sendNotification (SMethod_CustomMethod (Proxy @"ghcide/status")) (toJSON status) -- | Given a file, this function will return the HscEnv and the dependencies -- it would look up the cache first, if the cache is not available, it would @@ -889,7 +910,7 @@ consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml cfp = d case reverse $ readP_to_S parseVersion version of [] -> error $ "GHC version could not be parsed: " <> version ((runTime, _):_) - | compileTime == runTime -> session recorder sessionShake sessionState knownTargetsVar (hieYaml, ncfp, opts, libDir) + | compileTime == runTime -> session recorder sessionShake sessionState knownTargetsVar (hieYaml, ncfp, opts, libDir, mkReadyPayload hieYaml version) | otherwise -> handleSingleFileProcessingError' sessionState hieYaml cfp (GhcVersionMismatch{..}) -- Failure case, either a cradle error or the none cradle Left err -> do @@ -919,6 +940,10 @@ consultCradle recorder sessionShake sessionState knownTargetsVar hieYaml cfp = d -- we can't load it. -- Add it to the list of permanently failed to load targets and do not retry! let res = map (\err' -> renderCradleError err' cradle ncfp) err + lspEnv <- asks sessionLspContext + rootDir <- asks sessionRootDir + liftIO $ sendHlsStatusNotification lspEnv $ + mkHlsStatus (T.pack "error") (Just cfp) (Just rootDir) (Just $ errorStatusPayload $ errorStatusMessage res) handleSingleFileProcessingError sessionState hieYaml cfp res $ concatMap cradleErrorDependencies err -- | Set up the GHC session for the new 'ComponentOptions' we have discovered. @@ -931,9 +956,9 @@ session :: SessionShake -> SessionState -> TVar (Hashed KnownTargets) -> - (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) -> + (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath, HlsReadyPayload) -> SessionM () -session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, libDir) = do +session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, libDir, readyPayload) = do let initEmptyHscEnv = emptyHscEnvM libDir (new_components_info, old_components_info) <- packageSetup recorder sessionState initEmptyHscEnv (hieYaml, cfp, opts) @@ -970,6 +995,14 @@ session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, l let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>) return [keys1, keys2] + lspEnv <- asks sessionLspContext + rootDir <- asks sessionRootDir + liftIO $ sendHlsStatusNotification lspEnv $ + mkHlsStatus (T.pack "ready") (Just $ fromNormalizedFilePath cfp) (Just rootDir) (Just $ toJSON readyPayload) + +errorStatusMessage :: [FileDiagnostic] -> T.Text +errorStatusMessage [] = T.pack "HLS setup failed" +errorStatusMessage diagnostics = showDiagnostics diagnostics -- | Create a new HscEnv from a hieYaml root and a set of options packageSetup :: Recorder (WithPriority Log) -> SessionState -> SessionM HscEnv -> (Maybe FilePath, NormalizedFilePath, ComponentOptions) -> SessionM ([ComponentInfo], [ComponentInfo]) @@ -1062,11 +1095,10 @@ loadCradleWithNotifications recorder sessionState hieYaml cfp = do -- Find the 'Cradle' for the target loadingOptions <- asks sessionLoadingOptions - cradle <- liftIO $ loadCradle loadingOptions recorder hieYaml rootDir - - -- Expose the loaded cradle so clients can surface it in their UI. lspEnv <- asks sessionLspContext - liftIO $ sendCradleInfoNotification lspEnv (mkCradleInfo cfp hieYaml cradle) + liftIO $ sendHlsStatusNotification lspEnv $ + mkHlsStatus (T.pack "loading") (Just cfp) (Just rootDir) Nothing + cradle <- liftIO $ loadCradle loadingOptions recorder hieYaml rootDir -- Test notification for better observability. IdeTesting isTesting <- asks (optTesting . sessionIdeOptions) diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 4f5475442c..8bb60178a1 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -33,6 +33,7 @@ import Development.IDE.Core.OfInterest hiding (Log, LogShake) import Development.IDE.Core.Service hiding (Log, LogShake) import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake +import qualified Development.IDE.Session as Session import Development.IDE.Types.Location import Ide.Logger import Ide.Types @@ -133,6 +134,9 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration mempty , mkPluginNotificationHandler LSP.SMethod_Initialized $ \ide _ _ _ -> do + liftIO $ Session.sendHlsStatusNotification (lspEnv $ shakeExtras ide) $ + Session.mkHlsStatus (Text.pack "started") Nothing (Just $ rootDir ide) Nothing + --------- Initialize Shake session -------------------------------------------------------------------- liftIO $ shakeSessionInit (cmapWithPrio LogShake recorder) ide From b41d92a4976394c8c6274db9829818568eb6b2cc Mon Sep 17 00:00:00 2001 From: vidit-od Date: Fri, 8 May 2026 12:40:22 +0530 Subject: [PATCH 3/3] stylish haskell --- ghcide-test/exe/CradleTests.hs | 4 ++-- ghcide/session-loader/Development/IDE/Session.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/ghcide-test/exe/CradleTests.hs b/ghcide-test/exe/CradleTests.hs index 2cf4c4a4dc..7f218e2b2a 100644 --- a/ghcide-test/exe/CradleTests.hs +++ b/ghcide-test/exe/CradleTests.hs @@ -12,6 +12,7 @@ import Control.Applicative.Combinators import Control.Lens ((^.)) import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as A +import Data.Maybe (isJust) import Data.Proxy (Proxy (..)) import qualified Data.Text as T import Development.IDE.GHC.Util @@ -48,7 +49,6 @@ import Test.Hls.Util (EnvSpec (..), OS (..), ignoreInEnv) import Test.Tasty import Test.Tasty.HUnit -import Data.Maybe (isJust) tests :: TestTree @@ -136,7 +136,7 @@ waitForHlsStatus expectedStatus = waitForCustomMessage hlsStatusNotificationMethod $ \value -> case A.fromJSON value of A.Success status | hlsStatusStatus status == expectedStatus -> Just status - _ -> Nothing + _ -> Nothing -- | Checks that HLS reports the coarse setup lifecycle clients need for UI state. hlsStatusLifecycle :: TestTree diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index a1040bdeb7..b543aaf076 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -705,7 +705,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do absolutePathsCradleDeps <$> lookupOrWaitCache recorder sessionState absFile data HlsReadyPayload = HlsReadyPayload - { hlsReadyPayloadInferred :: Bool + { hlsReadyPayloadInferred :: Bool , hlsReadyPayloadGhcVersion :: String } deriving (Eq, Show) @@ -1001,7 +1001,7 @@ session recorder sessionShake sessionState knownTargetsVar(hieYaml, cfp, opts, l mkHlsStatus (T.pack "ready") (Just $ fromNormalizedFilePath cfp) (Just rootDir) (Just $ toJSON readyPayload) errorStatusMessage :: [FileDiagnostic] -> T.Text -errorStatusMessage [] = T.pack "HLS setup failed" +errorStatusMessage [] = T.pack "HLS setup failed" errorStatusMessage diagnostics = showDiagnostics diagnostics -- | Create a new HscEnv from a hieYaml root and a set of options