Store the lsp client settings in shakeExtras and create a Rule to get them (#731)

* Store client settings in ide state

* Log ide config registered in initHandler

* Use a Maybe aware updater function

* Create a Rule to get client settings

* Create a specific getter for client settings

* Trim trailing whitespace

* Use modifyVar to avoid race conditions

* Add comment to GetClientSettings

* Use defineEarlyCutOffNoFile for GetClientSettings

* Restart shake on config changed

* Use Hashed for clientSettings

* Send log notifications to client about session

* Show test output directly

* Add tests over client settings

* Apply hlint hints

* Simplify iface test to make it more robust

Following @pepeiborra advise

* Send session notifications only in test mode

* Retry bench execution

.azure/linux-bench.yml

@@ -38,7 +38,8 @@ jobs:
     displayName: 'stack build --bench --only-dependencies'
   - bash: |
       export PATH=/opt/cabal/bin:$PATH
-      stack bench --ghc-options=-Werror  --stack-yaml=$STACK_YAML
+      # Retry to avoid fpcomplete servers timeouts
+      stack bench --ghc-options=-Werror --stack-yaml=$STACK_YAML || stack bench --ghc-options=-Werror --stack-yaml=$STACK_YAML  || stack bench --ghc-options=-Werror --stack-yaml=$STACK_YAML
     displayName: 'stack bench --ghc-options=-Werror'
   - bash: |
       cat bench-hist/results.csv

cabal.project

@@ -1,5 +1,8 @@
 packages: .
 
+package ghcide
+  test-show-details: direct
+
 allow-newer:
 	active:base,
 	diagrams-contrib:base,

src/Development/IDE/Core/IdeConfiguration.hs

@@ -2,17 +2,22 @@
 module Development.IDE.Core.IdeConfiguration
   ( IdeConfiguration(..)
   , registerIdeConfiguration
+  , getIdeConfiguration
   , parseConfiguration
   , parseWorkspaceFolder
   , isWorkspaceFile
   , modifyWorkspaceFolders
+  , modifyClientSettings
+  , getClientSettings
   )
 where
 
 import           Control.Concurrent.Extra
 import           Control.Monad
+import           Data.Hashable                  (Hashed, hashed, unhashed)
 import           Data.HashSet                   (HashSet, singleton)
 import           Data.Text                      (Text, isPrefixOf)
+import           Data.Aeson.Types               (Value)
 import           Development.IDE.Core.Shake
 import           Development.IDE.Types.Location
 import           Development.Shake
@@ -22,6 +27,7 @@ import           System.FilePath (isRelative)
 -- | Lsp client relevant configuration details
 data IdeConfiguration = IdeConfiguration
   { workspaceFolders :: HashSet NormalizedUri
+  , clientSettings :: Hashed (Maybe Value)
   }
   deriving (Show)
 
@@ -39,13 +45,14 @@ getIdeConfiguration =
 
 parseConfiguration :: InitializeParams -> IdeConfiguration
 parseConfiguration InitializeParams {..} =
-  IdeConfiguration { .. }
+  IdeConfiguration {..}
  where
   workspaceFolders =
     foldMap (singleton . toNormalizedUri) _rootUri
       <> (foldMap . foldMap)
            (singleton . parseWorkspaceFolder)
            _workspaceFolders
+  clientSettings = hashed _initializationOptions
 
 parseWorkspaceFolder :: WorkspaceFolder -> NormalizedUri
 parseWorkspaceFolder =
@@ -53,10 +60,20 @@ parseWorkspaceFolder =
 
 modifyWorkspaceFolders
   :: IdeState -> (HashSet NormalizedUri -> HashSet NormalizedUri) -> IO ()
-modifyWorkspaceFolders ide f = do
+modifyWorkspaceFolders ide f = modifyIdeConfiguration ide f'
+  where f' (IdeConfiguration ws initOpts) = IdeConfiguration (f ws) initOpts
+
+modifyClientSettings
+  :: IdeState -> (Maybe Value -> Maybe Value) -> IO ()
+modifyClientSettings ide f = modifyIdeConfiguration ide f'
+  where f' (IdeConfiguration ws clientSettings) =
+            IdeConfiguration ws (hashed . f . unhashed $ clientSettings)
+
+modifyIdeConfiguration
+  :: IdeState -> (IdeConfiguration -> IdeConfiguration) -> IO ()
+modifyIdeConfiguration ide f = do
   IdeConfigurationVar var <- getIdeGlobalState ide
-  IdeConfiguration    ws  <- readVar var
-  writeVar var (IdeConfiguration (f ws))
+  modifyVar_ var (pure . f)
 
 isWorkspaceFile :: NormalizedFilePath -> Action Bool
 isWorkspaceFile file =
@@ -69,3 +86,6 @@ isWorkspaceFile file =
         any
           (\root -> toText root `isPrefixOf` toText (filePathToUri' file))
           workspaceFolders
+
+getClientSettings :: Action (Maybe Value)
+getClientSettings = unhashed . clientSettings <$> getIdeConfiguration

src/Development/IDE/Core/RuleTypes.hs

@@ -12,6 +12,7 @@ module Development.IDE.Core.RuleTypes(
     ) where
 
 import           Control.DeepSeq
+import Data.Aeson.Types (Value)
 import Data.Binary
 import           Development.IDE.Import.DependencyInformation
 import Development.IDE.GHC.Compat
@@ -253,3 +254,12 @@ data GetModSummary = GetModSummary
 instance Hashable GetModSummary
 instance NFData   GetModSummary
 instance Binary   GetModSummary
+
+-- | Get the vscode client settings stored in the ide state
+data GetClientSettings = GetClientSettings
+    deriving (Eq, Show, Typeable, Generic)
+instance Hashable GetClientSettings
+instance NFData   GetClientSettings
+instance Binary   GetClientSettings
+
+type instance RuleResult GetClientSettings = Hashed (Maybe Value)

src/Development/IDE/Core/Rules.hs

@@ -12,7 +12,7 @@
 --
 module Development.IDE.Core.Rules(
     IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
-    Priority(..), GhcSessionIO(..),
+    Priority(..), GhcSessionIO(..), GetClientSettings(..),
     priorityTypeCheck,
     priorityGenerateCore,
     priorityFilesOfInterest,
@@ -73,6 +73,7 @@ import DynFlags (gopt_set, xopt)
 import GHC.Generics(Generic)
 
 import qualified Development.IDE.Spans.AtPoint as AtPoint
+import Development.IDE.Core.IdeConfiguration
 import Development.IDE.Core.Service
 import Development.IDE.Core.Shake
 import Development.Shake.Classes hiding (get, put)
@@ -833,6 +834,12 @@ extractHiFileResult (Just tmr) =
     -- Bang patterns are important to force the inner fields
     Just $! tmr_hiFileResult tmr
 
+getClientSettingsRule :: Rules ()
+getClientSettingsRule = defineEarlyCutOffNoFile $ \GetClientSettings -> do
+  alwaysRerun
+  settings <- clientSettings <$> getIdeConfiguration
+  return (BS.pack . show . hash $ settings, settings)
+
 -- | A rule that wires per-file rules together
 mainRule :: Rules ()
 mainRule = do
@@ -852,6 +859,7 @@ mainRule = do
     isHiFileStableRule
     getModuleGraphRule
     knownFilesRule
+    getClientSettingsRule
 
 -- | Given the path to a module src file, this rule returns True if the
 -- corresponding `.hi` file is stable, that is, if it is newer

src/Development/IDE/Core/Shake.hs

@@ -567,9 +567,10 @@ shakeRestart IdeState{..} acts =
               let profile = case res of
                       Just fp -> ", profile saved at " <> fp
                       _ -> ""
-              logDebug (logger shakeExtras) $ T.pack $
-                  "Restarting build session (aborting the previous one took " ++
-                  showDuration stopTime ++ profile ++ ")"
+              let msg = T.pack $ "Restarting build session (aborting the previous one took "
+                              ++ showDuration stopTime ++ profile ++ ")"
+              logDebug (logger shakeExtras) msg
+              notifyTestingLogMessage shakeExtras msg
         )
         -- It is crucial to be masked here, otherwise we can get killed
         -- between spawning the new thread and updating shakeSession.
@@ -577,6 +578,14 @@ shakeRestart IdeState{..} acts =
         (\() -> do
           (,()) <$> newSession shakeExtras shakeDb acts)
 
+notifyTestingLogMessage :: ShakeExtras -> T.Text -> IO ()
+notifyTestingLogMessage extras msg = do
+    (IdeTesting isTestMode) <- optTesting <$> getIdeOptionsIO extras
+    let notif = LSP.NotLogMessage $ LSP.NotificationMessage "2.0" LSP.WindowLogMessage
+                                  $ LSP.LogMessageParams LSP.MtLog msg
+    when isTestMode $ eventer extras notif
+
+
 -- | Enqueue an action in the existing 'ShakeSession'.
 --   Returns a computation to block until the action is run, propagating exceptions.
 --   Assumes a 'ShakeSession' is available.
@@ -602,7 +611,7 @@ shakeEnqueue ShakeExtras{actionQueue, logger} act = do
 -- | Set up a new 'ShakeSession' with a set of initial actions
 --   Will crash if there is an existing 'ShakeSession' running.
 newSession :: ShakeExtras -> ShakeDatabase -> [DelayedActionInternal] -> IO ShakeSession
-newSession ShakeExtras{..} shakeDb acts = do
+newSession extras@ShakeExtras{..} shakeDb acts = do
     reenqueued <- atomically $ peekInProgress actionQueue
     let
         -- A daemon-like action used to inject additional work
@@ -616,8 +625,11 @@ newSession ShakeExtras{..} shakeDb acts = do
             getAction d
             liftIO $ atomically $ doneQueue d actionQueue
             runTime <- liftIO start
-            liftIO $ logPriority logger (actionPriority d) $ T.pack $
-                "finish: " ++ actionName d ++ " (took " ++ showDuration runTime ++ ")"
+            let msg = T.pack $ "finish: " ++ actionName d
+                            ++ " (took " ++ showDuration runTime ++ ")"
+            liftIO $ do
+                logPriority logger (actionPriority d) msg
+                notifyTestingLogMessage extras msg
 
         workRun restore = do
           let acts' = pumpActionThread : map run (reenqueued ++ acts)
@@ -625,9 +637,10 @@ newSession ShakeExtras{..} shakeDb acts = do
           let res' = case res of
                       Left e -> "exception: " <> displayException e
                       Right _ -> "completed"
-
-          let wrapUp = logDebug logger $ T.pack $ "Finishing build session(" ++ res' ++ ")"
-          return wrapUp
+          let msg = T.pack $ "Finishing build session(" ++ res' ++ ")"
+          return $ do
+              logDebug logger msg
+              notifyTestingLogMessage extras msg
 
     -- Do the work in a background thread
     workThread <- asyncWithUnmask workRun

src/Development/IDE/LSP/LanguageServer.hs

@@ -204,7 +204,10 @@ initHandler
     -> IdeState
     -> InitializeParams
     -> IO ()
-initHandler _ ide params = registerIdeConfiguration (shakeExtras ide) (parseConfiguration params)
+initHandler _ ide params = do
+    let initConfig = parseConfiguration params
+    logInfo (ideLogger ide) $ T.pack $ "Registering ide configuration: " <> show initConfig
+    registerIdeConfiguration (shakeExtras ide) initConfig
 
 -- | Things that get sent to us, but we don't deal with.
 --   Set them to avoid a warning in VS Code output.

src/Development/IDE/LSP/Notifications.hs

@@ -91,4 +91,11 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
             modifyWorkspaceFolders ide
               $ add       (foldMap (S.singleton . parseWorkspaceFolder) (_added   events))
               . substract (foldMap (S.singleton . parseWorkspaceFolder) (_removed events))
+
+    ,LSP.didChangeConfigurationParamsHandler = withNotification (LSP.didChangeConfigurationParamsHandler x) $
+        \_ ide (DidChangeConfigurationParams cfg) -> do
+            let msg = Text.pack $ show cfg
+            logInfo (ideLogger ide) $ "Configuration changed: " <> msg
+            modifyClientSettings ide (const $ Just cfg)
+            setSomethingModified ide
     }

test/exe/Main.hs

@@ -15,7 +15,7 @@ import Control.Exception (bracket, catch)
 import qualified Control.Lens as Lens
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
-import Data.Aeson (FromJSON, Value)
+import Data.Aeson (FromJSON, Value, toJSON)
 import qualified Data.Binary as Binary
 import Data.Foldable
 import Data.List.Extra
@@ -94,6 +94,7 @@ main = do
     , bootTests
     , rootUriTests
     , asyncTests
+    , clientSettingsTest
     ]
 
 initializeResponseTests :: TestTree
@@ -2252,7 +2253,7 @@ checkFileCompiles fp =
     expectNoMoreDiagnostics 0.5
 
 pluginSimpleTests :: TestTree
-pluginSimpleTests = 
+pluginSimpleTests =
   testSessionWait "simple plugin" $ do
     let content =
           T.unlines
@@ -2274,11 +2275,11 @@ pluginSimpleTests =
           )
       ]
 
