diff --git a/ghcide-test/exe/CradleTests.hs b/ghcide-test/exe/CradleTests.hs index ac9d42c483..7f218e2b2a 100644 --- a/ghcide-test/exe/CradleTests.hs +++ b/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" diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 7e1a062a7a..b543aaf076 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/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) 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