mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-11 08:45:35 +03:00
Another attempt at using the lsp API for some progress reporting (#4218)
* Another attempt at using the lsp API for some progress reporting * Fixing tests * Remove trace * Make splice plugin tests not depend on progress * More test fixing * Switch to hackage * stack * warnings * more * Put tests back --------- Co-authored-by: Patrick <fwy996602672@gmail.com>
This commit is contained in:
Michael Peyton Jones
GitHub
parent
b43dcbb8cf
commit
0651c5c904
@ -7,7 +7,7 @@ packages:
|
||||
./hls-plugin-api
|
||||
./hls-test-utils
|
||||
|
||||
index-state: 2024-04-30T10:44:19Z
|
||||
index-state: 2024-05-10T00:00:00Z
|
||||
|
||||
tests: True
|
||||
test-show-details: direct
|
||||
|
||||
@ -88,7 +88,7 @@ library
|
||||
, implicit-hie >= 0.1.4.0 && < 0.1.5
|
||||
, lens
|
||||
, list-t
|
||||
, lsp ^>=2.5.0.0
|
||||
, lsp ^>=2.6.0.0
|
||||
, lsp-types ^>=2.2.0.0
|
||||
, mtl
|
||||
, opentelemetry >=0.6.1
|
||||
|
||||
@ -2,7 +2,7 @@ module Development.IDE.Core.ProgressReporting
|
||||
( ProgressEvent(..)
|
||||
, ProgressReporting(..)
|
||||
, noProgressReporting
|
||||
, delayedProgressReporting
|
||||
, progressReporting
|
||||
-- utilities, reexported for use in Core.Shake
|
||||
, mRunLspT
|
||||
, mRunLspTCallback
|
||||
@ -12,31 +12,28 @@ module Development.IDE.Core.ProgressReporting
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM.Stats (TVar, atomicallyNamed,
|
||||
modifyTVar', newTVarIO,
|
||||
readTVarIO)
|
||||
import Control.Concurrent.Strict
|
||||
import Control.Concurrent.STM.Stats (TVar, atomically,
|
||||
atomicallyNamed, modifyTVar',
|
||||
newTVarIO, readTVar, retry)
|
||||
import Control.Concurrent.Strict (modifyVar_, newVar,
|
||||
threadDelay)
|
||||
import Control.Monad.Extra hiding (loop)
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.Aeson (ToJSON (toJSON))
|
||||
import Data.Foldable (for_)
|
||||
import Data.Functor (($>))
|
||||
import qualified Data.Text as T
|
||||
import Data.Unique
|
||||
import Development.IDE.GHC.Orphans ()
|
||||
import Development.IDE.Graph hiding (ShakeValue)
|
||||
import Development.IDE.Types.Location
|
||||
import Development.IDE.Types.Options
|
||||
import qualified Focus
|
||||
import Language.LSP.Protocol.Message
|
||||
import Language.LSP.Protocol.Types
|
||||
import qualified Language.LSP.Protocol.Types as LSP
|
||||
import Language.LSP.Server (ProgressAmount (..),
|
||||
ProgressCancellable (..),
|
||||
withProgress)
|
||||
import qualified Language.LSP.Server as LSP
|
||||
import qualified StmContainers.Map as STM
|
||||
import System.Time.Extra
|
||||
import UnliftIO.Exception (bracket_)
|
||||
import UnliftIO (Async, async, cancel)
|
||||
|
||||
data ProgressEvent
|
||||
= KickStarted
|
||||
@ -64,14 +61,14 @@ data State
|
||||
-- | State transitions used in 'delayedProgressReporting'
|
||||
data Transition = Event ProgressEvent | StopProgress
|
||||
|
||||
updateState :: IO (Async ()) -> Transition -> State -> IO State
|
||||
updateState _ _ Stopped = pure Stopped
|
||||
updateState start (Event KickStarted) NotStarted = Running <$> start
|
||||
updateState start (Event KickStarted) (Running a) = cancel a >> Running <$> start
|
||||
updateState _ (Event KickCompleted) (Running a) = cancel a $> NotStarted
|
||||
updateState _ (Event KickCompleted) st = pure st
|
||||
updateState _ StopProgress (Running a) = cancel a $> Stopped
|
||||
updateState _ StopProgress st = pure st
|
||||
updateState :: IO () -> Transition -> State -> IO State
|
||||
updateState _ _ Stopped = pure Stopped
|
||||
updateState start (Event KickStarted) NotStarted = Running <$> async start
|
||||
updateState start (Event KickStarted) (Running job) = cancel job >> Running <$> async start
|
||||
updateState _ (Event KickCompleted) (Running job) = cancel job $> NotStarted
|
||||
updateState _ (Event KickCompleted) st = pure st
|
||||
updateState _ StopProgress (Running job) = cancel job $> Stopped
|
||||
updateState _ StopProgress st = pure st
|
||||
|
||||
-- | Data structure to track progress across the project
|
||||
data InProgressState = InProgressState
|
||||
@ -93,7 +90,7 @@ recordProgress InProgressState{..} file shift = do
|
||||
(Just 0, 0) -> pure ()
|
||||
(Just 0, _) -> modifyTVar' doneVar pred
|
||||
(Just _, 0) -> modifyTVar' doneVar (+1)
|
||||
(Just _, _) -> pure()
|
||||
(Just _, _) -> pure ()
|
||||
where
|
||||
alterPrevAndNew = do
|
||||
prev <- Focus.lookup
|
||||
@ -102,91 +99,38 @@ recordProgress InProgressState{..} file shift = do
|
||||
return (prev, new)
|
||||
alter x = let x' = maybe (shift 0) shift x in Just x'
|
||||
|
||||
-- | A 'ProgressReporting' that enqueues Begin and End notifications in a new
|
||||
-- thread, with a grace period (nothing will be sent if 'KickCompleted' arrives
|
||||
-- before the end of the grace period).
|
||||
delayedProgressReporting
|
||||
:: Seconds -- ^ Grace period before starting
|
||||
-> Seconds -- ^ sampling delay
|
||||
-> Maybe (LSP.LanguageContextEnv c)
|
||||
progressReporting
|
||||
:: Maybe (LSP.LanguageContextEnv c)
|
||||
-> ProgressReportingStyle
|
||||
-> IO ProgressReporting
|
||||
delayedProgressReporting _before _after Nothing _optProgressStyle = noProgressReporting
|
||||
delayedProgressReporting before after (Just lspEnv) optProgressStyle = do
|
||||
progressReporting Nothing _optProgressStyle = noProgressReporting
|
||||
progressReporting (Just lspEnv) optProgressStyle = do
|
||||
inProgressState <- newInProgress
|
||||
progressState <- newVar NotStarted
|
||||
let progressUpdate event = updateStateVar $ Event event
|
||||
progressStop = updateStateVar StopProgress
|
||||
updateStateVar = modifyVar_ progressState . updateState (lspShakeProgress inProgressState)
|
||||
|
||||
progressStop = updateStateVar StopProgress
|
||||
updateStateVar = modifyVar_ progressState . updateState (lspShakeProgressNew inProgressState)
|
||||
inProgress = updateStateForFile inProgressState
|
||||
return ProgressReporting{..}
|
||||
where
|
||||
lspShakeProgress InProgressState{..} = do
|
||||
-- first sleep a bit, so we only show progress messages if it's going to take
|
||||
-- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
|
||||
liftIO $ sleep before
|
||||
u <- ProgressToken . InR . T.pack . show . hashUnique <$> liftIO newUnique
|
||||
|
||||
b <- liftIO newBarrier
|
||||
void $ LSP.runLspT lspEnv $ LSP.sendRequest SMethod_WindowWorkDoneProgressCreate
|
||||
LSP.WorkDoneProgressCreateParams { _token = u } $ liftIO . signalBarrier b
|
||||
liftIO $ async $ do
|
||||
ready <- waitBarrier b
|
||||
LSP.runLspT lspEnv $ for_ ready $ const $ bracket_ (start u) (stop u) (loop u 0)
|
||||
lspShakeProgressNew :: InProgressState -> IO ()
|
||||
lspShakeProgressNew InProgressState{..} =
|
||||
LSP.runLspT lspEnv $ withProgress "Processing" Nothing NotCancellable $ \update -> loop update 0
|
||||
where
|
||||
start token = LSP.sendNotification SMethod_Progress $
|
||||
LSP.ProgressParams
|
||||
{ _token = token
|
||||
, _value = toJSON $ WorkDoneProgressBegin
|
||||
{ _kind = AString @"begin"
|
||||
, _title = "Processing"
|
||||
, _cancellable = Nothing
|
||||
, _message = Nothing
|
||||
, _percentage = Nothing
|
||||
}
|
||||
}
|
||||
stop token = LSP.sendNotification SMethod_Progress
|
||||
LSP.ProgressParams
|
||||
{ _token = token
|
||||
, _value = toJSON $ WorkDoneProgressEnd
|
||||
{ _kind = AString @"end"
|
||||
, _message = Nothing
|
||||
}
|
||||
}
|
||||
loop _ _ | optProgressStyle == NoProgress =
|
||||
forever $ liftIO $ threadDelay maxBound
|
||||
loop token prevPct = do
|
||||
done <- liftIO $ readTVarIO doneVar
|
||||
todo <- liftIO $ readTVarIO todoVar
|
||||
liftIO $ sleep after
|
||||
if todo == 0 then loop token 0 else do
|
||||
let
|
||||
nextFrac :: Double
|
||||
nextFrac = fromIntegral done / fromIntegral todo
|
||||
loop _ _ | optProgressStyle == NoProgress = forever $ liftIO $ threadDelay maxBound
|
||||
loop update prevPct = do
|
||||
(todo, done, nextPct) <- liftIO $ atomically $ do
|
||||
todo <- readTVar todoVar
|
||||
done <- readTVar doneVar
|
||||
let nextFrac :: Double
|
||||
nextFrac = if todo == 0 then 0 else fromIntegral done / fromIntegral todo
|
||||
nextPct :: UInt
|
||||
nextPct = floor $ 100 * nextFrac
|
||||
when (nextPct /= prevPct) $
|
||||
LSP.sendNotification SMethod_Progress $
|
||||
LSP.ProgressParams
|
||||
{ _token = token
|
||||
, _value = case optProgressStyle of
|
||||
Explicit -> toJSON $ WorkDoneProgressReport
|
||||
{ _kind = AString @"report"
|
||||
, _cancellable = Nothing
|
||||
, _message = Just $ T.pack $ show done <> "/" <> show todo
|
||||
, _percentage = Nothing
|
||||
}
|
||||
Percentage -> toJSON $ WorkDoneProgressReport
|
||||
{ _kind = AString @"report"
|
||||
, _cancellable = Nothing
|
||||
, _message = Nothing
|
||||
, _percentage = Just nextPct
|
||||
}
|
||||
NoProgress -> error "unreachable"
|
||||
}
|
||||
loop token nextPct
|
||||
when (nextPct == prevPct) retry
|
||||
pure (todo, done, nextPct)
|
||||
|
||||
update (ProgressAmount (Just nextPct) (Just $ T.pack $ show done <> "/" <> show todo))
|
||||
loop update nextPct
|
||||
updateStateForFile inProgress file = actionBracket (f succ) (const $ f pred) . const
|
||||
-- This functions are deliberately eta-expanded to avoid space leaks.
|
||||
-- Do not remove the eta-expansion without profiling a session with at
|
||||
|
||||
@ -660,10 +660,9 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
|
||||
atomically $ modifyTVar' exportsMap (<> em)
|
||||
logWith recorder Debug $ LogCreateHieDbExportsMapFinish (ExportsMap.size em)
|
||||
|
||||
progress <- do
|
||||
let (before, after) = if testing then (0,0.1) else (0.1,0.1)
|
||||
progress <-
|
||||
if reportProgress
|
||||
then delayedProgressReporting before after lspEnv optProgressStyle
|
||||
then progressReporting lspEnv optProgressStyle
|
||||
else noProgressReporting
|
||||
actionQueue <- newQueue
|
||||
|
||||
|
||||
@ -3,6 +3,7 @@
|
||||
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE NumericUnderscores #-}
|
||||
-- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync
|
||||
-- This version removes the daml: handling
|
||||
module Development.IDE.LSP.LanguageServer
|
||||
|
||||
@ -238,7 +238,15 @@ defaultArguments recorder plugins = Arguments
|
||||
{ optCheckProject = pure $ checkProject config
|
||||
, optCheckParents = pure $ checkParents config
|
||||
}
|
||||
, argsLspOptions = def {LSP.optCompletionTriggerCharacters = Just "."}
|
||||
, argsLspOptions = def
|
||||
{ LSP.optCompletionTriggerCharacters = Just "."
|
||||
-- Generally people start to notice that something is taking a while at about 1s, so
|
||||
-- that's when we start reporting progress
|
||||
, LSP.optProgressStartDelay = 1_00_000
|
||||
-- Once progress is being reported, it's nice to see that it's moving reasonably quickly,
|
||||
-- but not so fast that it's ugly. This number is a bit made up
|
||||
, LSP.optProgressUpdateDelay = 1_00_000
|
||||
}
|
||||
, argsDefaultHlsConfig = def
|
||||
, argsGetHieDbLoc = getHieDbLoc
|
||||
, argsDebouncer = newAsyncDebouncer
|
||||
@ -266,7 +274,7 @@ defaultArguments recorder plugins = Arguments
|
||||
testing :: Recorder (WithPriority Log) -> IdePlugins IdeState -> Arguments
|
||||
testing recorder plugins =
|
||||
let
|
||||
arguments@Arguments{ argsHlsPlugins, argsIdeOptions } =
|
||||
arguments@Arguments{ argsHlsPlugins, argsIdeOptions, argsLspOptions } =
|
||||
defaultArguments recorder plugins
|
||||
hlsPlugins = pluginDescToIdePlugins $
|
||||
idePluginsToPluginDesc argsHlsPlugins
|
||||
@ -276,10 +284,12 @@ testing recorder plugins =
|
||||
defOptions = argsIdeOptions config sessionLoader
|
||||
in
|
||||
defOptions{ optTesting = IdeTesting True }
|
||||
lspOptions = argsLspOptions { LSP.optProgressStartDelay = 0, LSP.optProgressUpdateDelay = 0 }
|
||||
in
|
||||
arguments
|
||||
{ argsHlsPlugins = hlsPlugins
|
||||
, argsIdeOptions = ideOptions
|
||||
, argsLspOptions = lspOptions
|
||||
}
|
||||
|
||||
defaultMain :: Recorder (WithPriority Log) -> Arguments -> IO ()
|
||||
|
||||
@ -180,8 +180,7 @@ thLinkingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do
|
||||
-- modify b too
|
||||
let bSource' = T.unlines $ init (T.lines bSource) ++ ["$th"]
|
||||
changeDoc bdoc [TextDocumentContentChangeEvent . InR $ TextDocumentContentChangeWholeDocument bSource']
|
||||
waitForProgressBegin
|
||||
waitForAllProgressDone
|
||||
waitForDiagnostics
|
||||
|
||||
expectCurrentDiagnostics bdoc [(DiagnosticSeverity_Warning, (4,1), "Top-level binding")]
|
||||
|
||||
|
||||
@ -258,7 +258,7 @@ library hls-cabal-plugin
|
||||
, hls-plugin-api == 2.8.0.0
|
||||
, hls-graph == 2.8.0.0
|
||||
, lens
|
||||
, lsp ^>=2.5
|
||||
, lsp ^>=2.6
|
||||
, lsp-types ^>=2.2
|
||||
, regex-tdfa ^>=1.3.1
|
||||
, text
|
||||
@ -389,7 +389,7 @@ library hls-call-hierarchy-plugin
|
||||
, hiedb ^>= 0.6.0.0
|
||||
, hls-plugin-api == 2.8.0.0
|
||||
, lens
|
||||
, lsp >=2.5
|
||||
, lsp >=2.6
|
||||
, sqlite-simple
|
||||
, text
|
||||
|
||||
@ -1002,7 +1002,7 @@ library hls-alternate-number-format-plugin
|
||||
, hls-graph
|
||||
, hls-plugin-api == 2.8.0.0
|
||||
, lens
|
||||
, lsp ^>=2.5
|
||||
, lsp ^>=2.6
|
||||
, mtl
|
||||
, regex-tdfa
|
||||
, syb
|
||||
@ -1232,7 +1232,7 @@ library hls-gadt-plugin
|
||||
, hls-plugin-api == 2.8.0.0
|
||||
, haskell-language-server:hls-refactor-plugin
|
||||
, lens
|
||||
, lsp >=2.5
|
||||
, lsp >=2.6
|
||||
, mtl
|
||||
, text
|
||||
, transformers
|
||||
@ -1281,7 +1281,7 @@ library hls-explicit-fixity-plugin
|
||||
, ghcide == 2.8.0.0
|
||||
, hashable
|
||||
, hls-plugin-api == 2.8.0.0
|
||||
, lsp >=2.5
|
||||
, lsp >=2.6
|
||||
, text
|
||||
|
||||
default-extensions: DataKinds
|
||||
@ -1736,7 +1736,7 @@ library hls-semantic-tokens-plugin
|
||||
, ghcide == 2.8.0.0
|
||||
, hls-plugin-api == 2.8.0.0
|
||||
, lens
|
||||
, lsp >=2.5
|
||||
, lsp >=2.6
|
||||
, text
|
||||
, transformers
|
||||
, bytestring
|
||||
@ -1804,7 +1804,7 @@ library hls-notes-plugin
|
||||
, hls-graph == 2.8.0.0
|
||||
, hls-plugin-api == 2.8.0.0
|
||||
, lens
|
||||
, lsp >=2.5
|
||||
, lsp >=2.6
|
||||
, mtl >= 2.2
|
||||
, regex-tdfa >= 1.3.1
|
||||
, text
|
||||
|
||||
@ -69,7 +69,7 @@ library
|
||||
, hls-graph == 2.8.0.0
|
||||
, lens
|
||||
, lens-aeson
|
||||
, lsp ^>=2.5
|
||||
, lsp ^>=2.6
|
||||
, megaparsec >=9.0
|
||||
, mtl
|
||||
, opentelemetry >=0.4
|
||||
|
||||
@ -25,8 +25,7 @@ import Test.Hls (CodeAction (..), Command,
|
||||
mkPluginTestDescriptor',
|
||||
openDoc, runSessionWithServer,
|
||||
testCase, testGroup, toEither,
|
||||
type (|?),
|
||||
waitForAllProgressDone,
|
||||
type (|?), waitForBuildQueue,
|
||||
waitForDiagnostics, (@?=))
|
||||
import Text.Regex.TDFA ((=~))
|
||||
|
||||
@ -96,7 +95,7 @@ goldenChangeSignature fp = goldenWithHaskellDoc def changeTypeSignaturePlugin (f
|
||||
codeActionTest :: FilePath -> Int -> Int -> TestTree
|
||||
codeActionTest fp line col = goldenChangeSignature fp $ \doc -> do
|
||||
void waitForDiagnostics -- code actions are triggered from Diagnostics
|
||||
void waitForAllProgressDone -- apparently some tests need this to get the CodeAction to show up
|
||||
void waitForBuildQueue -- apparently some tests need this to get the CodeAction to show up
|
||||
actions <- getCodeActions doc (pointRange line col)
|
||||
foundActions <- findChangeTypeActions actions
|
||||
liftIO $ length foundActions @?= 1
|
||||
|
||||
@ -1,9 +1,12 @@
|
||||
-- IO expressions are supported, stdout/stderr output is ignored
|
||||
module TIO where
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
|
||||
{-
|
||||
Does not capture stdout, returns value.
|
||||
Has a delay in order to show progress reporting.
|
||||
|
||||
>>> print "ABC" >> return "XYZ"
|
||||
>>> threadDelay 2000000 >> print "ABC" >> return "XYZ"
|
||||
"XYZ"
|
||||
-}
|
||||
|
||||
5
plugins/hls-eval-plugin/test/testdata/TIO.hs
vendored
5
plugins/hls-eval-plugin/test/testdata/TIO.hs
vendored
@ -1,9 +1,12 @@
|
||||
-- IO expressions are supported, stdout/stderr output is ignored
|
||||
module TIO where
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
|
||||
{-
|
||||
Does not capture stdout, returns value.
|
||||
Has a delay in order to show progress reporting.
|
||||
|
||||
>>> print "ABC" >> return "XYZ"
|
||||
>>> threadDelay 2000000 >> print "ABC" >> return "XYZ"
|
||||
"XYZ"
|
||||
-}
|
||||
|
||||
@ -236,14 +236,11 @@ suggestionsTests =
|
||||
, testCase "[#1279] hlint should not activate extensions like PatternSynonyms" $ runHlintSession "" $ do
|
||||
doc <- openDoc "PatternKeyword.hs" "haskell"
|
||||
|
||||
waitForAllProgressDone
|
||||
-- hlint will report a parse error if PatternSynonyms is enabled
|
||||
expectNoMoreDiagnostics 3 doc "hlint"
|
||||
, testCase "hlint should not warn about redundant irrefutable pattern with LANGUAGE Strict" $ runHlintSession "" $ do
|
||||
doc <- openDoc "StrictData.hs" "haskell"
|
||||
|
||||
waitForAllProgressDone
|
||||
|
||||
expectNoMoreDiagnostics 3 doc "hlint"
|
||||
]
|
||||
where
|
||||
|
||||
@ -1,10 +1,9 @@
|
||||
module Main (main) where
|
||||
|
||||
import Development.IDE.Test
|
||||
import Ide.Plugin.Notes (Log, descriptor)
|
||||
import System.Directory (canonicalizePath)
|
||||
import System.FilePath ((</>))
|
||||
import Test.Hls hiding (waitForBuildQueue)
|
||||
import Ide.Plugin.Notes (Log, descriptor)
|
||||
import System.Directory (canonicalizePath)
|
||||
import System.FilePath ((</>))
|
||||
import Test.Hls
|
||||
|
||||
plugin :: PluginTestDescriptor Log
|
||||
plugin = mkPluginTestDescriptor descriptor "notes"
|
||||
@ -19,16 +18,14 @@ gotoNoteTests :: TestTree
|
||||
gotoNoteTests = testGroup "Goto Note Definition"
|
||||
[ testCase "single_file" $ runSessionWithServer def plugin testDataDir $ do
|
||||
doc <- openDoc "NoteDef.hs" "haskell"
|
||||
waitForBuildQueue
|
||||
waitForAllProgressDone
|
||||
waitForKickDone
|
||||
defs <- getDefinitions doc (Position 3 41)
|
||||
liftIO $ do
|
||||
fp <- canonicalizePath "NoteDef.hs"
|
||||
defs @?= InL (Definition (InR [Location (filePathToUri fp) (Range (Position 8 9) (Position 8 9))]))
|
||||
, testCase "liberal_format" $ runSessionWithServer def plugin testDataDir $ do
|
||||
doc <- openDoc "NoteDef.hs" "haskell"
|
||||
waitForBuildQueue
|
||||
waitForAllProgressDone
|
||||
waitForKickDone
|
||||
defs <- getDefinitions doc (Position 5 64)
|
||||
liftIO $ do
|
||||
fp <- canonicalizePath "NoteDef.hs"
|
||||
@ -36,24 +33,20 @@ gotoNoteTests = testGroup "Goto Note Definition"
|
||||
|
||||
, testCase "invalid_note" $ runSessionWithServer def plugin testDataDir $ do
|
||||
doc <- openDoc "NoteDef.hs" "haskell"
|
||||
waitForBuildQueue
|
||||
waitForAllProgressDone
|
||||
waitForKickDone
|
||||
defs <- getDefinitions doc (Position 6 54)
|
||||
liftIO $ do
|
||||
defs @?= InL (Definition (InR []))
|
||||
|
||||
, testCase "no_note" $ runSessionWithServer def plugin testDataDir $ do
|
||||
doc <- openDoc "NoteDef.hs" "haskell"
|
||||
waitForBuildQueue
|
||||
waitForAllProgressDone
|
||||
waitForKickDone
|
||||
defs <- getDefinitions doc (Position 1 0)
|
||||
liftIO $ defs @?= InL (Definition (InR []))
|
||||
|
||||
, testCase "unopened_file" $ runSessionWithServer def plugin testDataDir $ do
|
||||
doc <- openDoc "Other.hs" "haskell"
|
||||
waitForCustomMessage "ghcide/cradle/loaded" (const $ Just ())
|
||||
waitForBuildQueue
|
||||
waitForAllProgressDone
|
||||
waitForKickDone
|
||||
defs <- getDefinitions doc (Position 5 20)
|
||||
liftIO $ do
|
||||
fp <- canonicalizePath "NoteDef.hs"
|
||||
|
||||
@ -87,8 +87,9 @@ goldenTestWithEdit fp expect tc line col =
|
||||
{ _start = Position 0 0
|
||||
, _end = Position (fromIntegral $ length lns + 1) 1
|
||||
}
|
||||
waitForAllProgressDone -- cradle
|
||||
waitForAllProgressDone
|
||||
|
||||
void waitForDiagnostics
|
||||
void waitForBuildQueue
|
||||
alt <- liftIO $ T.readFile (fp <.> "error.hs")
|
||||
void $ applyEdit doc $ TextEdit theRange alt
|
||||
changeDoc doc [TextDocumentContentChangeEvent $ InL
|
||||
|
||||
@ -23,8 +23,8 @@ extra-deps:
|
||||
- monad-dijkstra-0.1.1.3
|
||||
- retrie-1.2.2
|
||||
- stylish-haskell-0.14.4.0
|
||||
- lsp-2.5.0.0
|
||||
- lsp-test-0.17.0.1
|
||||
- lsp-2.6.0.0
|
||||
- lsp-test-0.17.0.2
|
||||
- lsp-types-2.2.0.0
|
||||
|
||||
# stan dependencies not found in the stackage snapshot
|
||||
|
||||
@ -20,8 +20,8 @@ extra-deps:
|
||||
- hiedb-0.6.0.0
|
||||
- hie-bios-0.14.0
|
||||
- implicit-hie-0.1.4.0
|
||||
- lsp-2.5.0.0
|
||||
- lsp-test-0.17.0.1
|
||||
- lsp-2.6.0.0
|
||||
- lsp-test-0.17.0.2
|
||||
- lsp-types-2.2.0.0
|
||||
- monad-dijkstra-0.1.1.4
|
||||
|
||||
|
||||
@ -29,15 +29,16 @@ tests =
|
||||
runSession hlsLspCommand progressCaps "test/testdata/diagnostics" $ do
|
||||
let path = "Foo.hs"
|
||||
_ <- openDoc path "haskell"
|
||||
expectProgressMessages [pack ("Setting up diagnostics (for " ++ path ++ ")"), "Processing", "Indexing"] []
|
||||
expectProgressMessages [pack ("Setting up diagnostics (for " ++ path ++ ")"), "Processing", "Indexing"] [] []
|
||||
, requiresEvalPlugin $ testCase "eval plugin sends progress reports" $
|
||||
runSession hlsLspCommand progressCaps "plugins/hls-eval-plugin/test/testdata" $ do
|
||||
doc <- openDoc "T1.hs" "haskell"
|
||||
doc <- openDoc "TIO.hs" "haskell"
|
||||
lspId <- sendRequest SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing doc)
|
||||
|
||||
(codeLensResponse, activeProgressTokens) <- expectProgressMessagesTill
|
||||
(codeLensResponse, createdProgressTokens, activeProgressTokens) <- expectProgressMessagesTill
|
||||
(responseForId SMethod_TextDocumentCodeLens lspId)
|
||||
["Setting up testdata (for T1.hs)", "Processing"]
|
||||
["Setting up testdata (for TIO.hs)", "Processing"]
|
||||
[]
|
||||
[]
|
||||
|
||||
-- this is a test so exceptions result in fails
|
||||
@ -52,24 +53,24 @@ tests =
|
||||
(command ^. L.command)
|
||||
(decode $ encode $ fromJust $ command ^. L.arguments)
|
||||
|
||||
expectProgressMessages ["Evaluating"] activeProgressTokens
|
||||
expectProgressMessages ["Evaluating"] createdProgressTokens activeProgressTokens
|
||||
_ -> error $ "Unexpected response result: " ++ show response
|
||||
, requiresOrmoluPlugin $ testCase "ormolu plugin sends progress notifications" $ do
|
||||
runSessionWithConfig (def { ignoreConfigurationRequests = False }) hlsLspCommand progressCaps "test/testdata/format" $ do
|
||||
void configurationRequest
|
||||
setHlsConfig (formatLspConfig "ormolu")
|
||||
doc <- openDoc "Format.hs" "haskell"
|
||||
expectProgressMessages ["Setting up format (for Format.hs)", "Processing", "Indexing"] []
|
||||
expectProgressMessages ["Setting up format (for Format.hs)", "Processing", "Indexing"] [] []
|
||||
_ <- sendRequest SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing)
|
||||
expectProgressMessages ["Formatting Format.hs"] []
|
||||
expectProgressMessages ["Formatting Format.hs"] [] []
|
||||
, requiresFourmoluPlugin $ testCase "fourmolu plugin sends progress notifications" $ do
|
||||
runSessionWithConfig (def { ignoreConfigurationRequests = False }) hlsLspCommand progressCaps "test/testdata/format" $ do
|
||||
void configurationRequest
|
||||
setHlsConfig (formatLspConfig "fourmolu")
|
||||
doc <- openDoc "Format.hs" "haskell"
|
||||
expectProgressMessages ["Setting up format (for Format.hs)", "Processing", "Indexing"] []
|
||||
expectProgressMessages ["Setting up format (for Format.hs)", "Processing", "Indexing"] [] []
|
||||
_ <- sendRequest SMethod_TextDocumentFormatting $ DocumentFormattingParams Nothing doc (FormattingOptions 2 True Nothing Nothing Nothing)
|
||||
expectProgressMessages ["Formatting Format.hs"] []
|
||||
expectProgressMessages ["Formatting Format.hs"] [] []
|
||||
]
|
||||
|
||||
formatLspConfig :: Text -> Config
|
||||
@ -113,50 +114,52 @@ interestingMessage :: Session a -> Session (InterestingMessage a)
|
||||
interestingMessage theMessage =
|
||||
fmap InterestingMessage theMessage <|> fmap ProgressMessage progressMessage
|
||||
|
||||
expectProgressMessagesTill :: Session a -> [Text] -> [ProgressToken] -> Session (a, [ProgressToken])
|
||||
expectProgressMessagesTill stopMessage expectedTitles activeProgressTokens = do
|
||||
expectProgressMessagesTill :: Session a -> [Text] -> [ProgressToken] -> [ProgressToken] -> Session (a, [ProgressToken], [ProgressToken])
|
||||
expectProgressMessagesTill stopMessage expectedTitles createdProgressTokens activeProgressTokens = do
|
||||
message <- skipManyTill anyMessage (interestingMessage stopMessage)
|
||||
case message of
|
||||
InterestingMessage a -> do
|
||||
liftIO $ null expectedTitles @? "Expected titles not empty " <> show expectedTitles
|
||||
pure (a, activeProgressTokens)
|
||||
pure (a, createdProgressTokens, activeProgressTokens)
|
||||
ProgressMessage progressMessage ->
|
||||
updateExpectProgressStateAndRecurseWith
|
||||
(expectProgressMessagesTill stopMessage)
|
||||
progressMessage
|
||||
expectedTitles
|
||||
createdProgressTokens
|
||||
activeProgressTokens
|
||||
|
||||
{- | Test that the server is correctly producing a sequence of progress related
|
||||
messages. Each create must be pair with a corresponding begin and end,
|
||||
messages. Creates can be dangling, but should be paired with a corresponding begin and end,
|
||||
optionally with some progress in between. Tokens must match. The begin
|
||||
messages have titles describing the work that is in-progress, we check that
|
||||
the titles we see are those we expect.
|
||||
-}
|
||||
expectProgressMessages :: [Text] -> [ProgressToken] -> Session ()
|
||||
expectProgressMessages [] [] = pure ()
|
||||
expectProgressMessages expectedTitles activeProgressTokens = do
|
||||
expectProgressMessages :: [Text] -> [ProgressToken] -> [ProgressToken] -> Session ()
|
||||
expectProgressMessages [] _ [] = pure ()
|
||||
expectProgressMessages expectedTitles createdProgressTokens activeProgressTokens = do
|
||||
message <- skipManyTill anyMessage progressMessage
|
||||
updateExpectProgressStateAndRecurseWith expectProgressMessages message expectedTitles activeProgressTokens
|
||||
updateExpectProgressStateAndRecurseWith expectProgressMessages message expectedTitles createdProgressTokens activeProgressTokens
|
||||
|
||||
updateExpectProgressStateAndRecurseWith :: ([Text] -> [ProgressToken] -> Session a)
|
||||
updateExpectProgressStateAndRecurseWith :: ([Text] -> [ProgressToken] -> [ProgressToken] -> Session a)
|
||||
-> ProgressMessage
|
||||
-> [Text]
|
||||
-> [ProgressToken]
|
||||
-> [ProgressToken]
|
||||
-> Session a
|
||||
updateExpectProgressStateAndRecurseWith f progressMessage expectedTitles activeProgressTokens = do
|
||||
updateExpectProgressStateAndRecurseWith f progressMessage expectedTitles createdProgressTokens activeProgressTokens = do
|
||||
case progressMessage of
|
||||
ProgressCreate params -> do
|
||||
f expectedTitles ((params ^. L.token): activeProgressTokens)
|
||||
f expectedTitles ((params ^. L.token): createdProgressTokens) activeProgressTokens
|
||||
ProgressBegin token params -> do
|
||||
liftIO $ token `expectedIn` activeProgressTokens
|
||||
f (delete (params ^. L.title) expectedTitles) activeProgressTokens
|
||||
liftIO $ token `expectedIn` createdProgressTokens
|
||||
f (delete (params ^. L.title) expectedTitles) (delete token createdProgressTokens) (token:activeProgressTokens)
|
||||
ProgressReport token _ -> do
|
||||
liftIO $ token `expectedIn` activeProgressTokens
|
||||
f expectedTitles activeProgressTokens
|
||||
f expectedTitles createdProgressTokens activeProgressTokens
|
||||
ProgressEnd token _ -> do
|
||||
liftIO $ token `expectedIn` activeProgressTokens
|
||||
f expectedTitles (delete token activeProgressTokens)
|
||||
f expectedTitles createdProgressTokens (delete token activeProgressTokens)
|
||||
|
||||
|
||||
expectedIn :: (Foldable t, Eq a, Show a) => a -> t a -> Assertion
|
||||
|
||||
@ -22,10 +22,10 @@ hlsExeCommand = unsafePerformIO $ do
|
||||
pure testExe
|
||||
|
||||
hlsLspCommand :: String
|
||||
hlsLspCommand = hlsExeCommand ++ " --lsp -d -j4"
|
||||
hlsLspCommand = hlsExeCommand ++ " --lsp --test -d -j4"
|
||||
|
||||
hlsWrapperLspCommand :: String
|
||||
hlsWrapperLspCommand = hlsWrapperExeCommand ++ " --lsp -d -j4"
|
||||
hlsWrapperLspCommand = hlsWrapperExeCommand ++ " --lsp --test -d -j4"
|
||||
|
||||
hlsWrapperExeCommand :: String
|
||||
{-# NOINLINE hlsWrapperExeCommand #-}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user