Only report progress when client supports it (#2517)

* Only report progress when client supports it This fixes an issue that some people encountered when running hie-core in Emacs with a version of haskell-lsp that does not understand progress events. * Fix tests * More test fixes
2024-09-20 01:07:18 +03:00 · 2019-08-13 20:00:21 +02:00 · 2019-08-13 20:00:21 +02:00 · 3eb112e4ca
commit 3eb112e4ca
parent 3d0699a9a8
17 changed files with 60 additions and 25 deletions
--- a/compiler/damlc/daml-doc/test/DA/Daml/GHC/Damldoc/Tests.hs
+++ b/compiler/damlc/daml-doc/test/DA/Daml/GHC/Damldoc/Tests.hs
@ -16,6 +16,7 @@ import DA.Daml.Doc.Transform
 import DA.Daml.Doc.Anchor

 import Development.IDE.Types.Location
+import Development.IDE.Types.Options (IdeReportProgress(..))

 import           Control.Monad.Except
 import qualified Data.Aeson.Encode.Pretty as AP
@ -259,7 +260,7 @@ runDamldoc testfile importPathM = do
    -- run the doc generator on that file
    mbResult <- runExceptT $ extractDocs
        defaultExtractOptions
-        (toCompileOpts opts')
+        (toCompileOpts opts' (IdeReportProgress False))
        [toNormalizedFilePath testfile]

    case mbResult of
--- a/compiler/damlc/daml-ide-core/test/Development/IDE/State/API/Testing.hs
+++ b/compiler/damlc/daml-ide-core/test/Development/IDE/State/API/Testing.hs
@ -51,6 +51,7 @@ import qualified Development.IDE.Types.Location as D
 import DA.Daml.Compiler.Scenario as SS
 import Development.IDE.Core.Rules.Daml
 import Development.IDE.Types.Logger
+import Development.IDE.Types.Options (IdeReportProgress(..))
 import DA.Daml.Options
 import DA.Daml.Options.Types
 import Development.IDE.Core.Service.Daml(VirtualResource(..), mkDamlEnv)
@ -174,7 +175,7 @@ runShakeTest mbScenarioService (ShakeTest m) = do
        eventLogger _ = pure ()
    vfs <- API.makeVFSHandle
    damlEnv <- mkDamlEnv options mbScenarioService
-    service <- API.initialise (mainRule options) (atomically . eventLogger) noLogging damlEnv (toCompileOpts options) vfs
+    service <- API.initialise (mainRule options) (atomically . eventLogger) noLogging damlEnv (toCompileOpts options (IdeReportProgress False)) vfs
    result <- withSystemTempDirectory "shake-api-test" $ \testDirPath -> do
        let ste = ShakeTestEnv
                { steService = service
--- a/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer.hs
+++ b/compiler/damlc/daml-ide/src/DA/Daml/LanguageServer.hs
@ -9,6 +9,7 @@ module DA.Daml.LanguageServer
    ) where

 import           Language.Haskell.LSP.Types
+import           Language.Haskell.LSP.Types.Capabilities
 import           Development.IDE.LSP.Server
 import qualified Development.IDE.LSP.LanguageServer as LS
 import Control.Monad.Extra
@ -97,7 +98,7 @@ withUriDaml _ _ = return ()
 ------------------------------------------------------------------------

 runLanguageServer
-    :: ((FromServerMessage -> IO ()) -> VFSHandle -> IO IdeState)
+    :: ((FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)
    -> IO ()
 runLanguageServer getIdeState = do
    let handlers = setHandlersKeepAlive <> setHandlersVirtualResource <> setHandlersCodeLens <> setIgnoreOptionalHandlers
--- a/compiler/damlc/daml-opts/daml-opts/DA/Daml/Options.hs
+++ b/compiler/damlc/daml-opts/daml-opts/DA/Daml/Options.hs
@ -35,8 +35,8 @@ import Development.IDE.GHC.Util
 import qualified Development.IDE.Types.Options as HieCore

 -- | Convert to hie-core’s IdeOptions type.
-toCompileOpts :: Options -> HieCore.IdeOptions
-toCompileOpts options@Options{..} =
+toCompileOpts :: Options -> HieCore.IdeReportProgress -> HieCore.IdeOptions
+toCompileOpts options@Options{..} reportProgress =
    HieCore.IdeOptions
      { optPreprocessor = if optIsGenerated then noPreprocessor else damlPreprocessor optMbPackageName
      , optGhcSession = do
@ -52,6 +52,7 @@ toCompileOpts options@Options{..} =
      , optExtensions = ["daml"]
      , optThreads = optThreads
      , optShakeProfiling = optShakeProfiling
+      , optReportProgress = reportProgress
      , optLanguageSyntax = "daml"
      , optNewColonConvention = True
      }
--- a/compiler/damlc/ide-debug-driver/src/IdeDebugDriver.hs
+++ b/compiler/damlc/ide-debug-driver/src/IdeDebugDriver.hs
@ -13,6 +13,7 @@ import qualified Data.Yaml as Yaml
 import qualified Language.Haskell.LSP.Test as LSP
 import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Types hiding (Command)
+import Language.Haskell.LSP.Types.Capabilities
 import Language.Haskell.LSP.Types.Lens
 import qualified Language.Haskell.LSP.Types.Lens as LSP
 import Options.Applicative
@ -78,8 +79,9 @@ damlLanguageId = "daml"

 runSession :: Verbose -> SessionConfig -> IO ()
 runSession (Verbose verbose) SessionConfig{..} =
-    LSP.runSessionWithConfig cnf ideShellCommand LSP.fullCaps ideRoot $ traverse_ interpretCommand ideCommands
+    LSP.runSessionWithConfig cnf ideShellCommand fullCaps' ideRoot $ traverse_ interpretCommand ideCommands
    where cnf = LSP.defaultConfig { LSP.logStdErr = verbose, LSP.logMessages = verbose }
+          fullCaps' = LSP.fullCaps { _window = Just $ WindowClientCapabilities $ Just True }

 progressStart :: LSP.Session ProgressStartNotification
 progressStart = do
--- a/compiler/damlc/lib/DA/Cli/Damlc.hs
+++ b/compiler/damlc/lib/DA/Cli/Damlc.hs
@ -60,6 +60,7 @@ import Development.IDE.Core.RuleTypes.Daml (DalfPackage(..), GetParsedModule(..)
 import Development.IDE.GHC.Util (fakeDynFlags, moduleImportPaths)
 import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
+import Development.IDE.Types.Options (clientSupportsProgress)
 import "ghc-lib-parser" DynFlags
 import GHC.Conc
 import "ghc-lib-parser" Module
@ -309,8 +310,9 @@ execIde telemetry (Debug debug) enableScenarioService mbProfileDir = NS.withSock
            initPackageDb LF.versionDefault (InitPkgDb True)
            sdkVersion <- getSdkVersion `catchIO` const (pure "Unknown (not started via the assistant)")
            Logger.logInfo loggerH (T.pack $ "SDK version: " <> sdkVersion)
-            runLanguageServer
-                (getDamlIdeState opts mbScenarioService loggerH)
+            runLanguageServer $ \sendMsg vfs caps ->
+                getDamlIdeState opts mbScenarioService loggerH sendMsg vfs (clientSupportsProgress caps)
+

 execCompile :: FilePath -> FilePath -> Options -> Command
 execCompile inputFile outputFile opts = withProjectRoot' (ProjectOpts Nothing (ProjectCheck "" False)) $ \relativize -> do
--- a/compiler/damlc/lib/DA/Cli/Damlc/Command/Damldoc.hs
+++ b/compiler/damlc/lib/DA/Cli/Damlc/Command/Damldoc.hs
@ -10,6 +10,7 @@ import DA.Daml.Doc.Extract
 import DA.Daml.Options
 import DA.Daml.Options.Types
 import Development.IDE.Types.Location
+import Development.IDE.Types.Options

 import Options.Applicative
 import Data.List.Extra
@ -194,7 +195,7 @@ exec :: CmdArgs -> IO ()
 exec Damldoc{..} = do
    opts <- defaultOptionsIO Nothing
    runDamlDoc DamldocOptions
-        { do_ideOptions = toCompileOpts opts { optMbPackageName = cPkgName }
+        { do_ideOptions = toCompileOpts opts { optMbPackageName = cPkgName } (IdeReportProgress False)
        , do_outputPath = cOutputPath
        , do_outputFormat = cOutputFormat
        , do_inputFormat = cInputFormat
--- a/compiler/damlc/lib/DA/Cli/Damlc/IdeState.hs
+++ b/compiler/damlc/lib/DA/Cli/Damlc/IdeState.hs
@ -16,6 +16,7 @@ import qualified DA.Daml.Compiler.Scenario as Scenario
 import Development.IDE.Core.Rules.Daml
 import Development.IDE.Core.API
 import qualified Development.IDE.Types.Logger as IdeLogger
+import Development.IDE.Types.Options

 getDamlIdeState
    :: Options
@ -23,11 +24,12 @@ getDamlIdeState
    -> Logger.Handle IO
    -> (LSP.FromServerMessage -> IO ())
    -> VFSHandle
+    -> IdeReportProgress
    -> IO IdeState
-getDamlIdeState compilerOpts mbScenarioService loggerH eventHandler vfs = do
+getDamlIdeState compilerOpts mbScenarioService loggerH eventHandler vfs reportProgress = do
    let rule = mainRule compilerOpts
    damlEnv <- mkDamlEnv compilerOpts mbScenarioService
-    initialise rule eventHandler (toIdeLogger loggerH) damlEnv (toCompileOpts compilerOpts) vfs
+    initialise rule eventHandler (toIdeLogger loggerH) damlEnv (toCompileOpts compilerOpts reportProgress) vfs

 -- Wrapper for the common case where the scenario service will be started automatically (if enabled)
 -- and we use the builtin VFSHandle.
@ -41,7 +43,9 @@ withDamlIdeState opts@Options{..} loggerH eventHandler f = do
    scenarioServiceConfig <- Scenario.readScenarioServiceConfig
    Scenario.withScenarioService' optScenarioService loggerH scenarioServiceConfig $ \mbScenarioService -> do
        vfs <- makeVFSHandle
-        ideState <- getDamlIdeState opts mbScenarioService loggerH eventHandler vfs
+        -- We only use withDamlIdeState outside of the IDE where we do not care about
+        -- progress reporting.
+        ideState <- getDamlIdeState opts mbScenarioService loggerH eventHandler vfs (IdeReportProgress False)
        f ideState

 -- | Adapter to the IDE logger module.
--- a/compiler/damlc/tests/src/DA/Test/DamlDocTest.hs
+++ b/compiler/damlc/tests/src/DA/Test/DamlDocTest.hs
@ -17,6 +17,7 @@ import Development.IDE.Core.Service
 import Development.IDE.Core.Shake
 import Development.IDE.Types.Location
 import Development.IDE.Types.Logger
+import Development.IDE.Types.Options

 main :: IO ()
 main = defaultMain $ testGroup "daml-doctest"
@ -106,7 +107,7 @@ shouldGenerate input expected = withTempFile $ \tmpFile -> do
    T.writeFileUtf8 tmpFile $ T.unlines $ testModuleHeader <> input
    opts <- defaultOptionsIO Nothing
    vfs <- makeVFSHandle
-    ideState <- initialise mainRule (const $ pure ()) noLogging (toCompileOpts opts) vfs
+    ideState <- initialise mainRule (const $ pure ()) noLogging (toCompileOpts opts (IdeReportProgress False)) vfs
    Just pm <- runAction ideState $ use GetParsedModule $ toNormalizedFilePath tmpFile
    genModuleContent (getDocTestModule pm) @?= T.unlines (doctestHeader <> expected)

--- a/compiler/damlc/tests/src/DA/Test/DamlcIntegration.hs
+++ b/compiler/damlc/tests/src/DA/Test/DamlcIntegration.hs
@ -33,6 +33,7 @@ import qualified DA.Daml.Compiler.Scenario as SS
 import qualified DA.Service.Logger.Impl.Pure as Logger
 import qualified Development.IDE.Types.Logger as IdeLogger
 import Development.IDE.Types.Location
+import Development.IDE.Types.Options(IdeReportProgress(..))
 import qualified Data.Aeson as A
 import qualified Data.Aeson.Lens as A
 import           Data.ByteString.Lazy.Char8 (unpack)
@ -134,7 +135,7 @@ getIntegrationTests registerTODO scenarioService version = do
    damlEnv <- mkDamlEnv opts (Just scenarioService)
    pure $
      withResource
-      (initialise (mainRule opts) (const $ pure ()) IdeLogger.noLogging damlEnv (toCompileOpts opts) vfs)
+      (initialise (mainRule opts) (const $ pure ()) IdeLogger.noLogging damlEnv (toCompileOpts opts (IdeReportProgress False)) vfs)
      shutdown $ \service ->
      withTestArguments $ \args -> testGroup ("Tests for DAML-LF " ++ renderPretty version) $
        map (testCase args version service outdir registerTODO) allTestFiles
--- a/compiler/hie-core/exe/Main.hs
+++ b/compiler/hie-core/exe/Main.hs
@ -64,10 +64,11 @@ main = do
    if argLSP then do
        t <- offsetTime
        hPutStrLn stderr "Starting LSP server..."
-        runLanguageServer def def $ \event vfs -> do
+        runLanguageServer def def $ \event vfs caps -> do
            t <- t
            hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
-            let options = defaultIdeOptions $ liftIO $ newSession' =<< findCradle (dir <> "/")
+            let options = (defaultIdeOptions $ liftIO $ newSession' =<< findCradle (dir <> "/"))
+                    { optReportProgress = clientSupportsProgress caps }
            initialise (mainRule >> action kick) event logger options vfs
    else do
        putStrLn "[1/6] Finding hie-bios cradle"
--- a/compiler/hie-core/src/Development/IDE/Core/Service.hs
+++ b/compiler/hie-core/src/Development/IDE/Core/Service.hs
@ -51,6 +51,7 @@ initialise mainRule toDiags logger options vfs =
        toDiags
        logger
        (optShakeProfiling options)
+        (optReportProgress options)
        (shakeOptions { shakeThreads = optThreads options
                     , shakeFiles   = "/dev/null"
                     }) $ do
--- a/compiler/hie-core/src/Development/IDE/Core/Shake.hs
+++ b/compiler/hie-core/src/Development/IDE/Core/Shake.hs
@ -62,6 +62,7 @@ import Language.Haskell.LSP.Diagnostics
 import qualified Data.SortedList as SL
 import           Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
+import Development.IDE.Types.Options
 import           Control.Concurrent.Extra
 import           Control.Exception
 import           Control.DeepSeq
@ -211,7 +212,6 @@ type IdeRule k v =
  , NFData v
  )

-
 -- | A Shake database plus persistent store. Can be thought of as storing
 --   mappings from @(FilePath, k)@ to @RuleResult k@.
 data IdeState = IdeState
@ -278,10 +278,11 @@ seqValue v b = case v of
 shakeOpen :: (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
          -> Logger
          -> Maybe FilePath
+          -> IdeReportProgress
          -> ShakeOptions
          -> Rules ()
          -> IO IdeState
-shakeOpen eventer logger shakeProfileDir opts rules = do
+shakeOpen eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do
    shakeExtras <- do
        globals <- newVar HMap.empty
        state <- newVar HMap.empty
@ -294,7 +295,7 @@ shakeOpen eventer logger shakeProfileDir opts rules = do
        shakeOpenDatabase
            opts
                { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts
-                , shakeProgress = lspShakeProgress eventer
+                , shakeProgress = if reportProgress then lspShakeProgress eventer else const (pure ())
                }
            rules
    shakeAbort <- newVar $ return ()
--- a/compiler/hie-core/src/Development/IDE/LSP/LanguageServer.hs
+++ b/compiler/hie-core/src/Development/IDE/LSP/LanguageServer.hs
@ -10,6 +10,7 @@ module Development.IDE.LSP.LanguageServer
    ) where

 import           Language.Haskell.LSP.Types
+import           Language.Haskell.LSP.Types.Capabilities
 import           Development.IDE.LSP.Server
 import qualified Language.Haskell.LSP.Control as LSP
 import qualified Language.Haskell.LSP.Core as LSP
@ -40,7 +41,7 @@ import Language.Haskell.LSP.Messages
 runLanguageServer
    :: LSP.Options
    -> PartialHandlers
-    -> ((FromServerMessage -> IO ()) -> VFSHandle -> IO IdeState)
+    -> ((FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)
    -> IO ()
 runLanguageServer options userHandlers getIdeState = do
    -- Move stdout to another file descriptor and duplicate stderr
@ -119,7 +120,7 @@ runLanguageServer options userHandlers getIdeState = do
    where
        handleInit :: IO () -> (LspId -> IO ()) -> (LspId -> IO ()) -> Chan Message -> LSP.LspFuncs () -> IO (Maybe err)
        handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
-            ide <- getIdeState sendFunc (makeLSPVFSHandle lspFuncs)
+            ide <- getIdeState sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities
            _ <- flip forkFinally (const exitClientMsg) $ forever $ do
                msg <- readChan clientMsgChan
                case msg of
--- a/compiler/hie-core/src/Development/IDE/Types/Options.hs
+++ b/compiler/hie-core/src/Development/IDE/Types/Options.hs
@ -6,14 +6,17 @@
 -- | Options
 module Development.IDE.Types.Options
  ( IdeOptions(..)
+  , IdeReportProgress(..)
+  , clientSupportsProgress
  , IdePkgLocationOptions(..)
  , defaultIdeOptions
  ) where

+import Data.Maybe
 import Development.Shake
 import           GHC hiding (parseModule, typecheckModule)
 import           GhcPlugins                     as GHC hiding (fst3, (<>))
-
+import qualified Language.Haskell.LSP.Types.Capabilities as LSP

 data IdeOptions = IdeOptions
  { optPreprocessor :: GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource)
@ -25,10 +28,17 @@ data IdeOptions = IdeOptions

  , optThreads :: Int
  , optShakeProfiling :: Maybe FilePath
+  , optReportProgress :: IdeReportProgress
  , optLanguageSyntax :: String -- ^ the ```language to use
  , optNewColonConvention :: Bool -- ^ whether to use new colon convention
  }

+newtype IdeReportProgress = IdeReportProgress Bool
+
+clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress
+clientSupportsProgress caps = IdeReportProgress $ fromMaybe False $
+    LSP._progress =<< LSP._window (caps :: LSP.ClientCapabilities)
+
 defaultIdeOptions :: Action HscEnv -> IdeOptions
 defaultIdeOptions session = IdeOptions
    {optPreprocessor = (,) []
@ -37,6 +47,7 @@ defaultIdeOptions session = IdeOptions
    ,optPkgLocationOpts = defaultIdePkgLocationOptions
    ,optThreads = 0
    ,optShakeProfiling = Nothing
+    ,optReportProgress = IdeReportProgress False
    ,optLanguageSyntax = "haskell"
    ,optNewColonConvention = False
    }
--- a/compiler/hie-core/test/exe/Main.hs
+++ b/compiler/hie-core/test/exe/Main.hs
@ -11,6 +11,7 @@ import Development.IDE.Test
 import Development.IDE.Test.Runfiles
 import Language.Haskell.LSP.Test
 import Language.Haskell.LSP.Types
+import Language.Haskell.LSP.Types.Capabilities
 import System.Environment.Blank (setEnv)
 import System.IO.Extra
 import Test.Tasty
@ -64,7 +65,7 @@ run s = withTempDir $ \dir -> do
  -- HIE calls getXgdDirectory which assumes that HOME is set.
  -- Only sets HOME if it wasn't already set.
  setEnv "HOME" "/homeless-shelter" False
-  runSessionWithConfig conf cmd fullCaps dir s
+  runSessionWithConfig conf cmd fullCaps { _window = Just $ WindowClientCapabilities $ Just True } dir s
  where
    conf = defaultConfig
      -- If you uncomment this you can see all messages
--- a/compiler/lsp-tests/src/Main.hs
+++ b/compiler/lsp-tests/src/Main.hs
@ -14,6 +14,7 @@ import Data.Foldable (toList)
 import Data.List.Extra
 import qualified Data.Text as T
 import Language.Haskell.LSP.Types
+import Language.Haskell.LSP.Types.Capabilities
 import Language.Haskell.LSP.Types.Lens
 import Network.URI
 import System.Environment.Blank
@ -26,19 +27,22 @@ import Test.Tasty.HUnit
 import DA.Daml.Lsp.Test.Util
 import qualified Language.Haskell.LSP.Test as LSP

+fullCaps' :: ClientCapabilities
+fullCaps' = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }
+
 main :: IO ()
 main = do
    setEnv "TASTY_NUM_THREADS" "1" True
    damlcPath <- locateRunfiles $
        mainWorkspace </> "compiler" </> "damlc" </> exe "damlc"
-    let run s = withTempDir $ \dir -> runSessionWithConfig conf (damlcPath <> " ide --scenarios=no") fullCaps dir s
+    let run s = withTempDir $ \dir -> runSessionWithConfig conf (damlcPath <> " ide --scenarios=no") fullCaps' dir s
        runScenarios s
            -- We are currently seeing issues with GRPC FFI calls which make everything
            -- that uses the scenario service extremely flaky and forces us to disable it on
            -- CI. Once https://github.com/digital-asset/daml/issues/1354 is fixed we can
            -- also run scenario tests on Windows.
            | isWindows = pure ()
-            | otherwise = withTempDir $ \dir -> runSessionWithConfig conf (damlcPath <> " ide --scenarios=yes") fullCaps dir s
+            | otherwise = withTempDir $ \dir -> runSessionWithConfig conf (damlcPath <> " ide --scenarios=yes") fullCaps' dir s
    defaultMain $ testGroup "LSP"
        [ diagnosticTests run runScenarios
        , requestTests run runScenarios