Hls status and cradle-info on VScode

ghcide-test/exe/CradleTests.hs

@@ -12,16 +12,21 @@ 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
 import           Development.IDE.Plugin.Test     (TestRequest (..),
                                                   WaitForIdeRuleResult (..))
+import           Development.IDE.Session         (HlsReadyPayload (..),
+                                                  HlsStatus (..),
+                                                  hlsStatusNotificationMethod)
 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 +39,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 +54,8 @@ import           Test.Tasty.HUnit
 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
@@ -87,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
 
@@ -108,6 +121,66 @@ cradleLoadedMessage = satisfy $ \case
 cradleLoadedMethod :: String
 cradleLoadedMethod = "ghcide/cradle/loaded"
 
+-- | 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 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"
+    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
+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"
+    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
     let srcPath = dir </> "IgnoreFatal.hs"

ghcide/session-loader/Development/IDE/Session.hs

@@ -6,6 +6,11 @@ The logic for setting up a ghcide session by tapping into hie-bios.
 module Development.IDE.Session
   (SessionLoadingOptions(..)
   ,CacheDirs(..)
+  ,HlsStatus(..)
+  ,HlsReadyPayload(..)
+  ,hlsStatusNotificationMethod
+  ,mkHlsStatus
+  ,sendHlsStatusNotification
   ,loadSessionWithOptions
   ,getInitialGhcLibDirDefault
   ,getHieDbLoc
@@ -556,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
@@ -695,6 +704,74 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
       let absFile = toAbsolutePath file
       absolutePathsCradleDeps <$> lookupOrWaitCache recorder sessionState absFile
 
+data HlsReadyPayload = HlsReadyPayload
+  { hlsReadyPayloadInferred   :: Bool
+  , hlsReadyPayloadGhcVersion :: String
+  }
+  deriving (Eq, Show)
+
+instance ToJSON HlsReadyPayload where
+  toJSON (HlsReadyPayload inferred ghcVersion) =
+    object
+      [ "inferred" .= inferred
+      , "ghcVersion" .= ghcVersion
+      ]
+
+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
+    }
+
+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/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
 -- submit a request to the getOptionsLoop to get the options for the file
@@ -833,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
@@ -863,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.
@@ -875,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)
 
@@ -914,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])
@@ -1006,11 +1095,13 @@ loadCradleWithNotifications recorder sessionState hieYaml cfp = do
 
   -- Find the 'Cradle' for the target
   loadingOptions <- asks sessionLoadingOptions
+  lspEnv <- asks sessionLspContext
+  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)
-  lspEnv <- asks sessionLspContext
   when isTesting $ mRunLspT lspEnv $
     sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp)
 

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