-pluginParsedResultTests :: TestTree 
-pluginParsedResultTests = 
-  (`xfail84` "record-dot-preprocessor unsupported on 8.4") $ testSessionWait "parsedResultAction plugin" $ do 
-    let content = 
-          T.unlines 
+pluginParsedResultTests :: TestTree
+pluginParsedResultTests =
+  (`xfail84` "record-dot-preprocessor unsupported on 8.4") $ testSessionWait "parsedResultAction plugin" $ do
+    let content =
+          T.unlines
             [ "{-# LANGUAGE DuplicateRecordFields, TypeApplications, FlexibleContexts, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}"
             , "{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}"
             , "module Testing (Company(..), display) where"
@@ -2286,7 +2287,7 @@ pluginParsedResultTests =
             , "display :: Company -> String"
             , "display c = c.name"
             ]
-    _ <- createDoc "Testing.hs" "haskell" content 
+    _ <- createDoc "Testing.hs" "haskell" content
     expectNoMoreDiagnostics 1
 
 cppTests :: TestTree
@@ -3083,9 +3084,7 @@ ifaceErrorTest = testCase "iface-error-test-1" $ withoutStackEnv $ runWithExtraF
 
     -- Check that we wrote the interfaces for B when we saved
     lid <- sendRequest (CustomClientMethod "hidir") $ GetInterfaceFilesDir bPath
