mirror of
https://github.com/haskell/ghcide.git
synced 2024-09-11 13:57:06 +03:00
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
This commit is contained in:
parent
d868e06d28
commit
c361a26195
@ -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
|
||||
|
@ -1,5 +1,8 @@
|
||||
packages: .
|
||||
|
||||
package ghcide
|
||||
test-show-details: direct
|
||||
|
||||
allow-newer:
|
||||
active:base,
|
||||
diagrams-contrib:base,
|
||||
|
@ -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
|
@ -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)
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
}
|
||||
|
@ -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
|
||||
----------------------------------------------------------------------
|
||||
|
Loading…
Reference in New Issue
Block a user