Skip to content

Commit 296401c

Browse files
thomasjmthomasjm
committed
LSP diagnostics improvements + upgrade to GHC 9.6.4
1 parent 1ef855e commit 296401c

File tree

15 files changed

+97
-117
lines changed

15 files changed

+97
-117
lines changed

‎language_servers/markdown-spellcheck-lsp/default.nix

+3
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,7 @@ let
3636
indexJs = stdenv.mkDerivation {
3737
name = "markdown-spellcheck-lsp-index.js";
3838

39+
# src = /nix/store/p5bvd7wfib8992v2cpdn0hfk8kxnf2m7-markdown-spellcheck-lsp-tarball/markdown-spellcheck-lsp.tar.gz;
3940
src = fetchTarball {
4041
url = https://github.com/codedownio/markdown-spellcheck-lsp/releases/download/v0.5.0/markdown-spellcheck-lsp.tar.gz;
4142
sha256 = "sha256:020kvqcv38d2nxcj6wgi1wamnpfdwqzss4fm3w3svwcn5ki22psz";
@@ -75,6 +76,8 @@ common.writeTextDirWithMeta hunspell.meta "lib/codedown/language-servers/codedow
7576
"${contents}/bin/markdown-spellcheck-lsp"
7677
"--affix-file" "${hunspellDicts.en-us}/share/hunspell/en_US.aff"
7778
"--dic-file" "${hunspellDicts.en-us}/share/hunspell/en_US.dic"
79+
# "--personal-dic-file" ".codedown/personal-dictionary.dic"
80+
# "--log-level" "4"
7881
"--stdio"
7982
];
8083
}])

‎tests/app/Spec/Tests.hs

+2
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ import Control.Concurrent.QSem
99
import Control.Monad
1010
import Control.Monad.Catch
1111
import Control.Monad.IO.Class
12+
import Data.Typeable
1213
import Control.Monad.Trans.Control (MonadBaseControl)
1314
import Options.Applicative hiding (action)
1415
import Test.Sandwich
@@ -21,6 +22,7 @@ import TestLib.JupyterRunnerContext
2122
tests :: forall context. (
2223
HasBaseContext context
2324
, HasCommandLineOptions context SpecialOptions
25+
, Typeable context
2426
) => SpecFree context IO ()
2527
tests =
2628
introduceJupyterRunner $

‎tests/app/Spec/Tests/Haskell/DocumentHighlight.hs

+4-5
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,6 @@ import Language.LSP.Test hiding (message)
1313
import Spec.Tests.Haskell.Common
1414
import Test.Sandwich as Sandwich
1515
import TestLib.LSP
16-
import TestLib.NixEnvironmentContext
1716

1817

