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

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"

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

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 ()

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

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
     }

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