LSP diagnostics improvements + upgrade to GHC 9.6.4

language_servers/markdown-spellcheck-lsp/default.nix

@@ -36,6 +36,7 @@ let
   indexJs = stdenv.mkDerivation {
     name = "markdown-spellcheck-lsp-index.js";
 
+    # src = /nix/store/p5bvd7wfib8992v2cpdn0hfk8kxnf2m7-markdown-spellcheck-lsp-tarball/markdown-spellcheck-lsp.tar.gz;
     src = fetchTarball {
       url = https://github.com/codedownio/markdown-spellcheck-lsp/releases/download/v0.5.0/markdown-spellcheck-lsp.tar.gz;
       sha256 = "sha256:020kvqcv38d2nxcj6wgi1wamnpfdwqzss4fm3w3svwcn5ki22psz";
@@ -75,6 +76,8 @@ common.writeTextDirWithMeta hunspell.meta "lib/codedown/language-servers/codedow
     "${contents}/bin/markdown-spellcheck-lsp"
     "--affix-file" "${hunspellDicts.en-us}/share/hunspell/en_US.aff"
     "--dic-file" "${hunspellDicts.en-us}/share/hunspell/en_US.dic"
+    # "--personal-dic-file" ".codedown/personal-dictionary.dic"
+    # "--log-level" "4"
     "--stdio"
   ];
 }])

tests/app/Spec/Tests.hs

@@ -9,6 +9,7 @@ import Control.Concurrent.QSem
 import Control.Monad
 import Control.Monad.Catch
 import Control.Monad.IO.Class
+import Data.Typeable
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Options.Applicative hiding (action)
 import Test.Sandwich
@@ -21,6 +22,7 @@ import TestLib.JupyterRunnerContext
 tests :: forall context. (
   HasBaseContext context
   , HasCommandLineOptions context SpecialOptions
+  , Typeable context
   ) => SpecFree context IO ()
 tests =
   introduceJupyterRunner $

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

@@ -13,7 +13,6 @@ import Language.LSP.Test hiding (message)
 import Spec.Tests.Haskell.Common
 import Test.Sandwich as Sandwich
 import TestLib.LSP
-import TestLib.NixEnvironmentContext
 
 
 documentHighlightTests :: (LspContext context m) => SpecFree context m ()