1918
documentHighlightTests :: (LspContext context m) => SpecFree context m ()
@@ -48,7 +47,7 @@ documentHighlightCodeRegular = [__i|foo = "hello"
4847

4948
-------------------------------------
5049

51-
main :: IO ()
52-
main = runSandwichWithCommandLineArgs Sandwich.defaultOptions $ do
53-
introduceNixEnvironment [kernelSpec "haskell-ghc92"] [] "Haskell" $ do
54-
documentHighlightTests
50+
-- main :: IO ()
51+
-- main = runSandwichWithCommandLineArgs Sandwich.defaultOptions $ do
52+
-- introduceNixEnvironment [kernelSpec "haskell-ghc92"] [] "Haskell" $ do
53+
-- documentHighlightTests

‎tests/app/Spec/Tests/Rust/Changes.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -11,8 +11,8 @@ import qualified Language.LSP.Protocol.Lens as LSP
1111
import Language.LSP.Protocol.Types
1212
import Language.LSP.Test
1313
import Test.Sandwich as Sandwich
14+
import Test.Sandwich.Contexts.Waits (waitUntil)
1415
import TestLib.LSP
15-
import TestLib.Util
1616

1717

1818
changesTests :: (LspContext context m) => SpecFree context m ()

‎tests/app/Spec/Tests/Rust/Completion.hs

+1-2
Original file line numberDiff line numberDiff line change
@@ -9,9 +9,8 @@ import Language.LSP.Protocol.Types
99
import Language.LSP.Test
1010
import Safe
1111
import Test.Sandwich as Sandwich
12-
12+
import Test.Sandwich.Contexts.Waits (waitUntil)
1313
import TestLib.LSP
14-
import TestLib.Util
1514

1615

1716
completionTests :: (LspContext context m) => SpecFree context m ()

‎tests/app/Spec/Tests/Rust/Hovers.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -3,11 +3,11 @@ module Spec.Tests.Rust.Hovers where
33

44
import Control.Monad
55
import Data.String.Interpolate
6-
import Language.LSP.Test
76
import Language.LSP.Protocol.Types
7+
import Language.LSP.Test
88
import Test.Sandwich as Sandwich
9+
import Test.Sandwich.Contexts.Waits (waitUntil)
910
import TestLib.LSP
10-
import TestLib.Util
1111

1212

1313
hoverTests :: (LspContext context m) => SpecFree context m ()

‎tests/app/Spec/Tests/Spellchecker.hs

+16-1
Original file line numberDiff line numberDiff line change
@@ -2,9 +2,14 @@
22

33
module Spec.Tests.Spellchecker (tests) where
44

5+
import Control.Lens
56
import Data.String.Interpolate
7+
import Data.Text
8+
import Language.LSP.Protocol.Lens hiding (actions, diagnostics)
69
import Language.LSP.Protocol.Types
10+
import Language.LSP.Test hiding (message)
711
import Test.Sandwich as Sandwich
12+
import Test.Sandwich.Contexts.Waits (waitUntil)
813
import TestLib.LSP
914
import TestLib.NixEnvironmentContext
1015
import TestLib.NixTypes
@@ -16,12 +21,22 @@ otherPackages = [
1621
]
1722

1823
tests :: TopSpec
19-
tests = describe "Spellchecker" $ introduceNixEnvironment [] otherPackages "Python 3" $ do
24+
tests = describe "Spellchecker" $ introduceNixEnvironment [] otherPackages "Spellchecker env" $ do
2025
testDiagnostics "spellchecker" "test.md" Nothing [i|\# This is mispelled|] $ \diagnostics -> do
2126
assertDiagnosticRanges diagnostics [(Range (Position 0 10) (Position 0 19), Nothing)]
2227

2328
testDiagnostics "spellchecker" "test.md" Nothing [i|I've done a thing.|] $ \diagnostics -> do
2429
assertDiagnosticRanges diagnostics []
2530

31+
it "has a code action to fix the misspelling" $ doNotebookSession "spellchecker" [i|\# This is mispelled|] $ \filename -> do
32+
ident <- openDoc filename "spellchecker"
33+
actions <- getCodeActions ident (Range (Position 0 0) (Position 0 19))
34+
waitUntil 60 $ do
35+
fmap getTitle actions `shouldBe` ["foo"]
36+
37+
getTitle :: (HasTitle a Text, HasTitle b Text) => (a |? b) -> Text
38+
getTitle (InL x) = x ^. title
39+
getTitle (InR x) = x ^. title
40+
2641
main :: IO ()
2742
main = runSandwichWithCommandLineArgs Sandwich.defaultOptions tests

‎tests/package.yaml

+1-1
Original file line numberDiff line numberDiff line change
@@ -40,6 +40,7 @@ dependencies:
4040
- optparse-applicative
4141
- safe
4242
- sandwich
43+
- sandwich-contexts
4344
- string-interpolate
4445
- text
4546
- vector
@@ -67,7 +68,6 @@ library:
6768
- row-types
6869
- safe
6970
- temporary
70-
- time
7171
- unliftio
7272
- unliftio-core
7373

‎tests/src/TestLib/Contexts/PostgresqlDatabase.hs

+1
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,7 @@ import Control.Monad.Logger
2222
import Control.Monad.Reader
2323
import Control.Monad.Trans.Control (MonadBaseControl)
2424
import Control.Retry
25+
import Data.Function
2526
import Data.List as L
2627
import Data.Map as M
2728
import Data.Maybe

‎tests/src/TestLib/LSP.hs

+6-5
Original file line numberDiff line numberDiff line change
@@ -36,9 +36,9 @@ import Language.LSP.Test
3636
import System.FilePath
3737
import System.IO.Temp (createTempDirectory)
3838
import Test.Sandwich as Sandwich
39+
import Test.Sandwich.Contexts.Waits (waitUntil)
3940
import TestLib.Aeson
4041
import TestLib.Types
41-
import TestLib.Util
4242
import UnliftIO.Directory
4343
import UnliftIO.Exception
4444
import UnliftIO.IO
@@ -110,9 +110,9 @@ testDiagnostics'' :: (
110110
LspContext ctx m
111111
) => String -> Text -> FilePath -> Maybe Text -> Text -> [(FilePath, B.ByteString)] -> ([Diagnostic] -> ExampleT ctx m ()) -> SpecFree ctx m ()
112112
testDiagnostics'' label name filename maybeLanguageId codeToTest extraFiles cb = it label $ do
113-
withLspSession' id name filename codeToTest extraFiles $ do
113+
withLspSession' (waitUntil 300.0) name filename codeToTest extraFiles $ do
114114
_ <- openDoc filename (fromMaybe name maybeLanguageId)
115-
waitUntil 300.0 (waitForDiagnostics >>= lift . cb)
115+
waitForDiagnostics >>= lift . cb
116116

117117
itHasHoverSatisfying :: (
118118
LspContext ctx m
@@ -192,14 +192,15 @@ withLspSession' handleFn name filename codeToTest extraFiles session = do
192192
& set (workspace . _Just . didChangeWatchedFiles . _Just . dynamicRegistration) (Just False)
193193
& set (workspace . _Just . didChangeConfiguration . _Just . dynamicRegistration) (Just False)
194194

195+
-- TODO: pass home dir to session
195196
handleFn $ runSessionWithConfigCustomProcess modifyCp sessionConfig lspCommand caps dataDir session
196197

197-
assertDiagnosticRanges :: (HasCallStack, MonadThrow m) => [Diagnostic] -> [(Range, Maybe (Int32 |? Text))] -> ExampleT ctx m ()
198+
assertDiagnosticRanges :: (HasCallStack, MonadIO m) => [Diagnostic] -> [(Range, Maybe (Int32 |? Text))] -> ExampleT ctx m ()
198199
assertDiagnosticRanges diagnostics desired = ranges `shouldBe` desired
199200
where
200201
ranges = fmap (\x -> (x ^. range, x ^. code)) diagnostics
201202

202-
assertDiagnosticRanges' :: (HasCallStack, MonadThrow m) => [Diagnostic] -> [(Range, Maybe (Int32 |? Text), Text)] -> m ()
203+
assertDiagnosticRanges' :: (HasCallStack, MonadIO m) => [Diagnostic] -> [(Range, Maybe (Int32 |? Text), Text)] -> m ()
203204
assertDiagnosticRanges' diagnostics desired = ranges `shouldBe` desired
204205
where
205206
ranges = fmap (\x -> (x ^. range, x ^. code, x ^. LSP.message)) diagnostics

‎tests/src/TestLib/TestBuilding.hs

+3-4
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,6 @@ module TestLib.TestBuilding where
44

55
import Conduit as C
66
import Control.Monad.Logger
7-
import Control.Monad.Trans.Control (MonadBaseControl)
87
import System.Exit
98
import System.FilePath
109
import Test.Sandwich
@@ -13,10 +12,10 @@ import UnliftIO.Directory
1312
import UnliftIO.Process
1413

1514

16-
testBuild :: (MonadIO m, MonadThrow m, MonadBaseControl IO m, MonadLogger m) => String -> m ()
15+
testBuild :: (MonadUnliftIO m, MonadLogger m) => String -> m ()
1716
testBuild = testBuild' LevelDebug
1817

19-
testBuild' :: (MonadIO m, MonadThrow m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> String -> m ()
18+
testBuild' :: (MonadUnliftIO m, MonadLogger m) => LogLevel -> String -> m ()
2019
testBuild' logLevel expr = do
2120
rootDir <- findFirstParentMatching (\x -> doesPathExist (x </> ".git"))
2221

@@ -25,7 +24,7 @@ testBuild' logLevel expr = do
2524
}
2625
waitForProcess p >>= (`shouldBe` ExitSuccess)
2726

28-
testEval :: (MonadIO m, MonadThrow m, MonadBaseControl IO m, MonadLogger m) => String -> m ()
27+
testEval :: (MonadUnliftIO m, MonadLogger m) => String -> m ()
2928
testEval expr = do
3029
rootDir <- findFirstParentMatching (\x -> doesPathExist (x </> ".git"))
3130

‎tests/src/TestLib/Util.hs

+2-47
Original file line numberDiff line numberDiff line change
@@ -2,21 +2,13 @@
22

33
module TestLib.Util where
44

5-
import Control.Monad.Catch (MonadMask, MonadThrow)
65
import Control.Monad.IO.Unlift
7-
import Control.Retry
86
import Data.Aeson (Value)
97
import Data.String.Interpolate
108
import Data.Text as T
11-
import Data.Time
12-
import Data.Typeable
13-
import GHC.Stack
149
import System.FilePath
15-
import System.Timeout (Timeout)
1610
import Test.Sandwich
1711
import UnliftIO.Directory
18-
import UnliftIO.Exception
19-
import UnliftIO.Timeout
2012

2113
#if MIN_VERSION_aeson(2,0,0)
2214
import qualified Data.Aeson.Key as A
@@ -27,10 +19,10 @@ import qualified Data.HashMap.Strict as HM
2719
#endif
2820

2921

30-
findFirstParentMatching :: (MonadIO m, MonadThrow m) => (FilePath -> m Bool) -> m FilePath
22+
findFirstParentMatching :: (MonadIO m) => (FilePath -> m Bool) -> m FilePath
3123
findFirstParentMatching cb = getCurrentDirectory >>= findFirstParentMatching' cb
3224

33-
findFirstParentMatching' :: (MonadIO m, MonadThrow m) => (FilePath -> m Bool) -> FilePath -> m FilePath
25+
findFirstParentMatching' :: (MonadIO m) => (FilePath -> m Bool) -> FilePath -> m FilePath
3426
findFirstParentMatching' cb startingAt = cb startingAt >>= \case
3527
True -> return startingAt
3628
False -> case takeDirectory startingAt of
@@ -52,40 +44,3 @@ aesonFromList xs = HM.fromList [(A.fromText k, v) | (k, v) <- xs]
5244
aesonFromList :: (Eq k, Hashable k) => [(Text, Value)] -> HM.HashMap A.Key v
5345
aesonFromList = HM.fromList
5446
#endif
55-
56-
-- waitUntil :: forall m a. (HasCallStack, MonadIO m, MonadMask m, MonadThrow m) => Double -> m a -> m a
57-
-- waitUntil timeInSeconds action = do
58-
-- let policy = limitRetriesByCumulativeDelay (round (timeInSeconds * 1_000_000.0)) $ capDelay 200_000 $ exponentialBackoff 1_000
59-
-- recoverAll policy $ const action
60-
61-
waitUntil :: forall m a. (HasCallStack, MonadIO m, MonadMask m, MonadThrow m, MonadUnliftIO m) => Double -> m a -> m a
62-
waitUntil timeInSeconds action = do
63-
startTime <- liftIO getCurrentTime
64-
65-
recoveringDynamic policy [handleFailureReasonException startTime] $ \_status ->
66-
rethrowTimeoutExceptionWithCallStack $
67-
timeout (round (timeInSeconds * 1_000_000)) action >>= \case
68-
Nothing -> throwIO $ userError [i|Action timed out in waitUntil|]
69-
Just x -> return x
70-
71-
where
72-
policy = capDelay 1_000_000 $ exponentialBackoff 1_000
73-
74-
handleFailureReasonException startTime _status = Handler $ \(_ :: SomeException) ->
75-
retryUnlessTimedOut startTime
76-
77-
retryUnlessTimedOut :: UTCTime -> m RetryAction
78-
retryUnlessTimedOut startTime = do
79-
now <- liftIO getCurrentTime
80-
let thresh = secondsToNominalDiffTime (realToFrac timeInSeconds)
81-
if | (diffUTCTime now startTime) > thresh -> return DontRetry
82-
| otherwise -> return ConsultPolicy
83-
84-
rethrowTimeoutExceptionWithCallStack :: (HasCallStack) => m a -> m a
85-
rethrowTimeoutExceptionWithCallStack = handleSyncOrAsync $ \(e@(SomeException inner)) ->
86-
if | Just (_ :: Timeout) <- fromExceptionUnwrap e -> do
87-
throwIO $ userError "Timeout in waitUntil"
88-
| Just (SyncExceptionWrapper (cast -> Just (SomeException (cast -> Just (SomeAsyncException (cast -> Just (_ :: Timeout))))))) <- cast inner -> do
89-
throwIO $ userError "Timeout in waitUntil"
90-
| otherwise -> do
91-
throwIO e

‎tests/stack.yaml

+9-7
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11

2-
resolver: lts-21.21
2+
resolver: lts-22.15
33

44
nix:
55
pure: false
@@ -17,22 +17,24 @@ packages:
1717

1818
extra-deps:
1919
- git: https://github.com/codedownio/lsp.git
20-
commit: abe10b96fc28b1efa1f71d99ccb980a83602c81e
20+
commit: cc4b50ce04d22895c92bdd384540a7d7b8531a4f
2121
subdirs:
2222
- lsp
2323
- lsp-types
2424
- lsp-test
2525

2626
- git: https://github.com/codedownio/sandwich.git
27-
commit: 557515bc9d2934e56d2995ffacb888941ee57716
27+
commit: 9f6769f6ec743bb98d07f9a89b90ebe9032f4d4c
2828
subdirs:
2929
- sandwich
30+
- sandwich-contexts
3031

3132
# Needed by newer sandwich
32-
- brick-2.1.1
33-
- vty-6.1
34-
- vty-crossplatform-0.4.0.0
35-
- vty-unix-0.2.0.0
3633
- vty-windows-0.2.0.0
3734

3835
- ex-pool-0.2.1@sha256:c8249338ced27bc4d6395ad9c3069eec394fb111813d6ec736814d095f7e6a24,1293
36+
37+
- crypton-connection-0.3.1@sha256:4d0958537197956b536ea91718b1749949757022532f50b8f683290056a19021,1581
38+
39+
- git: https://github.com/codedownio/minio-hs
40+
commit: 768665c90321d118fdd3cde2c6ac6c01310d76a0

0 commit comments

Comments
 (0)