-    res <- skipManyTill (message :: Session WorkDoneProgressCreateRequest) $
-           skipManyTill (message :: Session WorkDoneProgressBeginNotification) $
-             responseForId lid
+    res <- skipManyTill anyMessage $ responseForId lid
     liftIO $ case res of
       ResponseMessage{_result=Right hidir} -> do
         hi_exists <- doesFileExist $ hidir </> "B.hi"
@@ -3277,6 +3276,26 @@ asyncTests = testGroup "async"
             liftIO $ [ _title | CACodeAction CodeAction{_title} <- actions] @=? ["add signature: foo :: a -> a"]
     ]
 
+
+clientSettingsTest :: TestTree
+clientSettingsTest = testGroup "client settings handling"
+    [
+        testSession "ghcide does not support update config" $ do
+            sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String)))
+            logNot <- skipManyTill anyMessage loggingNotification
+            isMessagePresent "Updating Not supported" [getLogMessage logNot]
+    ,   testSession "ghcide restarts shake session on config changes" $ do
+            sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON ("" :: String)))
+            nots <- skipManyTill anyMessage $ count 3 loggingNotification
+            isMessagePresent "Restarting build session" (map getLogMessage nots)
+
+    ]
+  where getLogMessage (NotLogMessage (NotificationMessage _ _ (LogMessageParams _ msg))) = msg
+        getLogMessage _ = ""
+
+        isMessagePresent expectedMsg actualMsgs = liftIO $
+            assertBool ("\"" ++ expectedMsg ++ "\" is not present in: " ++ show actualMsgs)
+                       (any ((expectedMsg `isSubsequenceOf`) . show) actualMsgs)
 ----------------------------------------------------------------------
 -- Utils
 ----------------------------------------------------------------------