@@ -48,7 +47,7 @@ documentHighlightCodeRegular = [__i|foo = "hello"
 
 -------------------------------------
 
-main :: IO ()
-main = runSandwichWithCommandLineArgs Sandwich.defaultOptions $ do
-  introduceNixEnvironment [kernelSpec "haskell-ghc92"] [] "Haskell" $ do
-    documentHighlightTests
+-- main :: IO ()
+-- main = runSandwichWithCommandLineArgs Sandwich.defaultOptions $ do
+--   introduceNixEnvironment [kernelSpec "haskell-ghc92"] [] "Haskell" $ do
+--     documentHighlightTests

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

@@ -11,8 +11,8 @@ import qualified Language.LSP.Protocol.Lens as LSP
 import Language.LSP.Protocol.Types
 import Language.LSP.Test
 import Test.Sandwich as Sandwich
+import Test.Sandwich.Contexts.Waits (waitUntil)
 import TestLib.LSP
-import TestLib.Util
 
 
 changesTests :: (LspContext context m) => SpecFree context m ()

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

@@ -9,9 +9,8 @@ import Language.LSP.Protocol.Types
 import Language.LSP.Test
 import Safe
 import Test.Sandwich as Sandwich
-
+import Test.Sandwich.Contexts.Waits (waitUntil)
 import TestLib.LSP
-import TestLib.Util
 
 
 completionTests :: (LspContext context m) => SpecFree context m ()

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

@@ -3,11 +3,11 @@ module Spec.Tests.Rust.Hovers where
 
 import Control.Monad
 import Data.String.Interpolate
-import Language.LSP.Test
 import Language.LSP.Protocol.Types
+import Language.LSP.Test
 import Test.Sandwich as Sandwich
+import Test.Sandwich.Contexts.Waits (waitUntil)
 import TestLib.LSP
-import TestLib.Util
 
 
 hoverTests :: (LspContext context m) => SpecFree context m ()

tests/app/Spec/Tests/Spellchecker.hs

@@ -2,9 +2,14 @@
 
 module Spec.Tests.Spellchecker (tests) where
 
+import Control.Lens
 import Data.String.Interpolate
+import Data.Text
+import Language.LSP.Protocol.Lens hiding (actions, diagnostics)
 import Language.LSP.Protocol.Types
+import Language.LSP.Test hiding (message)
 import Test.Sandwich as Sandwich
+import Test.Sandwich.Contexts.Waits (waitUntil)
 import TestLib.LSP
 import TestLib.NixEnvironmentContext
 import TestLib.NixTypes
@@ -16,12 +21,22 @@ otherPackages = [
   ]
 
 tests :: TopSpec
-tests = describe "Spellchecker" $ introduceNixEnvironment [] otherPackages "Python 3" $ do
+tests = describe "Spellchecker" $ introduceNixEnvironment [] otherPackages "Spellchecker env" $ do
   testDiagnostics "spellchecker" "test.md" Nothing [i|\# This is mispelled|] $ \diagnostics -> do
     assertDiagnosticRanges diagnostics [(Range (Position 0 10) (Position 0 19), Nothing)]
 
   testDiagnostics "spellchecker" "test.md" Nothing [i|I've done a thing.|] $ \diagnostics -> do
     assertDiagnosticRanges diagnostics []
 
+  it "has a code action to fix the misspelling" $ doNotebookSession "spellchecker" [i|\# This is mispelled|] $ \filename -> do
+    ident <- openDoc filename "spellchecker"
+    actions <- getCodeActions ident (Range (Position 0 0) (Position 0 19))
+    waitUntil 60 $ do
+      fmap getTitle actions `shouldBe` ["foo"]
+
+getTitle :: (HasTitle a Text, HasTitle b Text) => (a |? b) -> Text
+getTitle (InL x) = x ^. title
+getTitle (InR x) = x ^. title
+
 main :: IO ()
 main = runSandwichWithCommandLineArgs Sandwich.defaultOptions tests

tests/package.yaml

@@ -40,6 +40,7 @@ dependencies:
 - optparse-applicative
 - safe
 - sandwich
+- sandwich-contexts
 - string-interpolate
 - text
 - vector
@@ -67,7 +68,6 @@ library:
   - row-types
   - safe
   - temporary
-  - time
   - unliftio
   - unliftio-core
 

tests/src/TestLib/Contexts/PostgresqlDatabase.hs

@@ -22,6 +22,7 @@ import Control.Monad.Logger
 import Control.Monad.Reader
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Control.Retry
+import Data.Function
 import Data.List as L
 import Data.Map as M
 import Data.Maybe

tests/src/TestLib/LSP.hs

@@ -36,9 +36,9 @@ import Language.LSP.Test
 import System.FilePath
 import System.IO.Temp (createTempDirectory)
 import Test.Sandwich as Sandwich
+import Test.Sandwich.Contexts.Waits (waitUntil)
 import TestLib.Aeson
 import TestLib.Types
-import TestLib.Util
 import UnliftIO.Directory
 import UnliftIO.Exception
 import UnliftIO.IO
@@ -110,9 +110,9 @@ testDiagnostics'' :: (
   LspContext ctx m
   ) => String -> Text -> FilePath -> Maybe Text -> Text -> [(FilePath, B.ByteString)] -> ([Diagnostic] -> ExampleT ctx m ()) -> SpecFree ctx m ()
 testDiagnostics'' label name filename maybeLanguageId codeToTest extraFiles cb = it label $ do
-  withLspSession' id name filename codeToTest extraFiles $ do
+  withLspSession' (waitUntil 300.0) name filename codeToTest extraFiles $ do
     _ <- openDoc filename (fromMaybe name maybeLanguageId)
-    waitUntil 300.0 (waitForDiagnostics >>= lift . cb)
+    waitForDiagnostics >>= lift . cb
 
 itHasHoverSatisfying :: (
   LspContext ctx m
@@ -192,14 +192,15 @@ withLspSession' handleFn name filename codeToTest extraFiles session = do
            & set (workspace . _Just . didChangeWatchedFiles . _Just . dynamicRegistration) (Just False)
            & set (workspace . _Just . didChangeConfiguration . _Just . dynamicRegistration) (Just False)
 
+  -- TODO: pass home dir to session
   handleFn $ runSessionWithConfigCustomProcess modifyCp sessionConfig lspCommand caps dataDir session
 
-assertDiagnosticRanges :: (HasCallStack, MonadThrow m) => [Diagnostic] -> [(Range, Maybe (Int32 |? Text))] -> ExampleT ctx m ()
+assertDiagnosticRanges :: (HasCallStack, MonadIO m) => [Diagnostic] -> [(Range, Maybe (Int32 |? Text))] -> ExampleT ctx m ()
 assertDiagnosticRanges diagnostics desired = ranges `shouldBe` desired
   where
     ranges = fmap (\x -> (x ^. range, x ^. code)) diagnostics
 
-assertDiagnosticRanges' :: (HasCallStack, MonadThrow m) => [Diagnostic] -> [(Range, Maybe (Int32 |? Text), Text)] -> m ()
+assertDiagnosticRanges' :: (HasCallStack, MonadIO m) => [Diagnostic] -> [(Range, Maybe (Int32 |? Text), Text)] -> m ()
 assertDiagnosticRanges' diagnostics desired = ranges `shouldBe` desired
   where
     ranges = fmap (\x -> (x ^. range, x ^. code, x ^. LSP.message)) diagnostics

tests/src/TestLib/TestBuilding.hs

@@ -4,7 +4,6 @@ module TestLib.TestBuilding where
 
 import Conduit as C
 import Control.Monad.Logger
-import Control.Monad.Trans.Control (MonadBaseControl)
 import System.Exit
 import System.FilePath
 import Test.Sandwich
@@ -13,10 +12,10 @@ import UnliftIO.Directory
 import UnliftIO.Process
 
 
-testBuild :: (MonadIO m, MonadThrow m, MonadBaseControl IO m, MonadLogger m) => String -> m ()
+testBuild :: (MonadUnliftIO m, MonadLogger m) => String -> m ()
 testBuild = testBuild' LevelDebug
 
-testBuild' :: (MonadIO m, MonadThrow m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> String -> m ()
+testBuild' :: (MonadUnliftIO m, MonadLogger m) => LogLevel -> String -> m ()
 testBuild' logLevel expr = do
   rootDir <- findFirstParentMatching (\x -> doesPathExist (x </> ".git"))
 
@@ -25,7 +24,7 @@ testBuild' logLevel expr = do
     }
   waitForProcess p >>= (`shouldBe` ExitSuccess)
 
-testEval :: (MonadIO m, MonadThrow m, MonadBaseControl IO m, MonadLogger m) => String -> m ()
+testEval :: (MonadUnliftIO m, MonadLogger m) => String -> m ()
 testEval expr = do
   rootDir <- findFirstParentMatching (\x -> doesPathExist (x </> ".git"))
 

tests/src/TestLib/Util.hs

@@ -2,21 +2,13 @@
 
 module TestLib.Util where
 
-import Control.Monad.Catch (MonadMask, MonadThrow)
 import Control.Monad.IO.Unlift
-import Control.Retry
 import Data.Aeson (Value)
 import Data.String.Interpolate
 import Data.Text as T
-import Data.Time
-import Data.Typeable
-import GHC.Stack
 import System.FilePath
-import System.Timeout (Timeout)
 import Test.Sandwich
 import UnliftIO.Directory
-import UnliftIO.Exception
-import UnliftIO.Timeout
 
 #if MIN_VERSION_aeson(2,0,0)
 import qualified Data.Aeson.Key             as A
@@ -27,10 +19,10 @@ import qualified Data.HashMap.Strict        as HM
 #endif
 
 
-findFirstParentMatching :: (MonadIO m, MonadThrow m) => (FilePath -> m Bool) -> m FilePath
+findFirstParentMatching :: (MonadIO m) => (FilePath -> m Bool) -> m FilePath
 findFirstParentMatching cb = getCurrentDirectory >>= findFirstParentMatching' cb
 
-findFirstParentMatching' :: (MonadIO m, MonadThrow m) => (FilePath -> m Bool) -> FilePath -> m FilePath
+findFirstParentMatching' :: (MonadIO m) => (FilePath -> m Bool) -> FilePath -> m FilePath
 findFirstParentMatching' cb startingAt = cb startingAt >>= \case
   True -> return startingAt
   False -> case takeDirectory startingAt of
@@ -52,40 +44,3 @@ aesonFromList xs = HM.fromList [(A.fromText k, v) | (k, v) <- xs]
 aesonFromList :: (Eq k, Hashable k) => [(Text, Value)] -> HM.HashMap A.Key v
 aesonFromList = HM.fromList
 #endif
-
--- waitUntil :: forall m a. (HasCallStack, MonadIO m, MonadMask m, MonadThrow m) => Double -> m a -> m a
--- waitUntil timeInSeconds action = do
---   let policy = limitRetriesByCumulativeDelay (round (timeInSeconds * 1_000_000.0)) $ capDelay 200_000 $ exponentialBackoff 1_000
---   recoverAll policy $ const action
-
-waitUntil :: forall m a. (HasCallStack, MonadIO m, MonadMask m, MonadThrow m, MonadUnliftIO m) => Double -> m a -> m a
-waitUntil timeInSeconds action = do
-  startTime <- liftIO getCurrentTime
-
-  recoveringDynamic policy [handleFailureReasonException startTime] $ \_status ->
-    rethrowTimeoutExceptionWithCallStack $
-      timeout (round (timeInSeconds * 1_000_000)) action >>= \case
-        Nothing -> throwIO $ userError [i|Action timed out in waitUntil|]
-        Just x -> return x
-
-  where
-    policy = capDelay 1_000_000 $ exponentialBackoff 1_000
-
-    handleFailureReasonException startTime _status = Handler $ \(_ :: SomeException) ->
-      retryUnlessTimedOut startTime
-
-    retryUnlessTimedOut :: UTCTime -> m RetryAction
-    retryUnlessTimedOut startTime = do
-      now <- liftIO getCurrentTime
-      let thresh = secondsToNominalDiffTime (realToFrac timeInSeconds)
-      if | (diffUTCTime now startTime) > thresh -> return DontRetry
-         | otherwise -> return ConsultPolicy
-
-    rethrowTimeoutExceptionWithCallStack :: (HasCallStack) => m a -> m a
-    rethrowTimeoutExceptionWithCallStack = handleSyncOrAsync $ \(e@(SomeException inner)) ->
-      if | Just (_ :: Timeout) <- fromExceptionUnwrap e -> do
-             throwIO $ userError "Timeout in waitUntil"
-         | Just (SyncExceptionWrapper (cast -> Just (SomeException (cast -> Just (SomeAsyncException (cast -> Just (_ :: Timeout))))))) <- cast inner -> do
-             throwIO $ userError "Timeout in waitUntil"
-         | otherwise -> do
-             throwIO e

tests/stack.yaml

@@ -1,5 +1,5 @@
 
-resolver: lts-21.21
+resolver: lts-22.15
 
 nix:
   pure: false
@@ -17,22 +17,24 @@ packages:
 
 extra-deps:
 - git: https://github.com/codedownio/lsp.git
-  commit: abe10b96fc28b1efa1f71d99ccb980a83602c81e
+  commit: cc4b50ce04d22895c92bdd384540a7d7b8531a4f
   subdirs:
   - lsp
   - lsp-types
   - lsp-test
 
 - git: https://github.com/codedownio/sandwich.git
-  commit: 557515bc9d2934e56d2995ffacb888941ee57716
+  commit: 9f6769f6ec743bb98d07f9a89b90ebe9032f4d4c
   subdirs:
   - sandwich
+  - sandwich-contexts
 
 # Needed by newer sandwich
-- brick-2.1.1
-- vty-6.1
-- vty-crossplatform-0.4.0.0
-- vty-unix-0.2.0.0
 - vty-windows-0.2.0.0
 
 - ex-pool-0.2.1@sha256:c8249338ced27bc4d6395ad9c3069eec394fb111813d6ec736814d095f7e6a24,1293
+
+- crypton-connection-0.3.1@sha256:4d0958537197956b536ea91718b1749949757022532f50b8f683290056a19021,1581
+
+- git: https://github.com/codedownio/minio-hs
+  commit: 768665c90321d118fdd3cde2c6ac6c01310d76a0