diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for lsp-test +## 0.15.0.0 + +* Support `lsp-types-2.0.0.0` and `lsp-2.0.0.0`. + ## 0.14.1.0 * Compatibility with new `lsp-types` major version. diff --git a/bench/SimpleBench.hs b/bench/SimpleBench.hs --- a/bench/SimpleBench.hs +++ b/bench/SimpleBench.hs @@ -1,13 +1,16 @@ {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs, OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} module Main where import Language.LSP.Server import qualified Language.LSP.Test as Test -import Language.LSP.Types +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Message import Control.Monad.IO.Class import Control.Monad -import System.Process +import System.Process hiding (env) import System.Environment import System.Time.Extra import Control.Concurrent @@ -15,16 +18,16 @@ handlers :: Handlers (LspM ()) handlers = mconcat - [ requestHandler STextDocumentHover $ \req responder -> do - let RequestMessage _ _ _ (HoverParams _doc pos _workDone) = req + [ requestHandler SMethod_TextDocumentHover $ \req responder -> do + let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req Position _l _c' = pos rsp = Hover ms (Just range) - ms = HoverContents $ markedUpContent "lsp-demo-simple-server" "Hello world" + ms = InL $ mkMarkdown "Hello world" range = Range pos pos - responder (Right $ Just rsp) - , requestHandler STextDocumentDefinition $ \req responder -> do - let RequestMessage _ _ _ (DefinitionParams (TextDocumentIdentifier doc) pos _ _) = req - responder (Right $ InL $ Location doc $ Range pos pos) + responder (Right $ InL rsp) + , requestHandler SMethod_TextDocumentDefinition $ \req responder -> do + let TRequestMessage _ _ _ (DefinitionParams (TextDocumentIdentifier doc) pos _ _) = req + responder (Right $ InL $ Definition $ InL $ Location doc $ Range pos pos) ] server :: ServerDefinition () @@ -44,19 +47,19 @@ n <- read . head <$> getArgs - forkIO $ void $ runServerWithHandles mempty mempty hinRead houtWrite server + _ <- forkIO $ void $ runServerWithHandles mempty mempty hinRead houtWrite server liftIO $ putStrLn $ "Starting " <> show n <> " rounds" - i <- newIORef 0 + i <- newIORef (0 :: Integer) Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do start <- liftIO offsetTime replicateM_ n $ do - n <- liftIO $ readIORef i - liftIO $ when (n `mod` 1000 == 0) $ putStrLn $ show n - ResponseMessage{_result=Right (Just _)} <- Test.request STextDocumentHover $ + v <- liftIO $ readIORef i + liftIO $ when (v `mod` 1000 == 0) $ putStrLn $ show v + TResponseMessage{_result=Right (InL _)} <- Test.request SMethod_TextDocumentHover $ HoverParams (TextDocumentIdentifier $ Uri "test") (Position 1 100) Nothing - ResponseMessage{_result=Right (InL _)} <- Test.request STextDocumentDefinition $ + TResponseMessage{_result=Right (InL _)} <- Test.request SMethod_TextDocumentDefinition $ DefinitionParams (TextDocumentIdentifier $ Uri "test") (Position 1000 100) Nothing Nothing liftIO $ modifyIORef' i (+1) diff --git a/example/Test.hs b/example/Test.hs --- a/example/Test.hs +++ b/example/Test.hs @@ -2,7 +2,8 @@ import Control.Applicative.Combinators import Control.Monad.IO.Class import Language.LSP.Test -import Language.LSP.Types +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Message main = runSession "lsp-demo-reactor-server" fullCaps "test/data/" $ do doc <- openDoc "Rename.hs" "haskell" @@ -11,7 +12,7 @@ skipManyTill loggingNotification (count 1 publishDiagnosticsNotification) -- Send requests and notifications and receive responses - rsp <- request STextDocumentDocumentSymbol $ + rsp <- request SMethod_TextDocumentDocumentSymbol $ DocumentSymbolParams Nothing Nothing doc liftIO $ print rsp diff --git a/func-test/FuncTest.hs b/func-test/FuncTest.hs --- a/func-test/FuncTest.hs +++ b/func-test/FuncTest.hs @@ -4,8 +4,9 @@ import Language.LSP.Server import qualified Language.LSP.Test as Test -import Language.LSP.Types -import Language.LSP.Types.Lens hiding (options) +import Language.LSP.Protocol.Types +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message import Control.Monad.IO.Class import System.IO import Control.Monad @@ -41,7 +42,7 @@ handlers :: MVar () -> Handlers (LspM ()) handlers killVar = - notificationHandler SInitialized $ \noti -> do + notificationHandler SMethod_Initialized $ \noti -> do tid <- withRunInIO $ \runInIO -> forkIO $ runInIO $ withProgress "Doing something" NotCancellable $ \updater -> @@ -55,20 +56,16 @@ Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do -- First make sure that we get a $/progress begin notification skipManyTill Test.anyMessage $ do - x <- Test.message SProgress - let isBegin (Begin _) = True - isBegin _ = False - guard $ isBegin $ x ^. params . value + x <- Test.message SMethod_Progress + guard $ has (L.params . L.value . _workDoneProgressBegin) x -- Then kill the thread liftIO $ putMVar killVar () -- Then make sure we still get a $/progress end notification skipManyTill Test.anyMessage $ do - x <- Test.message SProgress - let isEnd (End _) = True - isEnd _ = False - guard $ isEnd $ x ^. params . value + x <- Test.message SMethod_Progress + guard $ has (L.params . L.value . _workDoneProgressEnd) x describe "workspace folders" $ it "keeps track of open workspace folders" $ do @@ -77,9 +74,9 @@ countVar <- newMVar 0 - let wf0 = WorkspaceFolder "one" "Starter workspace" - wf1 = WorkspaceFolder "/foo/bar" "My workspace" - wf2 = WorkspaceFolder "/foo/baz" "My other workspace" + let wf0 = WorkspaceFolder (filePathToUri "one") "Starter workspace" + wf1 = WorkspaceFolder (filePathToUri "/foo/bar") "My workspace" + wf2 = WorkspaceFolder (filePathToUri "/foo/baz") "My other workspace" definition = ServerDefinition { onConfigurationChange = const $ const $ Right () @@ -92,10 +89,10 @@ handlers :: Handlers (LspM ()) handlers = mconcat - [ notificationHandler SInitialized $ \noti -> do + [ notificationHandler SMethod_Initialized $ \noti -> do wfs <- fromJust <$> getWorkspaceFolders liftIO $ wfs `shouldContain` [wf0] - , notificationHandler SWorkspaceDidChangeWorkspaceFolders $ \noti -> do + , notificationHandler SMethod_WorkspaceDidChangeWorkspaceFolders $ \noti -> do i <- liftIO $ modifyMVar countVar (\i -> pure (i + 1, i)) wfs <- fromJust <$> getWorkspaceFolders liftIO $ case i of @@ -116,11 +113,9 @@ } changeFolders add rmv = - let addedFolders = List add - removedFolders = List rmv - ev = WorkspaceFoldersChangeEvent addedFolders removedFolders + let ev = WorkspaceFoldersChangeEvent add rmv ps = DidChangeWorkspaceFoldersParams ev - in Test.sendNotification SWorkspaceDidChangeWorkspaceFolders ps + in Test.sendNotification SMethod_WorkspaceDidChangeWorkspaceFolders ps Test.runSessionWithHandles hinWrite houtRead config Test.fullCaps "." $ do changeFolders [wf1] [] diff --git a/lsp-test.cabal b/lsp-test.cabal --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -1,7 +1,7 @@ -cabal-version: 2.4 -name: lsp-test -version: 0.14.1.0 -synopsis: Functional test framework for LSP servers. +cabal-version: 2.4 +name: lsp-test +version: 0.15.0.0 +synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against . @@ -10,126 +10,145 @@ To see examples of it in action, check out , and . -homepage: https://github.com/haskell/lsp/blob/master/lsp-test/README.md -license: BSD-3-Clause -license-file: LICENSE -author: Luke Lau -maintainer: luke_lau@icloud.com -bug-reports: https://github.com/haskell/lsp/issues -copyright: 2021 Luke Lau -category: Testing -build-type: Simple -extra-source-files: README.md - , ChangeLog.md - , test/data/**/*.hs -tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1, GHC == 8.10.2 +homepage: + https://github.com/haskell/lsp/blob/master/lsp-test/README.md + +license: BSD-3-Clause +license-file: LICENSE +author: Luke Lau +maintainer: luke_lau@icloud.com +bug-reports: https://github.com/haskell/lsp/issues +copyright: 2021 Luke Lau +category: Testing +build-type: Simple +extra-source-files: + ChangeLog.md + README.md + test/data/**/*.hs + source-repository head type: git location: https://github.com/haskell/lsp library - hs-source-dirs: src - exposed-modules: Language.LSP.Test - reexported-modules: lsp-types:Language.LSP.Types - , lsp-types:Language.LSP.Types.Capabilities - , parser-combinators:Control.Applicative.Combinators - default-language: Haskell2010 - build-depends: base >= 4.10 && < 5 - , lsp-types == 1.5.* || == 1.6.* - , lsp == 1.5.* || == 1.6.* - , aeson - , time - , aeson-pretty - , ansi-terminal - , async >= 2.0 - , bytestring - , co-log-core - , conduit - , conduit-parse == 0.2.* - , containers >= 0.5.9 - , data-default - , Diff >= 0.3 - , directory - , exceptions - , filepath - , Glob >= 0.9 && < 0.11 - , lens - , mtl < 2.4 - , parser-combinators >= 1.2 - , process >= 1.6 - , text - , transformers - , unordered-containers - , some + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: Language.LSP.Test + reexported-modules: + lsp-types:Language.LSP.Protocol.Types + , lsp-types:Language.LSP.Protocol.Message + , lsp-types:Language.LSP.Protocol.Capabilities + , parser-combinators:Control.Applicative.Combinators + + build-depends: + , aeson + , aeson-pretty + , ansi-terminal + , async >=2.0 + , base >=4.10 && <5 + , bytestring + , co-log-core + , conduit + , conduit-parse ^>=0.2 + , containers >=0.5.9 + , data-default + , Diff >=0.3 + , directory + , exceptions + , filepath + , Glob >=0.9 && <0.11 + , lens + , lsp ^>=2.0 + , lsp-types ^>=2.0 + , mtl <2.4 + , parser-combinators >=1.2 + , process >=1.6 + , row-types + , some + , text + , time + , transformers + if os(windows) - build-depends: Win32 + build-depends: Win32 else - build-depends: unix - other-modules: Language.LSP.Test.Compat - Language.LSP.Test.Decoding - Language.LSP.Test.Exceptions - Language.LSP.Test.Files - Language.LSP.Test.Parsing - Language.LSP.Test.Server - Language.LSP.Test.Session - ghc-options: -W + build-depends: unix + other-modules: + Language.LSP.Test.Compat + Language.LSP.Test.Decoding + Language.LSP.Test.Exceptions + Language.LSP.Test.Files + Language.LSP.Test.Parsing + Language.LSP.Test.Server + Language.LSP.Test.Session + + ghc-options: -W + test-suite tests - type: exitcode-stdio-1.0 - main-is: Test.hs - other-modules: DummyServer - hs-source-dirs: test - ghc-options: -W - build-depends: base >= 4.10 && < 5 - , hspec - , lens - , lsp == 1.6.* - , lsp-test - , data-default - , aeson - , unordered-containers - , text - , directory - , filepath - , unliftio - , process - , mtl < 2.4 - , aeson - default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + default-language: Haskell2010 + ghc-options: -W + other-modules: DummyServer + build-depends: + , aeson + , base >=4.10 && <5 + , containers + , data-default + , directory + , filepath + , hspec + , lens + , lsp ^>=2.0 + , lsp-test + , mtl <2.4 + , parser-combinators + , process + , text + , unliftio + test-suite func-test - main-is: FuncTest.hs - hs-source-dirs: func-test - type: exitcode-stdio-1.0 - build-depends: base - , lsp-test - , lsp - , process - , co-log-core - , lens - , unliftio - , hspec - default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: func-test + default-language: Haskell2010 + main-is: FuncTest.hs + build-depends: + , base + , co-log-core + , hspec + , lens + , lsp + , lsp-test + , parser-combinators + , process + , unliftio + test-suite example - main-is: Test.hs - hs-source-dirs: example - type: exitcode-stdio-1.0 - default-language: Haskell2010 - build-depends: base - , lsp-test - , parser-combinators - build-tool-depends: lsp:lsp-demo-reactor-server + type: exitcode-stdio-1.0 + hs-source-dirs: example + default-language: Haskell2010 + main-is: Test.hs + build-depends: + , base + , lsp-test + , parser-combinators + build-tool-depends: lsp:lsp-demo-reactor-server benchmark simple-bench - main-is: SimpleBench.hs - hs-source-dirs: bench - type: exitcode-stdio-1.0 - build-depends: base - , lsp-test - , lsp - , process - , extra - default-language: Haskell2010 - ghc-options: -Wall -O2 -eventlog -rtsopts + type: exitcode-stdio-1.0 + hs-source-dirs: bench + default-language: Haskell2010 + main-is: SimpleBench.hs + ghc-options: -Wall -O2 -eventlog -rtsopts + build-depends: + , base + , extra + , lsp + , lsp-test + , process + 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 @@ -113,16 +113,14 @@ import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.IO as T -import Data.Aeson +import Data.Aeson hiding (Null) import Data.Default -import qualified Data.HashMap.Strict as HashMap import Data.List import Data.Maybe -import Language.LSP.Types -import Language.LSP.Types.Lens hiding - (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.Protocol.Types +import Language.LSP.Protocol.Message +import qualified Language.LSP.Protocol.Lens as L +import qualified Language.LSP.Protocol.Capabilities as C import Language.LSP.VFS import Language.LSP.Test.Compat import Language.LSP.Test.Decoding @@ -147,7 +145,7 @@ -- > params = TextDocumentPositionParams doc -- > hover <- request STextdocumentHover params runSession :: String -- ^ The command to run the server. - -> C.ClientCapabilities -- ^ The capabilities that the client should declare. + -> ClientCapabilities -- ^ The capabilities that the client should declare. -> FilePath -- ^ The filepath to the root directory for the session. -> Session a -- ^ The session to run. -> IO a @@ -156,7 +154,7 @@ -- | 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. + -> ClientCapabilities -- ^ The capabilities that the client should declare. -> FilePath -- ^ The filepath to the root directory for the session. -> Session a -- ^ The session to run. -> IO a @@ -166,7 +164,7 @@ runSessionWithConfigCustomProcess :: (CreateProcess -> CreateProcess) -- ^ Tweak the 'CreateProcess' used to start the server. -> SessionConfig -- ^ Configuration options for the session. -> String -- ^ The command to run the server. - -> C.ClientCapabilities -- ^ The capabilities that the client should declare. + -> ClientCapabilities -- ^ The capabilities that the client should declare. -> FilePath -- ^ The filepath to the root directory for the session. -> Session a -- ^ The session to run. -> IO a @@ -188,7 +186,7 @@ runSessionWithHandles :: Handle -- ^ The input handle -> Handle -- ^ The output handle -> SessionConfig - -> C.ClientCapabilities -- ^ The capabilities that the client should declare. + -> ClientCapabilities -- ^ The capabilities that the client should declare. -> FilePath -- ^ The filepath to the root directory for the session. -> Session a -- ^ The session to run. -> IO a @@ -199,7 +197,7 @@ -> Handle -- ^ The input handle -> Handle -- ^ The output handle -> SessionConfig - -> C.ClientCapabilities -- ^ The capabilities that the client should declare. + -> ClientCapabilities -- ^ The capabilities that the client should declare. -> FilePath -- ^ The filepath to the root directory for the session. -> Session a -- ^ The session to run. -> IO a @@ -212,32 +210,33 @@ let initializeParams = InitializeParams Nothing -- Narrowing to Int32 here, but it's unlikely that a PID will -- be outside the range - (Just $ fromIntegral pid) + (InL $ fromIntegral pid) (Just lspTestClientInfo) (Just $ T.pack absRootDir) - (Just $ filePathToUri absRootDir) - (lspConfig config') + Nothing + (InL $ filePathToUri absRootDir) caps - (Just TraceOff) - (List <$> initialWorkspaceFolders config) + (lspConfig config') + (Just TraceValues_Off) + (fmap InL $ initialWorkspaceFolders config) runSession' serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do -- Wrap the session around initialize and shutdown calls - initReqId <- sendRequest SInitialize initializeParams + initReqId <- sendRequest SMethod_Initialize initializeParams -- Because messages can be sent in between the request and response, -- collect them and then... - (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId SInitialize initReqId) + (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId SMethod_Initialize initReqId) - case initRspMsg ^. LSP.result of + case initRspMsg ^. L.result of Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error) Right _ -> pure () initRspVar <- initRsp <$> ask liftIO $ putMVar initRspVar initRspMsg - sendNotification SInitialized (Just InitializedParams) + sendNotification SMethod_Initialized InitializedParams case lspConfig config of - Just cfg -> sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg) + Just cfg -> sendNotification SMethod_WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg) Nothing -> return () -- ... relay them back to the user Session so they can match on them! @@ -251,7 +250,7 @@ where -- | Asks the server to shutdown and exit politely exitServer :: Session () - exitServer = request_ SShutdown Empty >> sendNotification SExit Empty + exitServer = request_ SMethod_Shutdown Nothing >> sendNotification SMethod_Exit Nothing -- | Listens to the server output until the shutdown ACK, -- makes sure it matches the record and signals any semaphores @@ -264,17 +263,17 @@ writeChan (messageChan context) (ServerMessage msg) case msg of - (FromServerRsp SShutdown _) -> return () + (FromServerRsp SMethod_Shutdown _) -> return () _ -> listenServer serverOut context -- | Is this message allowed to be sent by the server between the intialize -- request and response? -- https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#initialize checkLegalBetweenMessage :: FromServerMessage -> Session () - checkLegalBetweenMessage (FromServerMess SWindowShowMessage _) = pure () - checkLegalBetweenMessage (FromServerMess SWindowLogMessage _) = pure () - checkLegalBetweenMessage (FromServerMess STelemetryEvent _) = pure () - checkLegalBetweenMessage (FromServerMess SWindowShowMessageRequest _) = pure () + checkLegalBetweenMessage (FromServerMess SMethod_WindowShowMessage _) = pure () + checkLegalBetweenMessage (FromServerMess SMethod_WindowLogMessage _) = pure () + checkLegalBetweenMessage (FromServerMess SMethod_TelemetryEvent _) = pure () + checkLegalBetweenMessage (FromServerMess SMethod_WindowShowMessageRequest _) = pure () checkLegalBetweenMessage msg = throw (IllegalInitSequenceMessage msg) -- | Check environment variables to override the config @@ -292,14 +291,14 @@ documentContents :: TextDocumentIdentifier -> Session T.Text documentContents doc = do vfs <- vfs <$> get - let Just file = vfs ^. vfsMap . at (toNormalizedUri (doc ^. uri)) + let Just file = vfs ^. vfsMap . at (toNormalizedUri (doc ^. L.uri)) return (virtualFileText file) -- | Parses an ApplyEditRequest, checks that it is for the passed document -- and returns the new content getDocumentEdit :: TextDocumentIdentifier -> Session T.Text getDocumentEdit doc = do - req <- message SWorkspaceApplyEdit + req <- message SMethod_WorkspaceApplyEdit unless (checkDocumentChanges req || checkChanges req) $ liftIO $ throw (IncorrectApplyEditRequest (show req)) @@ -307,14 +306,14 @@ documentContents doc where checkDocumentChanges req = - let changes = req ^. params . edit . documentChanges + let changes = req ^. L.params . L.edit . L.documentChanges maybeDocs = fmap (fmap documentChangeUri) changes in case maybeDocs of - Just docs -> (doc ^. uri) `elem` docs + Just docs -> (doc ^. L.uri) `elem` docs Nothing -> False checkChanges req = - let mMap = req ^. params . edit . changes - in maybe False (HashMap.member (doc ^. uri)) mMap + let mMap = req ^. L.params . L.edit . L.changes + in maybe False (Map.member (doc ^. L.uri)) mMap -- | Sends a request to the server and waits for its response. -- Will skip any messages in between the request and the response @@ -322,11 +321,11 @@ -- rsp <- request STextDocumentDocumentSymbol params -- @ -- Note: will skip any messages in between the request and the response. -request :: SClientMethod m -> MessageParams m -> Session (ResponseMessage m) +request :: SClientMethod m -> MessageParams m -> Session (TResponseMessage m) request m = sendRequest m >=> skipManyTill anyMessage . responseForId m -- | The same as 'sendRequest', but discard the response. -request_ :: SClientMethod (m :: Method FromClient Request) -> MessageParams m -> Session () +request_ :: SClientMethod (m :: Method ClientToServer Request) -> MessageParams m -> Session () request_ p = void . request p -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response. @@ -339,7 +338,7 @@ modify $ \c -> c { curReqId = idn+1 } let id = IdInt idn - let mess = RequestMessage "2.0" id method params + let mess = TRequestMessage "2.0" id method params -- Update the request map reqMap <- requestMap <$> ask @@ -353,27 +352,27 @@ return id -- | Sends a notification to the server. -sendNotification :: SClientMethod (m :: Method FromClient Notification) -- ^ The notification method. +sendNotification :: SClientMethod (m :: Method ClientToServer Notification) -- ^ The notification method. -> MessageParams m -- ^ The notification parameters. -> Session () -- Open a virtual file if we send a did open text document notification -sendNotification STextDocumentDidOpen params = do - let n = NotificationMessage "2.0" STextDocumentDidOpen params +sendNotification SMethod_TextDocumentDidOpen params = do + let n = TNotificationMessage "2.0" SMethod_TextDocumentDidOpen params oldVFS <- vfs <$> get let newVFS = flip execState oldVFS $ openVFS mempty n modify (\s -> s { vfs = newVFS }) sendMessage n -- Close a virtual file if we send a close text document notification -sendNotification STextDocumentDidClose params = do - let n = NotificationMessage "2.0" STextDocumentDidClose params +sendNotification SMethod_TextDocumentDidClose params = do + let n = TNotificationMessage "2.0" SMethod_TextDocumentDidClose params oldVFS <- vfs <$> get 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 +sendNotification SMethod_TextDocumentDidChange params = do + let n = TNotificationMessage "2.0" SMethod_TextDocumentDidChange params oldVFS <- vfs <$> get let newVFS = flip execState oldVFS $ changeFromClientVFS mempty n modify (\s -> s { vfs = newVFS }) @@ -381,17 +380,17 @@ sendNotification method params = case splitClientMethod method of - IsClientNot -> sendMessage (NotificationMessage "2.0" method params) - IsClientEither -> sendMessage (NotMess $ NotificationMessage "2.0" method params) + IsClientNot -> sendMessage (TNotificationMessage "2.0" method params) + IsClientEither -> sendMessage (NotMess $ TNotificationMessage "2.0" method params) -- | Sends a response to the server. -sendResponse :: ToJSON (ResponseResult m) => ResponseMessage m -> Session () +sendResponse :: (ToJSON (MessageResult m), ToJSON (ErrorData m)) => TResponseMessage m -> Session () sendResponse = sendMessage -- | Returns the initialize response that was received from the server. -- The initialize requests and responses are not included the session, -- so if you need to test it use this. -initializeResponse :: Session (ResponseMessage Initialize) +initializeResponse :: Session (TResponseMessage Method_Initialize) initializeResponse = ask >>= (liftIO . readMVar) . initRsp -- | /Creates/ a new text document. This is different from 'openDoc' @@ -412,14 +411,16 @@ rootDir <- asks rootDir caps <- asks sessionCapabilities absFile <- liftIO $ canonicalizePath (rootDir file) - let pred :: SomeRegistration -> [Registration WorkspaceDidChangeWatchedFiles] - pred (SomeRegistration r@(Registration _ SWorkspaceDidChangeWatchedFiles _)) = [r] + let pred :: SomeRegistration -> [TRegistration Method_WorkspaceDidChangeWatchedFiles] + pred (SomeRegistration r@(TRegistration _ SMethod_WorkspaceDidChangeWatchedFiles _)) = [r] pred _ = mempty regs = concatMap pred $ Map.elems dynCaps watchHits :: FileSystemWatcher -> Bool - watchHits (FileSystemWatcher pattern kind) = + watchHits (FileSystemWatcher (GlobPattern (InL (Pattern pattern))) kind) = -- If WatchKind is excluded, defaults to all true as per spec - fileMatches (T.unpack pattern) && createHits (fromMaybe (WatchKind True True True) kind) + fileMatches (T.unpack pattern) && containsCreate (fromMaybe WatchKind_Create kind) + -- TODO: Relative patterns + watchHits _ = False fileMatches pattern = Glob.match (Glob.compile pattern) relOrAbs -- If the pattern is absolute then match against the absolute fp @@ -427,19 +428,17 @@ | isAbsolute pattern = absFile | otherwise = file - createHits (WatchKind create _ _) = create - - regHits :: Registration WorkspaceDidChangeWatchedFiles -> Bool - regHits reg = foldl' (\acc w -> acc || watchHits w) False (reg ^. registerOptions . watchers) + regHits :: TRegistration Method_WorkspaceDidChangeWatchedFiles -> Bool + regHits reg = foldl' (\acc w -> acc || watchHits w) False (reg ^. L.registerOptions . _Just . L.watchers) clientCapsSupports = - caps ^? workspace . _Just . didChangeWatchedFiles . _Just . dynamicRegistration . _Just + caps ^? L.workspace . _Just . L.didChangeWatchedFiles . _Just . L.dynamicRegistration . _Just == Just True shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs when shouldSend $ - sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ - List [ FileEvent (filePathToUri (rootDir file)) FcCreated ] + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + [ FileEvent (filePathToUri (rootDir file)) FileChangeType_Created ] openDoc' file languageId contents -- | Opens a text document that /exists on disk/, and sends a @@ -459,21 +458,21 @@ let fp = rootDir context file uri = filePathToUri fp item = TextDocumentItem uri languageId 0 contents - sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams item) + sendNotification SMethod_TextDocumentDidOpen (DidOpenTextDocumentParams item) pure $ TextDocumentIdentifier uri -- | Closes a text document and sends a textDocument/didOpen notification to the server. closeDoc :: TextDocumentIdentifier -> Session () closeDoc docId = do - let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri)) - sendNotification STextDocumentDidClose params + let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. L.uri)) + sendNotification SMethod_TextDocumentDidClose params -- | Changes a text document and sends a textDocument/didOpen notification to the server. changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session () changeDoc docId changes = do verDoc <- getVersionedDoc docId - let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes) - sendNotification STextDocumentDidChange params + let params = DidChangeTextDocumentParams (verDoc & L.version +~ 1) changes + sendNotification SMethod_TextDocumentDidChange params -- | Gets the Uri for the file corrected to the session directory. getDocUri :: FilePath -> Session Uri @@ -485,8 +484,8 @@ -- | Waits for diagnostics to be published and returns them. waitForDiagnostics :: Session [Diagnostic] waitForDiagnostics = do - diagsNot <- skipManyTill anyMessage (message STextDocumentPublishDiagnostics) - let (List diags) = diagsNot ^. params . LSP.diagnostics + diagsNot <- skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics) + let diags = diagsNot ^. L.params . L.diagnostics return diags -- | The same as 'waitForDiagnostics', but will only match a specific @@ -500,34 +499,36 @@ else return res where matches :: Diagnostic -> Bool - matches d = d ^. source == Just (T.pack src) + matches d = d ^. L.source == Just (T.pack src) -- | Expects a 'PublishDiagnosticsNotification' and throws an -- 'UnexpectedDiagnostics' exception if there are any diagnostics -- returned. noDiagnostics :: Session () noDiagnostics = do - diagsNot <- message STextDocumentPublishDiagnostics - when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics + diagsNot <- message SMethod_TextDocumentPublishDiagnostics + when (diagsNot ^. L.params . L.diagnostics /= []) $ liftIO $ throw UnexpectedDiagnostics -- | Returns the symbols in a document. -getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation]) +getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [SymbolInformation] [DocumentSymbol]) getDocumentSymbols doc = do - ResponseMessage _ rspLid res <- request STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) + TResponseMessage _ rspLid res <- request SMethod_TextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) case res of - Right (InL (List xs)) -> return (Left xs) - Right (InR (List xs)) -> return (Right xs) + Right (InL xs) -> return (Left xs) + Right (InR (InL xs)) -> return (Right xs) + Right (InR (InR _)) -> return (Right []) Left err -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) err) -- | Returns the code actions in the specified range. getCodeActions :: TextDocumentIdentifier -> Range -> Session [Command |? CodeAction] getCodeActions doc range = do ctx <- getCodeActionContextInRange doc range - rsp <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc range ctx) + rsp <- request SMethod_TextDocumentCodeAction (CodeActionParams Nothing Nothing doc range ctx) - case rsp ^. result of - Right (List xs) -> return xs - Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) error) + case rsp ^. L.result of + Right (InL xs) -> return xs + Right (InR _) -> return [] + Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error) -- | Returns all the code actions in a document by -- querying the code actions at each of the current @@ -541,11 +542,12 @@ where go :: CodeActionContext -> [Command |? CodeAction] -> Diagnostic -> Session [Command |? CodeAction] go ctx acc diag = do - ResponseMessage _ rspLid res <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. range) ctx) + TResponseMessage _ rspLid res <- request SMethod_TextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. L.range) ctx) case res of Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e) - Right (List cmdOrCAs) -> pure (acc ++ cmdOrCAs) + Right (InL cmdOrCAs) -> pure (acc ++ cmdOrCAs) + Right (InR _) -> pure acc getCodeActionContextInRange :: TextDocumentIdentifier -> Range -> Session CodeActionContext getCodeActionContextInRange doc caRange = do @@ -553,7 +555,7 @@ let diags = [ d | d@Diagnostic{_range=range} <- curDiags , overlappingRange caRange range ] - return $ CodeActionContext (List diags) Nothing + return $ CodeActionContext diags Nothing Nothing where overlappingRange :: Range -> Range -> Bool overlappingRange (Range s e) range = @@ -570,12 +572,12 @@ getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext getCodeActionContext doc = do curDiags <- getCurrentDiagnostics doc - return $ CodeActionContext (List curDiags) Nothing + return $ CodeActionContext curDiags Nothing Nothing -- | Returns the current diagnostics that have been sent to the client. -- Note that this does not wait for more to come in. getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic] -getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get +getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. L.uri) . curDiagnostics <$> get -- | Returns the tokens of all progress sessions that have started but not yet ended. getIncompleteProgressSessions :: Session (Set.Set ProgressToken) @@ -584,9 +586,9 @@ -- | Executes a command. executeCommand :: Command -> Session () executeCommand cmd = do - let args = decode $ encode $ fromJust $ cmd ^. arguments - execParams = ExecuteCommandParams Nothing (cmd ^. command) args - void $ sendRequest SWorkspaceExecuteCommand execParams + let args = decode $ encode $ fromJust $ cmd ^. L.arguments + execParams = ExecuteCommandParams Nothing (cmd ^. L.command) args + void $ sendRequest SMethod_WorkspaceExecuteCommand execParams -- | Executes a code action. -- Matching with the specification, if a code action @@ -594,21 +596,23 @@ -- be applied first. executeCodeAction :: CodeAction -> Session () executeCodeAction action = do - maybe (return ()) handleEdit $ action ^. edit - maybe (return ()) executeCommand $ action ^. command + maybe (return ()) handleEdit $ action ^. L.edit + maybe (return ()) executeCommand $ action ^. L.command where handleEdit :: WorkspaceEdit -> Session () handleEdit e = -- Its ok to pass in dummy parameters here as they aren't used - let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e) - in updateState (FromServerMess SWorkspaceApplyEdit req) + let req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e) + in updateState (FromServerMess SMethod_WorkspaceApplyEdit req) -- | Adds the current version to the document, as tracked by the session. getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier getVersionedDoc (TextDocumentIdentifier uri) = do vfs <- vfs <$> get let ver = vfs ^? vfsMap . ix (toNormalizedUri uri) . to virtualFileVersion - return (VersionedTextDocumentIdentifier uri ver) + -- TODO: is this correct? Could return an OptionalVersionedTextDocumentIdentifier, + -- but that complicated callers... + return (VersionedTextDocumentIdentifier uri (fromMaybe 0 ver)) -- | Applys an edit to the document and returns the updated document version. applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier @@ -618,22 +622,18 @@ caps <- asks sessionCapabilities - let supportsDocChanges = fromMaybe False $ do - let mWorkspace = caps ^. LSP.workspace - C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ _ <- mWorkspace - C.WorkspaceEditClientCapabilities mDocChanges _ _ _ _ <- mEdit - mDocChanges + let supportsDocChanges = fromMaybe False $ caps ^? L.workspace . _Just . L.workspaceEdit . _Just . L.documentChanges . _Just let wEdit = if supportsDocChanges then - let docEdit = TextDocumentEdit verDoc (List [InL edit]) - in WorkspaceEdit Nothing (Just (List [InL docEdit])) Nothing + let docEdit = TextDocumentEdit (review _versionedTextDocumentIdentifier verDoc) [InL edit] + in WorkspaceEdit Nothing (Just [InL docEdit]) Nothing else - let changes = HashMap.singleton (doc ^. uri) (List [edit]) + let changes = Map.singleton (doc ^. L.uri) [edit] in WorkspaceEdit (Just changes) Nothing Nothing - let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) - updateState (FromServerMess SWorkspaceApplyEdit req) + let req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) + updateState (FromServerMess SMethod_WorkspaceApplyEdit req) -- version may have changed getVersionedDoc doc @@ -641,146 +641,139 @@ -- | Returns the completions for the position in the document. getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem] getCompletions doc pos = do - rsp <- request STextDocumentCompletion (CompletionParams doc pos Nothing Nothing Nothing) + rsp <- request SMethod_TextDocumentCompletion (CompletionParams doc pos Nothing Nothing Nothing) case getResponseResult rsp of - InL (List items) -> return items - InR (CompletionList _ (List items)) -> return items + InL items -> return items + InR (InL c) -> return $ c ^. L.items + InR (InR _) -> return [] -- | Returns the references for the position in the document. getReferences :: TextDocumentIdentifier -- ^ The document to lookup in. -> Position -- ^ The position to lookup. -> Bool -- ^ Whether to include declarations as references. - -> Session (List Location) -- ^ The locations of the references. + -> Session [Location] -- ^ The locations of the references. getReferences doc pos inclDecl = let ctx = ReferenceContext inclDecl params = ReferenceParams doc pos Nothing Nothing ctx - in getResponseResult <$> request STextDocumentReferences params + in absorbNull . getResponseResult <$> request SMethod_TextDocumentReferences params -- | Returns the declarations(s) for the term at the specified position. getDeclarations :: TextDocumentIdentifier -- ^ The document the term is in. -> Position -- ^ The position the term is at. - -> Session ([Location] |? [LocationLink]) -getDeclarations = getDeclarationyRequest STextDocumentDeclaration DeclarationParams + -> Session (Declaration |? [DeclarationLink] |? Null) +getDeclarations doc pos = do + rsp <- request SMethod_TextDocumentDeclaration (DeclarationParams doc pos Nothing Nothing) + pure $ getResponseResult rsp -- | Returns the definition(s) for the term at the specified position. getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in. -> Position -- ^ The position the term is at. - -> Session ([Location] |? [LocationLink]) -getDefinitions = getDeclarationyRequest STextDocumentDefinition DefinitionParams + -> Session (Definition |? [DefinitionLink] |? Null) +getDefinitions doc pos = do + rsp <- request SMethod_TextDocumentDefinition (DefinitionParams doc pos Nothing Nothing) + pure $ getResponseResult rsp -- | Returns the type definition(s) for the term at the specified position. getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in. -> Position -- ^ The position the term is at. - -> Session ([Location] |? [LocationLink]) -getTypeDefinitions = getDeclarationyRequest STextDocumentTypeDefinition TypeDefinitionParams + -> Session (Definition |? [DefinitionLink] |? Null) +getTypeDefinitions doc pos = do + rsp <- request SMethod_TextDocumentTypeDefinition (TypeDefinitionParams doc pos Nothing Nothing) + pure $ getResponseResult rsp -- | Returns the type definition(s) for the term at the specified position. getImplementations :: TextDocumentIdentifier -- ^ The document the term is in. -> Position -- ^ The position the term is at. - -> Session ([Location] |? [LocationLink]) -getImplementations = getDeclarationyRequest STextDocumentImplementation ImplementationParams - - -getDeclarationyRequest :: (ResponseResult m ~ (Location |? (List Location |? List LocationLink))) - => SClientMethod m - -> (TextDocumentIdentifier - -> Position - -> Maybe ProgressToken - -> Maybe ProgressToken - -> MessageParams m) - -> TextDocumentIdentifier - -> Position - -> Session ([Location] |? [LocationLink]) -getDeclarationyRequest method paramCons doc pos = do - let params = paramCons doc pos Nothing Nothing - rsp <- request method params - case getResponseResult rsp of - InL loc -> pure (InL [loc]) - InR (InL (List locs)) -> pure (InL locs) - InR (InR (List locLinks)) -> pure (InR locLinks) + -> Session (Definition |? [DefinitionLink] |? Null) +getImplementations doc pos = do + rsp <- request SMethod_TextDocumentImplementation (ImplementationParams doc pos Nothing Nothing) + pure $ getResponseResult rsp -- | Renames the term at the specified position. rename :: TextDocumentIdentifier -> Position -> String -> Session () rename doc pos newName = do - let params = RenameParams doc pos Nothing (T.pack newName) - rsp <- request STextDocumentRename params + let params = RenameParams Nothing doc pos (T.pack newName) + rsp <- request SMethod_TextDocumentRename params let wEdit = getResponseResult rsp - req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) - updateState (FromServerMess SWorkspaceApplyEdit req) + case nullToMaybe wEdit of + Just e -> do + let req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e) + updateState (FromServerMess SMethod_WorkspaceApplyEdit req) + Nothing -> pure () -- | Returns the hover information at the specified position. getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover) getHover doc pos = let params = HoverParams doc pos Nothing - in getResponseResult <$> request STextDocumentHover params + in nullToMaybe . getResponseResult <$> request SMethod_TextDocumentHover params -- | Returns the highlighted occurrences of the term at the specified position -getHighlights :: TextDocumentIdentifier -> Position -> Session (List DocumentHighlight) +getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight] getHighlights doc pos = let params = DocumentHighlightParams doc pos Nothing Nothing - in getResponseResult <$> request STextDocumentDocumentHighlight params + in absorbNull . getResponseResult <$> request SMethod_TextDocumentDocumentHighlight params -- | Checks the response for errors and throws an exception if needed. -- Returns the result if successful. -getResponseResult :: ResponseMessage m -> ResponseResult m +getResponseResult :: (ToJSON (ErrorData m)) => TResponseMessage m -> MessageResult m getResponseResult rsp = - case rsp ^. result of + case rsp ^. L.result of Right x -> x - Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) err + Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) err -- | Applies formatting to the specified document. formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session () formatDoc doc opts = do let params = DocumentFormattingParams Nothing doc opts - edits <- getResponseResult <$> request STextDocumentFormatting params + edits <- absorbNull . getResponseResult <$> request SMethod_TextDocumentFormatting params applyTextEdits doc edits -- | Applies formatting to the specified range in a document. formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session () formatRange doc opts range = do let params = DocumentRangeFormattingParams Nothing doc range opts - edits <- getResponseResult <$> request STextDocumentRangeFormatting params + edits <- absorbNull . getResponseResult <$> request SMethod_TextDocumentRangeFormatting params applyTextEdits doc edits -applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session () +applyTextEdits :: TextDocumentIdentifier -> [TextEdit] -> Session () applyTextEdits doc edits = - let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing Nothing + let wEdit = WorkspaceEdit (Just (Map.singleton (doc ^. L.uri) edits)) Nothing Nothing -- Send a dummy message to updateState so it can do bookkeeping - req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) - in updateState (FromServerMess SWorkspaceApplyEdit req) + req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) + in updateState (FromServerMess SMethod_WorkspaceApplyEdit req) -- | Returns the code lenses for the specified document. getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] getCodeLenses tId = do - rsp <- request STextDocumentCodeLens (CodeLensParams Nothing Nothing tId) - case getResponseResult rsp of - List res -> pure res + rsp <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing tId) + pure $ absorbNull $ getResponseResult rsp -- | Pass a param and return the response from `prepareCallHierarchy` prepareCallHierarchy :: CallHierarchyPrepareParams -> Session [CallHierarchyItem] -prepareCallHierarchy = resolveRequestWithListResp STextDocumentPrepareCallHierarchy +prepareCallHierarchy = resolveRequestWithListResp SMethod_TextDocumentPrepareCallHierarchy incomingCalls :: CallHierarchyIncomingCallsParams -> Session [CallHierarchyIncomingCall] -incomingCalls = resolveRequestWithListResp SCallHierarchyIncomingCalls +incomingCalls = resolveRequestWithListResp SMethod_CallHierarchyIncomingCalls outgoingCalls :: CallHierarchyOutgoingCallsParams -> Session [CallHierarchyOutgoingCall] -outgoingCalls = resolveRequestWithListResp SCallHierarchyOutgoingCalls +outgoingCalls = resolveRequestWithListResp SMethod_CallHierarchyOutgoingCalls -- | Send a request and receive a response with list. -resolveRequestWithListResp :: (ResponseResult m ~ Maybe (List a)) - => SClientMethod m -> MessageParams m -> Session [a] +resolveRequestWithListResp :: forall (m :: Method ClientToServer Request) a + . (ToJSON (ErrorData m), MessageResult m ~ ([a] |? Null)) + => SMethod m + -> MessageParams m + -> Session [a] resolveRequestWithListResp method params = do rsp <- request method params - case getResponseResult rsp of - Nothing -> pure [] - Just (List x) -> pure x + pure $ absorbNull $ getResponseResult rsp -- | Pass a param and return the response from `prepareCallHierarchy` -getSemanticTokens :: TextDocumentIdentifier -> Session (Maybe SemanticTokens) +getSemanticTokens :: TextDocumentIdentifier -> Session (SemanticTokens |? Null) getSemanticTokens doc = do let params = SemanticTokensParams Nothing Nothing doc - rsp <- request STextDocumentSemanticTokensFull params + rsp <- request SMethod_TextDocumentSemanticTokensFull params pure $ getResponseResult rsp -- | Returns a list of capabilities that the server has requested to /dynamically/ diff --git a/src/Language/LSP/Test/Compat.hs b/src/Language/LSP/Test/Compat.hs --- a/src/Language/LSP/Test/Compat.hs +++ b/src/Language/LSP/Test/Compat.hs @@ -1,13 +1,18 @@ -{-# LANGUAGE CPP, OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} -- For some reason ghc warns about not using -- Control.Monad.IO.Class but it's needed for -- MonadIO {-# OPTIONS_GHC -Wunused-imports #-} module Language.LSP.Test.Compat where +import Data.Row import Data.Maybe +import qualified Data.Text as T import System.IO -import Language.LSP.Types #if MIN_VERSION_process(1,6,3) -- We have to hide cleanupProcess for process-1.6.3.0 @@ -115,6 +120,5 @@ #endif - -lspTestClientInfo :: ClientInfo -lspTestClientInfo = ClientInfo "lsp-test" (Just CURRENT_PACKAGE_VERSION) +lspTestClientInfo :: Rec ("name" .== T.Text .+ "version" .== Maybe T.Text) +lspTestClientInfo = #name .== "lsp-test" .+ #version .== (Just CURRENT_PACKAGE_VERSION) diff --git a/src/Language/LSP/Test/Decoding.hs b/src/Language/LSP/Test/Decoding.hs --- a/src/Language/LSP/Test/Decoding.hs +++ b/src/Language/LSP/Test/Decoding.hs @@ -1,7 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeInType #-} module Language.LSP.Test.Decoding where @@ -17,8 +15,8 @@ import Data.Maybe import System.IO import System.IO.Error -import Language.LSP.Types -import Language.LSP.Types.Lens +import Language.LSP.Protocol.Message +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Test.Exceptions import Data.IxMap @@ -51,7 +49,7 @@ | isEOFError e = throw UnexpectedServerTermination | otherwise = throw e -type RequestMap = IxMap LspId (SMethod :: Method FromClient Request -> Type ) +type RequestMap = IxMap LspId (SMethod :: Method ClientToServer Request -> Type ) newRequestMap :: RequestMap newRequestMap = emptyIxMap @@ -66,10 +64,10 @@ helper acc msg = case msg of FromClientMess m mess -> case splitClientMethod m of IsClientNot -> acc - IsClientReq -> fromJust $ updateRequestMap acc (mess ^. id) m + IsClientReq -> fromJust $ updateRequestMap acc (mess ^. L.id) m IsClientEither -> case mess of NotMess _ -> acc - ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. id) m + ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. L.id) m _ -> acc decodeFromServerMsg :: RequestMap -> B.ByteString -> (RequestMap, FromServerMessage) 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 @@ -1,7 +1,7 @@ module Language.LSP.Test.Exceptions where import Control.Exception -import Language.LSP.Types +import Language.LSP.Protocol.Message import Data.Aeson import Data.Aeson.Encode.Pretty import Data.Algorithm.Diff @@ -16,7 +16,7 @@ | ReplayOutOfOrder FromServerMessage [FromServerMessage] | UnexpectedDiagnostics | IncorrectApplyEditRequest String - | UnexpectedResponseError SomeLspId ResponseError + | UnexpectedResponseError SomeLspId ResponseError | UnexpectedServerTermination | IllegalInitSequenceMessage FromServerMessage | MessageSendError Value IOError diff --git a/src/Language/LSP/Test/Files.hs b/src/Language/LSP/Test/Files.hs --- a/src/Language/LSP/Test/Files.hs +++ b/src/Language/LSP/Test/Files.hs @@ -10,10 +10,11 @@ ) where -import Language.LSP.Types -import Language.LSP.Types.Lens hiding (id) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import qualified Language.LSP.Protocol.Lens as L import Control.Lens -import qualified Data.HashMap.Strict as HM +import qualified Data.Map.Strict as M import qualified Data.Text as T import Data.Maybe import System.Directory @@ -38,9 +39,11 @@ return newMsgs rootDir :: [Event] -> FilePath -rootDir (ClientEv _ (FromClientMess SInitialize req):_) = +rootDir (ClientEv _ (FromClientMess SMethod_Initialize req):_) = fromMaybe (error "Couldn't find root dir") $ do - rootUri <- req ^. params .rootUri + rootUri <- case req ^. L.params . L.rootUri of + InL r -> Just r + InR _ -> error "Couldn't find root dir" uriToFilePath rootUri rootDir _ = error "Couldn't find initialize request in session" @@ -52,54 +55,55 @@ where --TODO: Handle all other URIs that might need swapped - fromClientMsg (FromClientMess m@SInitialize r) = FromClientMess m $ params .~ transformInit (r ^. params) $ r - fromClientMsg (FromClientMess m@STextDocumentDidOpen n) = FromClientMess m $ swapUri (params . textDocument) n - fromClientMsg (FromClientMess m@STextDocumentDidChange n) = FromClientMess m $ swapUri (params . textDocument) n - fromClientMsg (FromClientMess m@STextDocumentWillSave n) = FromClientMess m $ swapUri (params . textDocument) n - fromClientMsg (FromClientMess m@STextDocumentDidSave n) = FromClientMess m $ swapUri (params . textDocument) n - fromClientMsg (FromClientMess m@STextDocumentDidClose n) = FromClientMess m $ swapUri (params . textDocument) n - fromClientMsg (FromClientMess m@STextDocumentDocumentSymbol n) = FromClientMess m $ swapUri (params . textDocument) n - fromClientMsg (FromClientMess m@STextDocumentRename n) = FromClientMess m $ swapUri (params . textDocument) n + fromClientMsg (FromClientMess m@SMethod_Initialize r) = FromClientMess m $ L.params .~ transformInit (r ^. L.params) $ r + fromClientMsg (FromClientMess m@SMethod_TextDocumentDidOpen n) = FromClientMess m $ swapUri (L.params . L.textDocument) n + fromClientMsg (FromClientMess m@SMethod_TextDocumentDidChange n) = FromClientMess m $ swapUri (L.params . L.textDocument) n + fromClientMsg (FromClientMess m@SMethod_TextDocumentWillSave n) = FromClientMess m $ swapUri (L.params . L.textDocument) n + fromClientMsg (FromClientMess m@SMethod_TextDocumentDidSave n) = FromClientMess m $ swapUri (L.params . L.textDocument) n + fromClientMsg (FromClientMess m@SMethod_TextDocumentDidClose n) = FromClientMess m $ swapUri (L.params . L.textDocument) n + fromClientMsg (FromClientMess m@SMethod_TextDocumentDocumentSymbol n) = FromClientMess m $ swapUri (L.params . L.textDocument) n + fromClientMsg (FromClientMess m@SMethod_TextDocumentRename n) = FromClientMess m $ swapUri (L.params . L.textDocument) n fromClientMsg x = x fromServerMsg :: FromServerMessage -> FromServerMessage - fromServerMsg (FromServerMess m@SWorkspaceApplyEdit r) = FromServerMess m $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r - fromServerMsg (FromServerMess m@STextDocumentPublishDiagnostics n) = FromServerMess m $ swapUri params n - fromServerMsg (FromServerRsp m@STextDocumentDocumentSymbol r) = - let swapUri' :: (List DocumentSymbol |? List SymbolInformation) -> List DocumentSymbol |? List SymbolInformation - swapUri' (InR si) = InR (swapUri location <$> si) - swapUri' (InL dss) = InL dss -- no file locations here - in FromServerRsp m $ r & result %~ (fmap swapUri') - fromServerMsg (FromServerRsp m@STextDocumentRename r) = FromServerRsp m $ r & result %~ (fmap swapWorkspaceEdit) + fromServerMsg (FromServerMess m@SMethod_WorkspaceApplyEdit r) = FromServerMess m $ L.params . L.edit .~ swapWorkspaceEdit (r ^. L.params . L.edit) $ r + fromServerMsg (FromServerMess m@SMethod_TextDocumentPublishDiagnostics n) = FromServerMess m $ swapUri L.params n + fromServerMsg (FromServerRsp m@SMethod_TextDocumentDocumentSymbol r) = + let swapUri' :: ([SymbolInformation] |? [DocumentSymbol] |? Null) -> [SymbolInformation] |? [DocumentSymbol] |? Null + swapUri' (InR (InL dss)) = InR $ InL dss -- no file locations here + swapUri' (InR (InR n)) = InR $ InR n + swapUri' (InL si) = InL (swapUri L.location <$> si) + in FromServerRsp m $ r & L.result . _Right %~ swapUri' + fromServerMsg (FromServerRsp m@SMethod_TextDocumentRename r) = FromServerRsp m $ r & L.result . _Right . _L %~ swapWorkspaceEdit fromServerMsg x = x swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit swapWorkspaceEdit e = let swapDocumentChangeUri :: DocumentChange -> DocumentChange - swapDocumentChangeUri (InL textDocEdit) = InL $ swapUri textDocument textDocEdit + swapDocumentChangeUri (InL textDocEdit) = InL $ swapUri L.textDocument textDocEdit swapDocumentChangeUri (InR (InL createFile)) = InR $ InL $ swapUri id createFile -- for RenameFile, we swap `newUri` - swapDocumentChangeUri (InR (InR (InL renameFile))) = InR $ InR $ InL $ newUri .~ f (renameFile ^. newUri) $ renameFile + swapDocumentChangeUri (InR (InR (InL renameFile))) = InR $ InR $ InL $ L.newUri .~ f (renameFile ^. L.newUri) $ renameFile swapDocumentChangeUri (InR (InR (InR deleteFile))) = InR $ InR $ InR $ swapUri id deleteFile - - newDocChanges = fmap (fmap swapDocumentChangeUri) $ e ^. documentChanges - newChanges = fmap (swapKeys f) $ e ^. changes - in WorkspaceEdit newChanges newDocChanges Nothing + in e & L.changes . _Just %~ swapKeys f + & L.documentChanges . _Just . traversed%~ swapDocumentChangeUri - swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b - swapKeys f = HM.foldlWithKey' (\acc k v -> HM.insert (f k) v acc) HM.empty + swapKeys :: (Uri -> Uri) -> M.Map Uri b -> M.Map Uri b + swapKeys f = M.foldlWithKey' (\acc k v -> M.insert (f k) v acc) M.empty - swapUri :: HasUri b Uri => Lens' a b -> a -> a + swapUri :: L.HasUri b Uri => Lens' a b -> a -> a swapUri lens x = - let newUri = f (x ^. lens . uri) - in (lens . uri) .~ newUri $ x + let newUri = f (x ^. lens . L.uri) + in (lens . L.uri) .~ newUri $ x -- | Transforms rootUri/rootPath. transformInit :: InitializeParams -> InitializeParams transformInit x = - let newRootUri = fmap f (x ^. rootUri) - newRootPath = do - fp <- T.unpack <$> x ^. rootPath - let uri = filePathToUri fp - T.pack <$> uriToFilePath (f uri) - in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x + let modifyRootPath p = + let fp = T.unpack p + uri = filePathToUri fp + in case uriToFilePath (f uri) of + Just fp -> T.pack fp + Nothing -> p + in x & L.rootUri . _L %~ f + & L.rootPath . _Just . _L %~ modifyRootPath diff --git a/src/Language/LSP/Test/Parsing.hs b/src/Language/LSP/Test/Parsing.hs --- a/src/Language/LSP/Test/Parsing.hs +++ b/src/Language/LSP/Test/Parsing.hs @@ -1,10 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeInType #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeInType #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} @@ -35,8 +31,10 @@ import qualified Data.Conduit.Parser (named) import qualified Data.Text as T import Data.Typeable -import Language.LSP.Types +import Language.LSP.Protocol.Message import Language.LSP.Test.Session +import GHC.TypeLits (KnownSymbol, symbolVal) +import Data.GADT.Compare -- $receiving -- To receive a message, specify the method of the message to expect: @@ -115,8 +113,8 @@ -- | Matches a request or a notification coming from the server. -- Doesn't match Custom Messages -message :: SServerMethod m -> Session (ServerMessage m) -message (SCustomMethod _) = error "message can't be used with CustomMethod, use customRequest or customNotification instead" +message :: SServerMethod m -> Session (TMessage m) +message (SMethod_CustomMethod _) = error "message can't be used with CustomMethod, use customRequest or customNotification instead" message m1 = named (T.pack $ "Request for: " <> show m1) $ satisfyMaybe $ \case FromServerMess m2 msg -> do res <- mEqServer m1 m2 @@ -125,23 +123,31 @@ Left _f -> Nothing _ -> Nothing -customRequest :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Request)) -customRequest m = named m $ satisfyMaybe $ \case - FromServerMess m1 msg -> case splitServerMethod m1 of - IsServerEither -> case msg of - ReqMess _ | m1 == SCustomMethod m -> Just msg +customRequest :: KnownSymbol s => Proxy s -> Session (TMessage (Method_CustomMethod s :: Method ServerToClient Request)) +customRequest p = + let m = T.pack $ symbolVal p + in named m $ satisfyMaybe $ \case + FromServerMess m1 msg -> case splitServerMethod m1 of + IsServerEither -> case msg of + ReqMess _ -> case m1 `geq` SMethod_CustomMethod p of + Just Refl -> Just msg + _ -> Nothing + _ -> Nothing _ -> Nothing _ -> Nothing - _ -> Nothing -customNotification :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Notification)) -customNotification m = named m $ satisfyMaybe $ \case - FromServerMess m1 msg -> case splitServerMethod m1 of - IsServerEither -> case msg of - NotMess _ | m1 == SCustomMethod m -> Just msg +customNotification :: KnownSymbol s => Proxy s -> Session (TMessage (Method_CustomMethod s :: Method ServerToClient Notification)) +customNotification p = + let m = T.pack $ symbolVal p + in named m $ satisfyMaybe $ \case + FromServerMess m1 msg -> case splitServerMethod m1 of + IsServerEither -> case msg of + NotMess _ -> case m1 `geq` SMethod_CustomMethod p of + Just Refl -> Just msg + _ -> Nothing + _ -> Nothing _ -> Nothing _ -> Nothing - _ -> Nothing -- | Matches if the message is a notification. anyNotification :: Session FromServerMessage @@ -169,7 +175,7 @@ FromServerRsp _ _ -> True -- | Matches a response coming from the server. -response :: SMethod (m :: Method FromClient Request) -> Session (ResponseMessage m) +response :: SMethod (m :: Method ClientToServer Request) -> Session (TResponseMessage m) response m1 = named (T.pack $ "Response for: " <> show m1) $ satisfyMaybe $ \case FromServerRsp m2 msg -> do HRefl <- runEq mEqClient m1 m2 @@ -177,12 +183,12 @@ _ -> Nothing -- | Like 'response', but matches a response for a specific id. -responseForId :: SMethod (m :: Method FromClient Request) -> LspId m -> Session (ResponseMessage m) +responseForId :: SMethod (m :: Method ClientToServer Request) -> LspId m -> Session (TResponseMessage m) responseForId m lid = named (T.pack $ "Response for id: " ++ show lid) $ do satisfyMaybe $ \msg -> do case msg of FromServerMess _ _ -> Nothing - FromServerRsp m' rspMsg@(ResponseMessage _ lid' _) -> do + FromServerRsp m' rspMsg@(TResponseMessage _ lid' _) -> do HRefl <- runEq mEqClient m m' guard (Just lid == lid') pure rspMsg @@ -195,16 +201,16 @@ loggingNotification :: Session FromServerMessage loggingNotification = named "Logging notification" $ satisfy shouldSkip where - shouldSkip (FromServerMess SWindowLogMessage _) = True - shouldSkip (FromServerMess SWindowShowMessage _) = True - shouldSkip (FromServerMess SWindowShowMessageRequest _) = True - shouldSkip (FromServerMess SWindowShowDocument _) = True + shouldSkip (FromServerMess SMethod_WindowLogMessage _) = True + shouldSkip (FromServerMess SMethod_WindowShowMessage _) = True + shouldSkip (FromServerMess SMethod_WindowShowMessageRequest _) = True + shouldSkip (FromServerMess SMethod_WindowShowDocument _) = True shouldSkip _ = False -- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics' -- (textDocument/publishDiagnostics) notification. -publishDiagnosticsNotification :: Session (Message TextDocumentPublishDiagnostics) +publishDiagnosticsNotification :: Session (TMessage Method_TextDocumentPublishDiagnostics) publishDiagnosticsNotification = named "Publish diagnostics notification" $ satisfyMaybe $ \msg -> case msg of - FromServerMess STextDocumentPublishDiagnostics diags -> Just diags + FromServerMess SMethod_TextDocumentPublishDiagnostics diags -> Just diags _ -> Nothing 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 @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} @@ -43,16 +44,16 @@ import Control.Monad.Catch (MonadThrow) import Control.Monad.Except import Control.Monad.IO.Class +import Control.Monad.Trans.Class #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, execState) import qualified Control.Monad.Trans.State as State import qualified Data.ByteString.Lazy.Char8 as B -import Data.Aeson hiding (Error) +import Data.Aeson hiding (Error, Null) import Data.Aeson.Encode.Pretty import Data.Conduit as Conduit import Data.Conduit.Parser as Parser @@ -63,13 +64,11 @@ import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.IO as T -import qualified Data.HashMap.Strict as HashMap import Data.Maybe import Data.Function -import Language.LSP.Types.Capabilities -import Language.LSP.Types -import Language.LSP.Types.Lens -import qualified Language.LSP.Types.Lens as LSP +import Language.LSP.Protocol.Types as LSP +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message as LSP import Language.LSP.VFS import Language.LSP.Test.Compat import Language.LSP.Test.Decoding @@ -84,6 +83,7 @@ import System.Timeout ( timeout ) import Data.IORef import Colog.Core (LogAction (..), WithSeverity (..), Severity (..)) +import Data.Row -- | A session representing one instance of launching and connecting to a server. -- @@ -142,7 +142,7 @@ -- Keep curTimeoutId in SessionContext, as its tied to messageChan , curTimeoutId :: IORef Int -- ^ The current timeout we are waiting on , requestMap :: MVar RequestMap - , initRsp :: MVar (ResponseMessage Initialize) + , initRsp :: MVar (TResponseMessage Method_Initialize) , config :: SessionConfig , sessionCapabilities :: ClientCapabilities } @@ -231,9 +231,9 @@ yield msg chanSource - isLogNotification (ServerMessage (FromServerMess SWindowShowMessage _)) = True - isLogNotification (ServerMessage (FromServerMess SWindowLogMessage _)) = True - isLogNotification (ServerMessage (FromServerMess SWindowShowDocument _)) = True + isLogNotification (ServerMessage (FromServerMess SMethod_WindowShowMessage _)) = True + isLogNotification (ServerMessage (FromServerMess SMethod_WindowLogMessage _)) = True + isLogNotification (ServerMessage (FromServerMess SMethod_WindowShowDocument _)) = True isLogNotification _ = False watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () @@ -307,64 +307,67 @@ yield msg where respond :: (MonadIO m, HasReader SessionContext m) => FromServerMessage -> m () - respond (FromServerMess SWindowWorkDoneProgressCreate req) = - sendMessage $ ResponseMessage "2.0" (Just $ req ^. LSP.id) (Right Empty) - respond (FromServerMess SWorkspaceApplyEdit r) = do - sendMessage $ ResponseMessage "2.0" (Just $ r ^. LSP.id) (Right $ ApplyWorkspaceEditResponseBody True Nothing Nothing) + respond (FromServerMess SMethod_WindowWorkDoneProgressCreate req) = + sendMessage $ TResponseMessage "2.0" (Just $ req ^. L.id) (Right Null) + respond (FromServerMess SMethod_WorkspaceApplyEdit r) = do + sendMessage $ TResponseMessage "2.0" (Just $ r ^. L.id) (Right $ ApplyWorkspaceEditResult True Nothing Nothing) respond _ = pure () -- extract Uri out from DocumentChange -- didn't put this in `lsp-types` because TH was getting in the way documentChangeUri :: DocumentChange -> Uri -documentChangeUri (InL x) = x ^. textDocument . uri -documentChangeUri (InR (InL x)) = x ^. uri -documentChangeUri (InR (InR (InL x))) = x ^. oldUri -documentChangeUri (InR (InR (InR x))) = x ^. uri +documentChangeUri (InL x) = x ^. L.textDocument . L.uri +documentChangeUri (InR (InL x)) = x ^. L.uri +documentChangeUri (InR (InR (InL x))) = x ^. L.oldUri +documentChangeUri (InR (InR (InR x))) = x ^. L.uri updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m () -updateState (FromServerMess SProgress req) = case req ^. params . value of - Begin _ -> - modify $ \s -> s { curProgressSessions = Set.insert (req ^. params . token) $ curProgressSessions s } - End _ -> - modify $ \s -> s { curProgressSessions = Set.delete (req ^. params . token) $ curProgressSessions s } +updateState (FromServerMess SMethod_Progress req) = case req ^. L.params . L.value of + v | Just _ <- v ^? _workDoneProgressBegin -> + modify $ \s -> s { curProgressSessions = Set.insert (req ^. L.params . L.token) $ curProgressSessions s } + v | Just _ <- v ^? _workDoneProgressEnd -> + modify $ \s -> s { curProgressSessions = Set.delete (req ^. L.params . L.token) $ curProgressSessions s } _ -> pure () -- Keep track of dynamic capability registration -updateState (FromServerMess SClientRegisterCapability req) = do - let List newRegs = (\sr@(SomeRegistration r) -> (r ^. LSP.id, sr)) <$> req ^. params . registrations +updateState (FromServerMess SMethod_ClientRegisterCapability req) = do + let + regs :: [SomeRegistration] + regs = req ^.. L.params . L.registrations . traversed . to toSomeRegistration . _Just + let newRegs = (\sr@(SomeRegistration r) -> (r ^. L.id, sr)) <$> regs modify $ \s -> s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) } -updateState (FromServerMess SClientUnregisterCapability req) = do - let List unRegs = (^. LSP.id) <$> req ^. params . unregisterations +updateState (FromServerMess SMethod_ClientUnregisterCapability req) = do + let unRegs = (^. L.id) <$> req ^. L.params . L.unregisterations modify $ \s -> let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs in s { curDynCaps = newCurDynCaps } -updateState (FromServerMess STextDocumentPublishDiagnostics n) = do - let List diags = n ^. params . diagnostics - doc = n ^. params . uri +updateState (FromServerMess SMethod_TextDocumentPublishDiagnostics n) = do + let diags = n ^. L.params . L.diagnostics + doc = n ^. L.params . L.uri modify $ \s -> let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s) in s { curDiagnostics = newDiags } -updateState (FromServerMess SWorkspaceApplyEdit r) = do +updateState (FromServerMess SMethod_WorkspaceApplyEdit r) = do -- First, prefer the versioned documentChanges field - allChangeParams <- case r ^. params . edit . documentChanges of - Just (List cs) -> do + allChangeParams <- case r ^. L.params . L.edit . L.documentChanges of + Just (cs) -> do mapM_ (checkIfNeedsOpened . documentChangeUri) cs -- replace the user provided version numbers with the VFS ones + 1 -- (technically we should check that the user versions match the VFS ones) - cs' <- traverseOf (traverse . _InL . textDocument) bumpNewestVersion cs + cs' <- traverseOf (traverse . _L . L.textDocument . _versionedTextDocumentIdentifier) bumpNewestVersion cs return $ mapMaybe getParamsFromDocumentChange cs' -- Then fall back to the changes field - Nothing -> case r ^. params . edit . changes of + Nothing -> case r ^. L.params . L.edit . L.changes of Just cs -> do - mapM_ checkIfNeedsOpened (HashMap.keys cs) - concat <$> mapM (uncurry getChangeParams) (HashMap.toList cs) + mapM_ checkIfNeedsOpened (Map.keys cs) + concat <$> mapM (uncurry getChangeParams) (Map.toList cs) Nothing -> error "WorkspaceEdit contains neither documentChanges nor changes!" @@ -372,20 +375,20 @@ let newVFS = flip execState (vfs s) $ changeFromServerVFS logger r return $ s { vfs = newVFS } - let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams + let groupedParams = groupBy (\a b -> a ^. L.textDocument == b ^. L.textDocument) allChangeParams mergedParams = map mergeParams groupedParams -- TODO: Don't do this when replaying a session - forM_ mergedParams (sendMessage . NotificationMessage "2.0" STextDocumentDidChange) + forM_ mergedParams (sendMessage . TNotificationMessage "2.0" SMethod_TextDocumentDidChange) -- Update VFS to new document versions - let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams - latestVersions = map ((^. textDocument) . last) sortedVersions + let sortedVersions = map (sortBy (compare `on` (^. L.textDocument . L.version))) groupedParams + latestVersions = map ((^. L.textDocument) . last) sortedVersions forM_ latestVersions $ \(VersionedTextDocumentIdentifier uri v) -> modify $ \s -> let oldVFS = vfs s - update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver +1) t + update (VirtualFile _ file_ver t) = VirtualFile v (file_ver +1) t newVFS = oldVFS & vfsMap . ix (toNormalizedUri uri) %~ update in s { vfs = newVFS } @@ -399,23 +402,24 @@ let fp = fromJust $ uriToFilePath uri contents <- liftIO $ T.readFile fp let item = TextDocumentItem (filePathToUri fp) "" 0 contents - msg = NotificationMessage "2.0" STextDocumentDidOpen (DidOpenTextDocumentParams item) + msg = TNotificationMessage "2.0" SMethod_TextDocumentDidOpen (DidOpenTextDocumentParams item) sendMessage msg modifyM $ \s -> do let newVFS = flip execState (vfs s) $ openVFS logger msg return $ s { vfs = newVFS } - getParamsFromTextDocumentEdit :: TextDocumentEdit -> DidChangeTextDocumentParams - getParamsFromTextDocumentEdit (TextDocumentEdit docId (List edits)) = do - DidChangeTextDocumentParams docId (List $ map editToChangeEvent edits) + getParamsFromTextDocumentEdit :: TextDocumentEdit -> Maybe DidChangeTextDocumentParams + getParamsFromTextDocumentEdit (TextDocumentEdit docId edits) = + DidChangeTextDocumentParams <$> docId ^? _versionedTextDocumentIdentifier <*> pure (map editToChangeEvent edits) + -- TODO: move somewhere reusable editToChangeEvent :: TextEdit |? AnnotatedTextEdit -> TextDocumentContentChangeEvent - editToChangeEvent (InR e) = TextDocumentContentChangeEvent (Just $ e ^. range) Nothing (e ^. newText) - editToChangeEvent (InL e) = TextDocumentContentChangeEvent (Just $ e ^. range) Nothing (e ^. newText) + editToChangeEvent (InR e) = TextDocumentContentChangeEvent $ InL $ #range .== (e ^. L.range) .+ #rangeLength .== Nothing .+ #text .== (e ^. L.newText) + editToChangeEvent (InL e) = TextDocumentContentChangeEvent $ InL $ #range .== (e ^. L.range) .+ #rangeLength .== Nothing .+ #text .== (e ^. L.newText) getParamsFromDocumentChange :: DocumentChange -> Maybe DidChangeTextDocumentParams - getParamsFromDocumentChange (InL textDocumentEdit) = Just $ getParamsFromTextDocumentEdit textDocumentEdit + getParamsFromDocumentChange (InL textDocumentEdit) = getParamsFromTextDocumentEdit textDocumentEdit getParamsFromDocumentChange _ = Nothing bumpNewestVersion (VersionedTextDocumentIdentifier uri _) = @@ -426,18 +430,19 @@ textDocumentVersions uri = do vfs <- vfs <$> get let curVer = fromMaybe 0 $ vfs ^? vfsMap . ix (toNormalizedUri uri) . lsp_version - pure $ map (VersionedTextDocumentIdentifier uri . Just) [curVer + 1..] + pure $ map (VersionedTextDocumentIdentifier uri) [curVer + 1..] textDocumentEdits uri edits = do vers <- textDocumentVersions uri - pure $ map (\(v, e) -> TextDocumentEdit v (List [InL e])) $ zip vers edits + pure $ map (\(v, e) -> TextDocumentEdit (review _versionedTextDocumentIdentifier v) [InL e]) $ zip vers edits - getChangeParams uri (List edits) = do - map <$> pure getParamsFromTextDocumentEdit <*> textDocumentEdits uri (reverse edits) + getChangeParams uri edits = do + edits <- textDocumentEdits uri (reverse edits) + pure $ catMaybes $ map getParamsFromTextDocumentEdit edits mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams - mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params)) - in DidChangeTextDocumentParams (head params ^. textDocument) (List events) + mergeParams params = let events = concat (toList (map (toList . (^. L.contentChanges)) params)) + in DidChangeTextDocumentParams (head params ^. L.textDocument) events updateState _ = return () sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m () diff --git a/test/DummyServer.hs b/test/DummyServer.hs --- a/test/DummyServer.hs +++ b/test/DummyServer.hs @@ -1,11 +1,13 @@ {-# LANGUAGE TypeInType #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeApplications #-} module DummyServer where import Control.Monad import Control.Monad.Reader -import Data.Aeson hiding (defaultOptions) -import qualified Data.HashMap.Strict as HM +import Data.Aeson hiding (defaultOptions, Null) +import qualified Data.Map.Strict as M import Data.List (isSuffixOf) import Data.String import UnliftIO.Concurrent @@ -15,8 +17,9 @@ import System.Directory import System.FilePath import System.Process -import Language.LSP.Types -import Data.Default +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Message +import Data.Proxy withDummyServer :: ((Handle, Handle) -> IO ()) -> IO () withDummyServer f = do @@ -31,7 +34,7 @@ , staticHandlers = handlers , interpretHandler = \env -> Iso (\m -> runLspT env (runReaderT m handlerEnv)) liftIO - , options = defaultOptions {executeCommandCommands = Just ["doAnEdit"]} + , options = defaultOptions {optExecuteCommandCommands = Just ["doAnEdit"]} } bracket @@ -41,53 +44,54 @@ data HandlerEnv = HandlerEnv - { relRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles) - , absRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles) + { relRegToken :: MVar (RegistrationToken Method_WorkspaceDidChangeWatchedFiles) + , absRegToken :: MVar (RegistrationToken Method_WorkspaceDidChangeWatchedFiles) } handlers :: Handlers (ReaderT HandlerEnv (LspM ())) handlers = mconcat - [ notificationHandler SInitialized $ + [ notificationHandler SMethod_Initialized $ \_noti -> - sendNotification SWindowLogMessage $ - LogMessageParams MtLog "initialized" - , requestHandler STextDocumentHover $ + sendNotification SMethod_WindowLogMessage $ + LogMessageParams MessageType_Log "initialized" + , requestHandler SMethod_TextDocumentHover $ \_req responder -> responder $ Right $ - Just $ - Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing - , requestHandler STextDocumentDocumentSymbol $ + InL $ + Hover (InL (MarkupContent MarkupKind_PlainText "hello")) Nothing + , requestHandler SMethod_TextDocumentDocumentSymbol $ \_req responder -> responder $ Right $ - InL $ - List - [ DocumentSymbol - "foo" - Nothing - SkObject - Nothing - Nothing - (mkRange 0 0 3 6) - (mkRange 0 0 3 6) - Nothing - ] - , notificationHandler STextDocumentDidOpen $ + InR $ InL + [ DocumentSymbol + "foo" + Nothing + SymbolKind_Object + Nothing + Nothing + (mkRange 0 0 3 6) + (mkRange 0 0 3 6) + Nothing + ] + , notificationHandler SMethod_TextDocumentDidOpen $ \noti -> do - let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti + let TNotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti TextDocumentItem uri _ _ _ = doc Just fp = uriToFilePath uri diag = Diagnostic (mkRange 0 0 0 1) - (Just DsWarning) + (Just DiagnosticSeverity_Warning) (Just (InL 42)) + Nothing (Just "dummy-server") "Here's a warning" Nothing Nothing + Nothing withRunInIO $ \runInIO -> do when (".hs" `isSuffixOf` fp) $ @@ -96,39 +100,37 @@ do threadDelay (2 * 10 ^ 6) runInIO $ - sendNotification STextDocumentPublishDiagnostics $ - PublishDiagnosticsParams uri Nothing (List [diag]) + sendNotification SMethod_TextDocumentPublishDiagnostics $ + PublishDiagnosticsParams uri Nothing [diag] -- also act as a registerer for workspace/didChangeWatchedFiles when (".register" `isSuffixOf` fp) $ do let regOpts = - DidChangeWatchedFilesRegistrationOptions $ - List - [ FileSystemWatcher - "*.watch" - (Just (WatchKind True True True)) - ] + DidChangeWatchedFilesRegistrationOptions + [ FileSystemWatcher + (GlobPattern $ InL $ Pattern "*.watch") + (Just WatchKind_Create) + ] Just token <- runInIO $ - registerCapability SWorkspaceDidChangeWatchedFiles regOpts $ + registerCapability SMethod_WorkspaceDidChangeWatchedFiles regOpts $ \_noti -> - sendNotification SWindowLogMessage $ - LogMessageParams MtLog "got workspace/didChangeWatchedFiles" + sendNotification SMethod_WindowLogMessage $ + LogMessageParams MessageType_Log "got workspace/didChangeWatchedFiles" runInIO $ asks relRegToken >>= \v -> putMVar v token when (".register.abs" `isSuffixOf` fp) $ do curDir <- getCurrentDirectory let regOpts = - DidChangeWatchedFilesRegistrationOptions $ - List - [ FileSystemWatcher - (fromString $ curDir "*.watch") - (Just (WatchKind True True True)) - ] + DidChangeWatchedFilesRegistrationOptions + [ FileSystemWatcher + (GlobPattern $ InL $ Pattern $ fromString $ curDir "*.watch") + (Just WatchKind_Create) + ] Just token <- runInIO $ - registerCapability SWorkspaceDidChangeWatchedFiles regOpts $ + registerCapability SMethod_WorkspaceDidChangeWatchedFiles regOpts $ \_noti -> - sendNotification SWindowLogMessage $ - LogMessageParams MtLog "got workspace/didChangeWatchedFiles" + sendNotification SMethod_WindowLogMessage $ + LogMessageParams MessageType_Log "got workspace/didChangeWatchedFiles" runInIO $ asks absRegToken >>= \v -> putMVar v token -- also act as an unregisterer for workspace/didChangeWatchedFiles when (".unregister" `isSuffixOf` fp) $ @@ -142,57 +144,57 @@ -- this handler is used by the -- "text document VFS / sends back didChange notifications (documentChanges)" test - , notificationHandler STextDocumentDidChange $ \noti -> do - let NotificationMessage _ _ params = noti - void $ sendNotification (SCustomMethod "custom/textDocument/didChange") (toJSON params) + , notificationHandler SMethod_TextDocumentDidChange $ \noti -> do + let TNotificationMessage _ _ params = noti + void $ sendNotification (SMethod_CustomMethod (Proxy @"custom/textDocument/didChange")) (toJSON params) - , requestHandler SWorkspaceExecuteCommand $ \req resp -> do + , requestHandler SMethod_WorkspaceExecuteCommand $ \req resp -> do case req of - RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just (List [val]))) -> do + TRequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just [val])) -> do let Success docUri = fromJSON val - edit = List [TextEdit (mkRange 0 0 0 5) "howdy"] + edit = [TextEdit (mkRange 0 0 0 5) "howdy"] params = ApplyWorkspaceEditParams (Just "Howdy edit") $ - WorkspaceEdit (Just (HM.singleton docUri edit)) Nothing Nothing - resp $ Right Null - void $ sendRequest SWorkspaceApplyEdit params (const (pure ())) - RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAVersionedEdit" (Just (List [val]))) -> do + WorkspaceEdit (Just (M.singleton docUri edit)) Nothing Nothing + resp $ Right $ InR $ Null + void $ sendRequest SMethod_WorkspaceApplyEdit params (const (pure ())) + TRequestMessage _ _ _ (ExecuteCommandParams Nothing "doAVersionedEdit" (Just [val])) -> do let Success versionedDocUri = fromJSON val - edit = List [InL (TextEdit (mkRange 0 0 0 5) "howdy")] + edit = [InL (TextEdit (mkRange 0 0 0 5) "howdy")] documentEdit = TextDocumentEdit versionedDocUri edit params = ApplyWorkspaceEditParams (Just "Howdy edit") $ - WorkspaceEdit Nothing (Just (List [InL documentEdit])) Nothing - resp $ Right Null - void $ sendRequest SWorkspaceApplyEdit params (const (pure ())) - RequestMessage _ _ _ (ExecuteCommandParams _ name _) -> + WorkspaceEdit Nothing (Just [InL documentEdit]) Nothing + resp $ Right $ InR Null + void $ sendRequest SMethod_WorkspaceApplyEdit params (const (pure ())) + TRequestMessage _ _ _ (ExecuteCommandParams _ name _) -> error $ "unsupported command: " <> show name - , requestHandler STextDocumentCodeAction $ \req resp -> do - let RequestMessage _ _ _ params = req + , requestHandler SMethod_TextDocumentCodeAction $ \req resp -> do + let TRequestMessage _ _ _ params = req CodeActionParams _ _ _ _ cactx = params - CodeActionContext diags _ = cactx + CodeActionContext diags _ _ = cactx codeActions = fmap diag2ca diags diag2ca d = CodeAction "Delete this" Nothing - (Just (List [d])) + (Just [d]) Nothing Nothing Nothing (Just (Command "" "deleteThis" Nothing)) Nothing - resp $ Right $ InR <$> codeActions - , requestHandler STextDocumentCompletion $ \_req resp -> do - let res = CompletionList True (List [item]) + resp $ Right $ InL $ InR <$> codeActions + , requestHandler SMethod_TextDocumentCompletion $ \_req resp -> do + let res = CompletionList True Nothing [item] item = CompletionItem "foo" - (Just CiConstant) - (Just (List [])) Nothing + (Just CompletionItemKind_Constant) + (Just []) Nothing Nothing Nothing @@ -206,15 +208,17 @@ Nothing Nothing Nothing - resp $ Right $ InR res - , requestHandler STextDocumentPrepareCallHierarchy $ \req resp -> do - let RequestMessage _ _ _ params = req + Nothing + Nothing + resp $ Right $ InR $ InL res + , requestHandler SMethod_TextDocumentPrepareCallHierarchy $ \req resp -> do + let TRequestMessage _ _ _ params = req CallHierarchyPrepareParams _ pos _ = params Position x y = pos item = CallHierarchyItem "foo" - SkMethod + SymbolKind_Method Nothing Nothing (Uri "") @@ -222,21 +226,21 @@ (Range (Position 2 3) (Position 4 5)) Nothing if x == 0 && y == 0 - then resp $ Right Nothing - else resp $ Right $ Just $ List [item] - , requestHandler SCallHierarchyIncomingCalls $ \req resp -> do - let RequestMessage _ _ _ params = req + then resp $ Right $ InR Null + else resp $ Right $ InL [item] + , requestHandler SMethod_CallHierarchyIncomingCalls $ \req resp -> do + let TRequestMessage _ _ _ params = req CallHierarchyIncomingCallsParams _ _ item = params - resp $ Right $ Just $ - List [CallHierarchyIncomingCall item (List [Range (Position 2 3) (Position 4 5)])] - , requestHandler SCallHierarchyOutgoingCalls $ \req resp -> do - let RequestMessage _ _ _ params = req + resp $ Right $ InL + [CallHierarchyIncomingCall item [Range (Position 2 3) (Position 4 5)]] + , requestHandler SMethod_CallHierarchyOutgoingCalls $ \req resp -> do + let TRequestMessage _ _ _ params = req CallHierarchyOutgoingCallsParams _ _ item = params - resp $ Right $ Just $ - List [CallHierarchyOutgoingCall item (List [Range (Position 4 5) (Position 2 3)])] - , requestHandler STextDocumentSemanticTokensFull $ \_req resp -> do - let tokens = makeSemanticTokens def [SemanticTokenAbsolute 0 1 2 SttType []] + resp $ Right $ InL + [CallHierarchyOutgoingCall item [Range (Position 4 5) (Position 2 3)]] + , requestHandler SMethod_TextDocumentSemanticTokensFull $ \_req resp -> do + let tokens = makeSemanticTokens defaultSemanticTokensLegend [SemanticTokenAbsolute 0 1 2 SemanticTokenTypes_Type []] case tokens of - Left t -> resp $ Left $ ResponseError InternalError t Nothing - Right tokens -> resp $ Right $ Just tokens + Left t -> resp $ Left $ ResponseError (InR ErrorCodes_InternalError) t Nothing + Right tokens -> resp $ Right $ InL tokens ] diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -3,29 +3,27 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TypeApplications #-} import DummyServer import Test.Hspec import Data.Aeson import Data.Default -import qualified Data.HashMap.Strict as HM +import qualified Data.Map.Strict as M import Data.Either import Data.Maybe import qualified Data.Text as T import Data.Type.Equality +import Data.Proxy import Control.Applicative.Combinators import Control.Concurrent import Control.Monad.IO.Class import Control.Monad import Control.Lens hiding (List, Iso) import Language.LSP.Test -import Language.LSP.Types -import Language.LSP.Types.Lens hiding - (capabilities, message, rename, applyEdit) -import qualified Language.LSP.Types.Lens as LSP -import Language.LSP.Types.Capabilities as LSP +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import qualified Language.LSP.Protocol.Lens as L import System.Directory import System.FilePath import System.Timeout @@ -44,10 +42,10 @@ in session `shouldThrow` anySessionException it "initializeResponse" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do rsp <- initializeResponse - liftIO $ rsp ^. result `shouldSatisfy` isRight + liftIO $ rsp ^. L.result `shouldSatisfy` isRight it "runSessionWithConfig" $ \(hin, hout) -> - runSessionWithHandles hin hout def didChangeCaps "." $ return () + runSessionWithHandles hin hout def fullCaps "." $ return () describe "withTimeout" $ do it "times out" $ \(hin, hout) -> @@ -56,7 +54,7 @@ -- won't receive a request - will timeout -- incoming logging requests shouldn't increase the -- timeout - withTimeout 5 $ skipManyTill anyMessage (message SWorkspaceApplyEdit) + withTimeout 5 $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) -- wait just a bit longer than 5 seconds so we have time -- to open the document in timeout 6000000 sesh `shouldThrow` anySessionException @@ -96,7 +94,7 @@ withTimeout 10 $ liftIO $ threadDelay 7000000 getDocumentSymbols doc -- should now timeout - skipManyTill anyMessage (message SWorkspaceApplyEdit) + skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) isTimeout (Timeout _) = True isTimeout _ = False in sesh `shouldThrow` isTimeout @@ -106,7 +104,7 @@ it "throw on time out" $ \(hin, hout) -> let sesh = runSessionWithHandles hin hout (def {messageTimeout = 10}) fullCaps "." $ do skipMany loggingNotification - _ <- message SWorkspaceApplyEdit + _ <- message SMethod_WorkspaceApplyEdit return () in sesh `shouldThrow` anySessionException @@ -119,17 +117,17 @@ describe "UnexpectedMessageException" $ do it "throws when there's an unexpected message" $ \(hin, hout) -> - let selector (UnexpectedMessage "Publish diagnostics notification" (FromServerMess SWindowLogMessage _)) = True + let selector (UnexpectedMessage "Publish diagnostics notification" (FromServerMess SMethod_WindowLogMessage _)) = True selector _ = False in runSessionWithHandles hin hout def fullCaps "." publishDiagnosticsNotification `shouldThrow` selector it "provides the correct types that were expected and received" $ \(hin, hout) -> - let selector (UnexpectedMessage "Response for: STextDocumentRename" (FromServerRsp STextDocumentDocumentSymbol _)) = True + let selector (UnexpectedMessage "Response for: SMethod_TextDocumentRename" (FromServerRsp SMethod_TextDocumentDocumentSymbol _)) = True selector _ = False sesh = do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" - sendRequest STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) + sendRequest SMethod_TextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) skipMany anyNotification - response STextDocumentRename -- the wrong type + response SMethod_TextDocumentRename -- the wrong type in runSessionWithHandles hin hout def fullCaps "." sesh `shouldThrow` selector @@ -139,20 +137,20 @@ doc <- openDoc "test/data/refactor/Main.hs" "haskell" VersionedTextDocumentIdentifier _ beforeVersion <- getVersionedDoc doc - let args = toJSON (VersionedTextDocumentIdentifier (doc ^. uri) beforeVersion) - reqParams = ExecuteCommandParams Nothing "doAVersionedEdit" (Just (List [args])) + let args = toJSON (VersionedTextDocumentIdentifier (doc ^. L.uri) beforeVersion) + reqParams = ExecuteCommandParams Nothing "doAVersionedEdit" (Just [args]) - request_ SWorkspaceExecuteCommand reqParams + request_ SMethod_WorkspaceExecuteCommand reqParams - editReq <- message SWorkspaceApplyEdit + editReq <- message SMethod_WorkspaceApplyEdit liftIO $ do - let Just (List [InL(TextDocumentEdit vdoc (List [InL edit_]))]) = - editReq ^. params . edit . documentChanges - vdoc `shouldBe` VersionedTextDocumentIdentifier (doc ^. uri) beforeVersion + let Just [InL(TextDocumentEdit vdoc [InL edit_])] = + editReq ^. L.params . L.edit . L.documentChanges + vdoc `shouldBe` OptionalVersionedTextDocumentIdentifier (doc ^. L.uri) (InL beforeVersion) edit_ `shouldBe` TextEdit (Range (Position 0 0) (Position 0 5)) "howdy" - change <- customNotification "custom/textDocument/didChange" - let NotMess (NotificationMessage _ _ (c::Value)) = change + change <- customNotification (Proxy @"custom/textDocument/didChange") + let NotMess (TNotificationMessage _ _ (c::Value)) = change Success (DidChangeTextDocumentParams reportedVDoc _edit) = fromJSON c VersionedTextDocumentIdentifier _ reportedVersion = reportedVDoc @@ -168,15 +166,15 @@ runSessionWithHandles hin hout def fullCaps "." $ do doc <- openDoc "test/data/refactor/Main.hs" "haskell" - let args = toJSON (doc ^. uri) - reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args])) - request_ SWorkspaceExecuteCommand reqParams + let args = toJSON (doc ^. L.uri) + reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just [args]) + request_ SMethod_WorkspaceExecuteCommand reqParams - editReq <- message SWorkspaceApplyEdit + editReq <- message SMethod_WorkspaceApplyEdit liftIO $ do - let (Just cs) = editReq ^. params . edit . changes - [(u, List es)] = HM.toList cs - u `shouldBe` doc ^. uri + let (Just cs) = editReq ^. L.params . L.edit . L.changes + [(u, es)] = M.toList cs + u `shouldBe` doc ^. L.uri es `shouldBe` [TextEdit (Range (Position 0 0) (Position 0 5)) "howdy"] contents <- documentContents doc liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n" @@ -186,9 +184,9 @@ runSessionWithHandles hin hout def fullCaps "." $ do doc <- openDoc "test/data/refactor/Main.hs" "haskell" - let args = toJSON (doc ^. uri) - reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args])) - request_ SWorkspaceExecuteCommand reqParams + let args = toJSON (doc ^. L.uri) + reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just [args]) + request_ SMethod_WorkspaceExecuteCommand reqParams contents <- getDocumentEdit doc liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n" @@ -198,7 +196,7 @@ waitForDiagnostics [InR action] <- getCodeActions doc (Range (Position 0 0) (Position 0 2)) actions <- getCodeActions doc (Range (Position 1 14) (Position 1 18)) - liftIO $ action ^. title `shouldBe` "Delete this" + liftIO $ action ^. L.title `shouldBe` "Delete this" liftIO $ actions `shouldSatisfy` null describe "getAllCodeActions" $ @@ -208,8 +206,8 @@ actions <- getAllCodeActions doc liftIO $ do let [InR action] = actions - action ^. title `shouldBe` "Delete this" - action ^. command . _Just . command `shouldBe` "deleteThis" + action ^. L.title `shouldBe` "Delete this" + action ^. L.command . _Just . L.command `shouldBe` "deleteThis" describe "getDocumentSymbols" $ it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do @@ -217,19 +215,19 @@ skipMany loggingNotification - Left (mainSymbol:_) <- getDocumentSymbols doc + Right (mainSymbol:_) <- getDocumentSymbols doc liftIO $ do - mainSymbol ^. name `shouldBe` "foo" - mainSymbol ^. kind `shouldBe` SkObject - mainSymbol ^. range `shouldBe` mkRange 0 0 3 6 + mainSymbol ^. L.name `shouldBe` "foo" + mainSymbol ^. L.kind `shouldBe` SymbolKind_Object + mainSymbol ^. L.range `shouldBe` mkRange 0 0 3 6 describe "applyEdit" $ do - it "increments the version" $ \(hin, hout) -> runSessionWithHandles hin hout def docChangesCaps "." $ do + it "increments the version" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" - VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc + VersionedTextDocumentIdentifier _ oldVersion <- getVersionedDoc doc let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo" - VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit + VersionedTextDocumentIdentifier _ newVersion <- applyEdit doc edit liftIO $ newVersion `shouldBe` oldVersion + 1 it "changes the document contents" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" @@ -244,7 +242,7 @@ comps <- getCompletions doc (Position 5 5) let item = head comps - liftIO $ item ^. label `shouldBe` "foo" + liftIO $ item ^. L.label `shouldBe` "foo" -- describe "getReferences" $ -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do @@ -277,8 +275,8 @@ openDoc "test/data/Error.hs" "haskell" [diag] <- waitForDiagnosticsSource "dummy-server" liftIO $ do - diag ^. severity `shouldBe` Just DsWarning - diag ^. source `shouldBe` Just "dummy-server" + diag ^. L.severity `shouldBe` Just DiagnosticSeverity_Warning + diag ^. L.source `shouldBe` Just "dummy-server" -- describe "rename" $ do -- it "works" $ \(hin, hout) -> pendingWith "HaRe not in hie-bios yet" @@ -328,24 +326,24 @@ describe "satisfy" $ it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do openDoc "test/data/Format.hs" "haskell" - let pred (FromServerMess SWindowLogMessage _) = True + let pred (FromServerMess SMethod_WindowLogMessage _) = True pred _ = False void $ satisfy pred describe "satisfyMaybe" $ do it "returns matched data on match" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do -- Wait for window/logMessage "initialized" from the server. - let pred (FromServerMess SWindowLogMessage _) = Just "match" :: Maybe String + let pred (FromServerMess SMethod_WindowLogMessage _) = Just "match" :: Maybe String pred _ = Nothing :: Maybe String result <- satisfyMaybe pred liftIO $ result `shouldBe` "match" it "doesn't return if no match" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do - let pred (FromServerMess STextDocumentPublishDiagnostics _) = Just "matched" :: Maybe String + let pred (FromServerMess SMethod_TextDocumentPublishDiagnostics _) = Just "matched" :: Maybe String pred _ = Nothing :: Maybe String -- We expect a window/logMessage from the server, but -- not a textDocument/publishDiagnostics. - result <- satisfyMaybe pred <|> (message SWindowLogMessage *> pure "no match") + result <- satisfyMaybe pred <|> (message SMethod_WindowLogMessage *> pure "no match") liftIO $ result `shouldBe` "no match" describe "ignoreLogNotifications" $ @@ -360,26 +358,26 @@ loggingNotification -- initialized log message createDoc ".register" "haskell" "" - message SClientRegisterCapability + message SMethod_ClientRegisterCapability doc <- createDoc "Foo.watch" "haskell" "" - msg <- message SWindowLogMessage - liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles" + msg <- message SMethod_WindowLogMessage + liftIO $ msg ^. L.params . L.message `shouldBe` "got workspace/didChangeWatchedFiles" - [SomeRegistration (Registration _ regMethod regOpts)] <- getRegisteredCapabilities + [SomeRegistration (TRegistration _ regMethod regOpts)] <- getRegisteredCapabilities liftIO $ do - case regMethod `mEqClient` SWorkspaceDidChangeWatchedFiles of + case regMethod `mEqClient` SMethod_WorkspaceDidChangeWatchedFiles of Just (Right HRefl) -> - regOpts `shouldBe` (DidChangeWatchedFilesRegistrationOptions $ List - [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ]) + regOpts `shouldBe` (Just $ DidChangeWatchedFilesRegistrationOptions + [ FileSystemWatcher (GlobPattern $ InL $ Pattern "*.watch") (Just WatchKind_Create) ]) _ -> expectationFailure "Registration wasn't on workspace/didChangeWatchedFiles" -- now unregister it by sending a specific createDoc createDoc ".unregister" "haskell" "" - message SClientUnregisterCapability + message SMethod_ClientUnregisterCapability createDoc "Bar.watch" "haskell" "" - void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing + void $ sendRequest SMethod_TextDocumentHover $ HoverParams doc (Position 0 0) Nothing count 0 $ loggingNotification void $ anyResponse @@ -389,18 +387,18 @@ loggingNotification -- initialized log message createDoc ".register.abs" "haskell" "" - message SClientRegisterCapability + message SMethod_ClientRegisterCapability doc <- createDoc (curDir "Foo.watch") "haskell" "" - msg <- message SWindowLogMessage - liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles" + msg <- message SMethod_WindowLogMessage + liftIO $ msg ^. L.params . L.message `shouldBe` "got workspace/didChangeWatchedFiles" -- now unregister it by sending a specific createDoc createDoc ".unregister.abs" "haskell" "" - message SClientUnregisterCapability + message SMethod_ClientUnregisterCapability createDoc (curDir "Bar.watch") "haskell" "" - void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing + void $ sendRequest SMethod_TextDocumentHover $ HoverParams doc (Position 0 0) Nothing count 0 $ loggingNotification void $ anyResponse @@ -408,37 +406,25 @@ let workPos = Position 1 0 notWorkPos = Position 0 0 params pos = CallHierarchyPrepareParams (TextDocumentIdentifier (Uri "")) pos Nothing - item = CallHierarchyItem "foo" SkFunction Nothing Nothing (Uri "") + item = CallHierarchyItem "foo" SymbolKind_Function Nothing Nothing (Uri "") (Range (Position 1 2) (Position 3 4)) (Range (Position 1 2) (Position 3 4)) Nothing it "prepare works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do rsp <- prepareCallHierarchy (params workPos) - liftIO $ head rsp ^. range `shouldBe` Range (Position 2 3) (Position 4 5) + liftIO $ head rsp ^. L.range `shouldBe` Range (Position 2 3) (Position 4 5) it "prepare not works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do rsp <- prepareCallHierarchy (params notWorkPos) liftIO $ rsp `shouldBe` [] it "incoming calls" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do - [CallHierarchyIncomingCall _ (List fromRanges)] <- incomingCalls (CallHierarchyIncomingCallsParams Nothing Nothing item) + [CallHierarchyIncomingCall _ fromRanges] <- incomingCalls (CallHierarchyIncomingCallsParams Nothing Nothing item) liftIO $ head fromRanges `shouldBe` Range (Position 2 3) (Position 4 5) it "outgoing calls" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do - [CallHierarchyOutgoingCall _ (List fromRanges)] <- outgoingCalls (CallHierarchyOutgoingCallsParams Nothing Nothing item) + [CallHierarchyOutgoingCall _ fromRanges] <- outgoingCalls (CallHierarchyOutgoingCallsParams Nothing Nothing item) liftIO $ head fromRanges `shouldBe` Range (Position 4 5) (Position 2 3) describe "semantic tokens" $ do 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,1,0] - -didChangeCaps :: ClientCapabilities -didChangeCaps = def { _workspace = Just workspaceCaps } - where - workspaceCaps = def { _didChangeConfiguration = Just configCaps } - configCaps = DidChangeConfigurationClientCapabilities (Just True) - -docChangesCaps :: ClientCapabilities -docChangesCaps = def { _workspace = Just workspaceCaps } - where - workspaceCaps = def { _workspaceEdit = Just editCaps } - editCaps = WorkspaceEditClientCapabilities (Just True) Nothing Nothing Nothing Nothing + InL toks <- getSemanticTokens doc + liftIO $ toks ^. L.data_ `shouldBe` [0,1,2,1,0]