diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,12 @@ # Revision history for lsp-test +## 0.14.0.3 + +* Compatibility with new `lsp-types` major version. + ## 0.14.0.2 -* Compatibility with new lsp-types major version. +* Compatibility with new `lsp-types` major version. ## 0.14.0.1 -- 2021-07-30 diff --git a/bench/SimpleBench.hs b/bench/SimpleBench.hs --- a/bench/SimpleBench.hs +++ b/bench/SimpleBench.hs @@ -44,7 +44,7 @@ n <- read . head <$> getArgs - forkIO $ void $ runServerWithHandles hinRead houtWrite server + forkIO $ void $ runServerWithHandles mempty mempty hinRead houtWrite server liftIO $ putStrLn $ "Starting " <> show n <> " rounds" i <- newIORef 0 diff --git a/func-test/FuncTest.hs b/func-test/FuncTest.hs --- a/func-test/FuncTest.hs +++ b/func-test/FuncTest.hs @@ -18,9 +18,11 @@ import UnliftIO.Concurrent import Control.Exception import System.Exit +import qualified Colog.Core as L main :: IO () main = hspec $ do + let logger = L.cmap show L.logStringStderr describe "progress reporting" $ it "sends end notification if thread is killed" $ do (hinRead, hinWrite) <- createPipe @@ -48,7 +50,7 @@ takeMVar killVar killThread tid - forkIO $ void $ runServerWithHandles hinRead houtWrite definition + forkIO $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite definition Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do -- First make sure that we get a $/progress begin notification @@ -107,8 +109,7 @@ _ -> error "Shouldn't be here" ] - - server <- async $ void $ runServerWithHandles hinRead houtWrite definition + server <- async $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite definition let config = Test.defaultConfig { Test.initialWorkspaceFolders = Just [wf0] diff --git a/lsp-test.cabal b/lsp-test.cabal --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: lsp-test -version: 0.14.0.2 +version: 0.14.0.3 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against @@ -36,23 +36,25 @@ , parser-combinators:Control.Applicative.Combinators default-language: Haskell2010 build-depends: base >= 4.10 && < 5 - , lsp-types == 1.4.* + , lsp-types == 1.5.* + , lsp == 1.5.* , aeson , time , aeson-pretty , ansi-terminal - , async + , async >= 2.0 , bytestring + , co-log-core , conduit , conduit-parse == 0.2.* , containers >= 0.5.9 , data-default - , Diff + , Diff >= 0.3 , directory , filepath , Glob >= 0.9 && < 0.11 , lens - , mtl + , mtl < 2.4 , parser-combinators >= 1.2 , process >= 1.6 , text @@ -81,7 +83,7 @@ build-depends: base >= 4.10 && < 5 , hspec , lens - , lsp == 1.4.* + , lsp == 1.5.* , lsp-test , data-default , aeson @@ -91,7 +93,7 @@ , filepath , unliftio , process - , mtl + , mtl < 2.4 , aeson default-language: Haskell2010 @@ -103,6 +105,7 @@ , lsp-test , lsp , process + , co-log-core , lens , unliftio , hspec diff --git a/src/Language/LSP/Test.hs b/src/Language/LSP/Test.hs --- a/src/Language/LSP/Test.hs +++ b/src/Language/LSP/Test.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeInType #-} @@ -119,7 +118,7 @@ import Data.Maybe import Language.LSP.Types import Language.LSP.Types.Lens hiding - (id, capabilities, message, executeCommand, applyEdit, rename) + (id, capabilities, message, executeCommand, applyEdit, rename, to) import qualified Language.LSP.Types.Lens as LSP import qualified Language.LSP.Types.Capabilities as C import Language.LSP.VFS @@ -135,6 +134,7 @@ import System.FilePath import System.Process (ProcessHandle) import qualified System.FilePath.Glob as Glob +import Control.Monad.State (execState) -- | Starts a new session. -- @@ -151,7 +151,7 @@ -> IO a runSession = runSessionWithConfig def --- | Starts a new sesion with a custom configuration. +-- | Starts a new session with a custom configuration. runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session. -> String -- ^ The command to run the server. -> C.ClientCapabilities -- ^ The capabilities that the client should declare. @@ -198,7 +198,7 @@ config <- envOverrideConfig config' let initializeParams = InitializeParams Nothing - -- Narowing to Int32 here, but it's unlikely that a pid will + -- Narrowing to Int32 here, but it's unlikely that a PID will -- be outside the range (Just $ fromIntegral pid) (Just lspTestClientInfo) @@ -241,7 +241,7 @@ exitServer :: Session () exitServer = request_ SShutdown Empty >> sendNotification SExit Empty - -- | Listens to the server output until the shutdown ack, + -- | Listens to the server output until the shutdown ACK, -- makes sure it matches the record and signals any semaphores listenServer :: Handle -> SessionContext -> IO () listenServer serverOut context = do @@ -280,7 +280,7 @@ documentContents :: TextDocumentIdentifier -> Session T.Text documentContents doc = do vfs <- vfs <$> get - let file = vfsMap vfs Map.! toNormalizedUri (doc ^. uri) + let Just file = vfs ^. vfsMap . at (toNormalizedUri (doc ^. uri)) return (virtualFileText file) -- | Parses an ApplyEditRequest, checks that it is for the passed document @@ -348,7 +348,7 @@ sendNotification STextDocumentDidOpen params = do let n = NotificationMessage "2.0" STextDocumentDidOpen params oldVFS <- vfs <$> get - let (newVFS,_) = openVFS oldVFS n + let newVFS = flip execState oldVFS $ openVFS mempty n modify (\s -> s { vfs = newVFS }) sendMessage n @@ -356,16 +356,16 @@ sendNotification STextDocumentDidClose params = do let n = NotificationMessage "2.0" STextDocumentDidClose params oldVFS <- vfs <$> get - let (newVFS,_) = closeVFS oldVFS n + let newVFS = flip execState oldVFS $ closeVFS mempty n modify (\s -> s { vfs = newVFS }) sendMessage n sendNotification STextDocumentDidChange params = do - let n = NotificationMessage "2.0" STextDocumentDidChange params - oldVFS <- vfs <$> get - let (newVFS,_) = changeFromClientVFS oldVFS n - modify (\s -> s { vfs = newVFS }) - sendMessage n + let n = NotificationMessage "2.0" STextDocumentDidChange params + oldVFS <- vfs <$> get + let newVFS = flip execState oldVFS $ changeFromClientVFS mempty n + modify (\s -> s { vfs = newVFS }) + sendMessage n sendNotification method params = case splitClientMethod method of @@ -594,11 +594,8 @@ -- | Adds the current version to the document, as tracked by the session. getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier getVersionedDoc (TextDocumentIdentifier uri) = do - fs <- vfsMap . vfs <$> get - let ver = - case fs Map.!? toNormalizedUri uri of - Just vf -> Just (virtualFileVersion vf) - _ -> Nothing + vfs <- vfs <$> get + let ver = vfs ^? vfsMap . ix (toNormalizedUri uri) . to virtualFileVersion return (VersionedTextDocumentIdentifier uri ver) -- | Applys an edit to the document and returns the updated document version. @@ -706,7 +703,7 @@ let params = HoverParams doc pos Nothing in getResponseResult <$> request STextDocumentHover params --- | Returns the highlighted occurences of the term at the specified position +-- | Returns the highlighted occurrences of the term at the specified position getHighlights :: TextDocumentIdentifier -> Position -> Session (List DocumentHighlight) getHighlights doc pos = let params = DocumentHighlightParams doc pos Nothing Nothing diff --git a/src/Language/LSP/Test/Exceptions.hs b/src/Language/LSP/Test/Exceptions.hs --- a/src/Language/LSP/Test/Exceptions.hs +++ b/src/Language/LSP/Test/Exceptions.hs @@ -48,7 +48,7 @@ show UnexpectedDiagnostics = "Unexpectedly received diagnostics from the server." show (IncorrectApplyEditRequest msgStr) = "ApplyEditRequest didn't contain document, instead received:\n" ++ msgStr - show (UnexpectedResponseError lid e) = "Received an exepected error in a response for id " ++ show lid ++ ":\n" + show (UnexpectedResponseError lid e) = "Received an expected error in a response for id " ++ show lid ++ ":\n" ++ show e show UnexpectedServerTermination = "Language server unexpectedly terminated" show (IllegalInitSequenceMessage msg) = diff --git a/src/Language/LSP/Test/Session.hs b/src/Language/LSP/Test/Session.hs --- a/src/Language/LSP/Test/Session.hs +++ b/src/Language/LSP/Test/Session.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -46,12 +45,13 @@ #if __GLASGOW_HASKELL__ == 806 import Control.Monad.Fail #endif +import Control.Monad.Trans.Class import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Control.Monad.Trans.Reader as Reader (ask) -import Control.Monad.Trans.State (StateT, runStateT) +import Control.Monad.Trans.State (StateT, runStateT, execState) import qualified Control.Monad.Trans.State as State import qualified Data.ByteString.Lazy.Char8 as B -import Data.Aeson +import Data.Aeson hiding (Error) import Data.Aeson.Encode.Pretty import Data.Conduit as Conduit import Data.Conduit.Parser as Parser @@ -80,8 +80,9 @@ #ifndef mingw32_HOST_OS import System.Process (waitForProcess) #endif -import System.Timeout +import System.Timeout ( timeout ) import Data.IORef +import Colog.Core (LogAction (..), WithSeverity (..), Severity (..)) -- | A session representing one instance of launching and connecting to a server. -- @@ -367,7 +368,7 @@ error "WorkspaceEdit contains neither documentChanges nor changes!" modifyM $ \s -> do - newVFS <- liftIO $ changeFromServerVFS (vfs s) r + let newVFS = flip execState (vfs s) $ changeFromServerVFS logger r return $ s { vfs = newVFS } let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams @@ -384,14 +385,16 @@ modify $ \s -> let oldVFS = vfs s update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver +1) t - newVFS = updateVFS (Map.adjust update (toNormalizedUri uri)) oldVFS + newVFS = oldVFS & vfsMap . ix (toNormalizedUri uri) %~ update in s { vfs = newVFS } - where checkIfNeedsOpened uri = do + where + logger = LogAction $ \(WithSeverity msg sev) -> case sev of { Error -> error $ show msg; _ -> pure () } + checkIfNeedsOpened uri = do oldVFS <- vfs <$> get -- if its not open, open it - unless (toNormalizedUri uri `Map.member` vfsMap oldVFS) $ do + unless (has (vfsMap . ix (toNormalizedUri uri)) oldVFS) $ do let fp = fromJust $ uriToFilePath uri contents <- liftIO $ T.readFile fp let item = TextDocumentItem (filePathToUri fp) "" 0 contents @@ -399,7 +402,7 @@ sendMessage msg modifyM $ \s -> do - let (newVFS,_) = openVFS (vfs s) msg + let newVFS = flip execState (vfs s) $ openVFS logger msg return $ s { vfs = newVFS } getParamsFromTextDocumentEdit :: TextDocumentEdit -> DidChangeTextDocumentParams @@ -420,9 +423,8 @@ -- For a uri returns an infinite list of versions [n,n+1,n+2,...] -- where n is the current version textDocumentVersions uri = do - m <- vfsMap . vfs <$> get - let curVer = fromMaybe 0 $ - _lsp_version <$> m Map.!? (toNormalizedUri uri) + vfs <- vfs <$> get + let curVer = fromMaybe 0 $ vfs ^? vfsMap . ix (toNormalizedUri uri) . lsp_version pure $ map (VersionedTextDocumentIdentifier uri . Just) [curVer + 1..] textDocumentEdits uri edits = do diff --git a/test/DummyServer.hs b/test/DummyServer.hs --- a/test/DummyServer.hs +++ b/test/DummyServer.hs @@ -35,7 +35,7 @@ } bracket - (forkIO $ void $ runServerWithHandles hinRead houtWrite definition) + (forkIO $ void $ runServerWithHandles mempty mempty hinRead houtWrite definition) killThread (const $ f (hinWrite, houtRead)) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -429,7 +429,7 @@ it "full works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do let doc = TextDocumentIdentifier (Uri "") Just toks <- getSemanticTokens doc - liftIO $ toks ^. xdata `shouldBe` List [0,1,2,0,0] + liftIO $ toks ^. xdata `shouldBe` List [0,1,2,1,0] didChangeCaps :: ClientCapabilities didChangeCaps = def { _workspace = Just workspaceCaps }