lsp-test 0.16.0.0 → 0.16.0.1
raw patch · 19 files changed
+1124/−951 lines, 19 filesdep ~lspdep ~lsp-typesPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: lsp, lsp-types
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- bench/SimpleBench.hs +42/−38
- example/Test.hs +7/−6
- func-test/FuncTest.hs +74/−68
- lsp-test.cabal +9/−4
- src/Language/LSP/Test.hs +447/−339
- src/Language/LSP/Test/Compat.hs +12/−13
- src/Language/LSP/Test/Decoding.hs +54/−48
- src/Language/LSP/Test/Exceptions.hs +48/−32
- src/Language/LSP/Test/Files.hs +72/−70
- src/Language/LSP/Test/Parsing.hs +102/−98
- src/Language/LSP/Test/Server.hs +2/−2
- src/Language/LSP/Test/Session.hs +5/−3
- test/DummyServer.hs +68/−66
- test/Test.hs +80/−75
- test/data/Format.hs +4/−3
- test/data/documentSymbolFail/example/Main.hs +76/−60
- test/data/renameFail/Desktop/simple.hs +9/−13
- test/data/renamePass/Desktop/simple.hs +9/−13
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for lsp-test +## 0.16.0.1++- Support newer versions of dependencies.+ ## 0.16.0.0 - The client configuration is now _mandatory_ and is an `Object` rather than a `Value`.
bench/SimpleBench.hs view
@@ -1,46 +1,49 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RankNTypes #-}+ module Main where -import Language.LSP.Server-import qualified Language.LSP.Test as Test-import Language.LSP.Protocol.Types-import Language.LSP.Protocol.Message-import Control.Monad.IO.Class+import Control.Concurrent import Control.Monad-import System.Process hiding (env)+import Control.Monad.IO.Class+import Data.IORef+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types+import Language.LSP.Server+import Language.LSP.Test qualified as Test import System.Environment+import System.Process hiding (env) import System.Time.Extra-import Control.Concurrent-import Data.IORef handlers :: Handlers (LspM ())-handlers = mconcat- [ requestHandler SMethod_TextDocumentHover $ \req responder -> do- let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req- Position _l _c' = pos- rsp = Hover ms (Just range)- ms = InL $ mkMarkdown "Hello world"- range = 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)- ]+handlers =+ mconcat+ [ requestHandler SMethod_TextDocumentHover $ \req responder -> do+ let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req+ Position _l _c' = pos+ rsp = Hover ms (Just range)+ ms = InL $ mkMarkdown "Hello world"+ range = 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 ()-server = ServerDefinition- { parseConfig = const $ const $ Right ()- , onConfigChange = const $ pure ()- , defaultConfig = ()- , configSection = "demo"- , doInitialize = \env _req -> pure $ Right env- , staticHandlers = \_caps -> handlers- , interpretHandler = \env -> Iso (runLspT env) liftIO- , options = defaultOptions- }+server =+ ServerDefinition+ { parseConfig = const $ const $ Right ()+ , onConfigChange = const $ pure ()+ , defaultConfig = ()+ , configSection = "demo"+ , doInitialize = \env _req -> pure $ Right env+ , staticHandlers = \_caps -> handlers+ , interpretHandler = \env -> Iso (runLspT env) liftIO+ , options = defaultOptions+ } main :: IO () main = do@@ -59,13 +62,14 @@ replicateM_ n $ do 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- TResponseMessage{_result=Right (InL _)} <- Test.request SMethod_TextDocumentDefinition $- DefinitionParams (TextDocumentIdentifier $ Uri "test") (Position 1000 100) Nothing Nothing+ TResponseMessage{_result = Right (InL _)} <-+ Test.request SMethod_TextDocumentHover $+ HoverParams (TextDocumentIdentifier $ Uri "test") (Position 1 100) Nothing+ TResponseMessage{_result = Right (InL _)} <-+ Test.request SMethod_TextDocumentDefinition $+ DefinitionParams (TextDocumentIdentifier $ Uri "test") (Position 1000 100) Nothing Nothing - liftIO $ modifyIORef' i (+1)+ liftIO $ modifyIORef' i (+ 1) pure () end <- liftIO start liftIO $ putStrLn $ "Completed " <> show n <> " rounds in " <> showDuration end-
example/Test.hs view
@@ -1,21 +1,22 @@ {-# LANGUAGE OverloadedStrings #-}+ import Control.Applicative.Combinators import Control.Monad.IO.Class-import Language.LSP.Test-import Language.LSP.Protocol.Types import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types+import Language.LSP.Test main = runSession "lsp-demo-reactor-server" fullCaps "test/data/" $ do doc <- openDoc "Rename.hs" "haskell"- + -- Use your favourite favourite combinators. skipManyTill loggingNotification (count 1 publishDiagnosticsNotification) -- Send requests and notifications and receive responses- rsp <- request SMethod_TextDocumentDocumentSymbol $- DocumentSymbolParams Nothing Nothing doc+ rsp <-+ request SMethod_TextDocumentDocumentSymbol $+ DocumentSymbolParams Nothing Nothing doc liftIO $ print rsp -- Or use one of the helper functions getDocumentSymbols doc >>= liftIO . print-
func-test/FuncTest.hs view
@@ -1,25 +1,27 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs, OverloadedStrings #-}+ module Main where -import Language.LSP.Server-import qualified Language.LSP.Test as Test-import Language.LSP.Protocol.Types-import qualified Language.LSP.Protocol.Lens as L-import Language.LSP.Protocol.Message +import Colog.Core qualified as L+import Control.Applicative.Combinators+import Control.Exception+import Control.Lens hiding (Iso, List)+import Control.Monad import Control.Monad.IO.Class+import Data.Maybe+import Language.LSP.Protocol.Lens qualified as L+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types+import Language.LSP.Server+import Language.LSP.Test qualified as Test+import System.Exit import System.IO-import Control.Monad import System.Process-import Control.Applicative.Combinators-import Control.Lens hiding (List, Iso) import Test.Hspec-import Data.Maybe import UnliftIO import UnliftIO.Concurrent-import Control.Exception-import System.Exit-import qualified Colog.Core as L main :: IO () main = hspec $ do@@ -28,42 +30,44 @@ it "sends end notification if thread is killed" $ do (hinRead, hinWrite) <- createPipe (houtRead, houtWrite) <- createPipe- + killVar <- newEmptyMVar - let definition = ServerDefinition- { parseConfig = const $ const $ Right ()- , onConfigChange = const $ pure ()- , defaultConfig = ()- , configSection = "demo"- , doInitialize = \env _req -> pure $ Right env- , staticHandlers = \_caps -> handlers killVar- , interpretHandler = \env -> Iso (runLspT env) liftIO- , options = defaultOptions- }+ let definition =+ ServerDefinition+ { parseConfig = const $ const $ Right ()+ , onConfigChange = const $ pure ()+ , defaultConfig = ()+ , configSection = "demo"+ , doInitialize = \env _req -> pure $ Right env+ , staticHandlers = \_caps -> handlers killVar+ , interpretHandler = \env -> Iso (runLspT env) liftIO+ , options = defaultOptions+ } handlers :: MVar () -> Handlers (LspM ()) handlers killVar = notificationHandler SMethod_Initialized $ \noti -> do tid <- withRunInIO $ \runInIO ->- forkIO $ runInIO $- withProgress "Doing something" NotCancellable $ \updater ->- liftIO $ threadDelay (1 * 1000000)+ forkIO $+ runInIO $+ withProgress "Doing something" NotCancellable $ \updater ->+ liftIO $ threadDelay (1 * 1000000) liftIO $ void $ forkIO $ do takeMVar killVar killThread tid- + forkIO $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite definition- + Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do -- First make sure that we get a $/progress begin notification skipManyTill Test.anyMessage $ do 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 SMethod_Progress@@ -73,53 +77,56 @@ it "keeps track of open workspace folders" $ do (hinRead, hinWrite) <- createPipe (houtRead, houtWrite) <- createPipe- + countVar <- newMVar 0 let wf0 = WorkspaceFolder (filePathToUri "one") "Starter workspace" wf1 = WorkspaceFolder (filePathToUri "/foo/bar") "My workspace" wf2 = WorkspaceFolder (filePathToUri "/foo/baz") "My other workspace"- - definition = ServerDefinition- { parseConfig = const $ const $ Right ()- , onConfigChange = const $ pure ()- , defaultConfig = ()- , configSection = "demo"- , doInitialize = \env _req -> pure $ Right env- , staticHandlers = \_caps -> handlers- , interpretHandler = \env -> Iso (runLspT env) liftIO- , options = defaultOptions- } + definition =+ ServerDefinition+ { parseConfig = const $ const $ Right ()+ , onConfigChange = const $ pure ()+ , defaultConfig = ()+ , configSection = "demo"+ , doInitialize = \env _req -> pure $ Right env+ , staticHandlers = \_caps -> handlers+ , interpretHandler = \env -> Iso (runLspT env) liftIO+ , options = defaultOptions+ }+ handlers :: Handlers (LspM ())- handlers = mconcat- [ notificationHandler SMethod_Initialized $ \noti -> do- wfs <- fromJust <$> getWorkspaceFolders- liftIO $ wfs `shouldContain` [wf0]- , notificationHandler SMethod_WorkspaceDidChangeWorkspaceFolders $ \noti -> do- i <- liftIO $ modifyMVar countVar (\i -> pure (i + 1, i))- wfs <- fromJust <$> getWorkspaceFolders- liftIO $ case i of- 0 -> do- wfs `shouldContain` [wf1]- wfs `shouldContain` [wf0]- 1 -> do- wfs `shouldNotContain` [wf1]- wfs `shouldContain` [wf0]- wfs `shouldContain` [wf2]- _ -> error "Shouldn't be here"- ]- + handlers =+ mconcat+ [ notificationHandler SMethod_Initialized $ \noti -> do+ wfs <- fromJust <$> getWorkspaceFolders+ liftIO $ wfs `shouldContain` [wf0]+ , notificationHandler SMethod_WorkspaceDidChangeWorkspaceFolders $ \noti -> do+ i <- liftIO $ modifyMVar countVar (\i -> pure (i + 1, i))+ wfs <- fromJust <$> getWorkspaceFolders+ liftIO $ case i of+ 0 -> do+ wfs `shouldContain` [wf1]+ wfs `shouldContain` [wf0]+ 1 -> do+ wfs `shouldNotContain` [wf1]+ wfs `shouldContain` [wf0]+ wfs `shouldContain` [wf2]+ _ -> error "Shouldn't be here"+ ]+ server <- async $ void $ runServerWithHandles logger (L.hoistLogAction liftIO logger) hinRead houtWrite definition- - let config = Test.defaultConfig- { Test.initialWorkspaceFolders = Just [wf0]- }- ++ let config =+ Test.defaultConfig+ { Test.initialWorkspaceFolders = Just [wf0]+ }+ changeFolders add rmv = let ev = WorkspaceFoldersChangeEvent add rmv ps = DidChangeWorkspaceFoldersParams ev- in Test.sendNotification SMethod_WorkspaceDidChangeWorkspaceFolders ps+ in Test.sendNotification SMethod_WorkspaceDidChangeWorkspaceFolders ps Test.runSessionWithHandles hinWrite houtRead config Test.fullCaps "." $ do changeFolders [wf1] []@@ -127,4 +134,3 @@ Left e <- waitCatch server fromException e `shouldBe` Just ExitSuccess-
lsp-test.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: lsp-test-version: 0.16.0.0+version: 0.16.0.1 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against@@ -34,6 +34,7 @@ library hs-source-dirs: src default-language: Haskell2010+ default-extensions: ImportQualifiedPost exposed-modules: Language.LSP.Test reexported-modules: lsp-types:Language.LSP.Protocol.Types@@ -60,8 +61,8 @@ , Glob >=0.9 && <0.11 , lens , lens-aeson- , lsp ^>=2.2- , lsp-types ^>=2.0+ , lsp ^>=2.3+ , lsp-types ^>=2.1 , mtl <2.4 , parser-combinators >=1.2 , process >=1.6@@ -92,6 +93,7 @@ hs-source-dirs: test main-is: Test.hs default-language: Haskell2010+ default-extensions: ImportQualifiedPost ghc-options: -W other-modules: DummyServer build-depends:@@ -103,7 +105,7 @@ , filepath , hspec , lens- , lsp ^>=2.2+ , lsp ^>=2.3 , lsp-test , mtl <2.4 , parser-combinators@@ -116,6 +118,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: func-test default-language: Haskell2010+ default-extensions: ImportQualifiedPost main-is: FuncTest.hs build-depends: , base@@ -133,6 +136,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: example default-language: Haskell2010+ default-extensions: ImportQualifiedPost main-is: Test.hs build-depends: , base@@ -144,6 +148,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: bench default-language: Haskell2010+ default-extensions: ImportQualifiedPost main-is: SimpleBench.hs ghc-options: -Wall -O2 -eventlog -rtsopts build-depends:
src/Language/LSP/Test.hs view
@@ -1,15 +1,15 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeInType #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-} -{-|+{- | Module : Language.LSP.Test Description : A functional testing framework for LSP servers. Maintainer : luke_lau@icloud.com@@ -20,223 +20,279 @@ <https://github.com/Microsoft/language-server-protocol Language Server Protocol servers>. You should import "Language.LSP.Types" alongside this. -}-module Language.LSP.Test- (+module Language.LSP.Test ( -- * Sessions- Session- , runSession- , runSessionWithConfig- , runSessionWithConfigCustomProcess- , runSessionWithHandles- , runSessionWithHandles'- , setIgnoringLogNotifications- , setIgnoringConfigurationRequests+ Session,+ runSession,+ runSessionWithConfig,+ runSessionWithConfigCustomProcess,+ runSessionWithHandles,+ runSessionWithHandles',+ setIgnoringLogNotifications,+ setIgnoringConfigurationRequests,+ -- ** Config- , SessionConfig(..)- , defaultConfig- , C.fullCaps+ SessionConfig (..),+ defaultConfig,+ C.fullCaps,+ -- ** Exceptions- , module Language.LSP.Test.Exceptions- , withTimeout+ module Language.LSP.Test.Exceptions,+ withTimeout,+ -- * Sending- , request- , request_- , sendRequest- , sendNotification- , sendResponse+ request,+ request_,+ sendRequest,+ sendNotification,+ sendResponse,+ -- * Receiving- , module Language.LSP.Test.Parsing+ module Language.LSP.Test.Parsing,+ -- * Utilities+ -- | Quick helper functions for common tasks. -- ** Initialization- , initializeResponse+ initializeResponse,+ -- ** Config- , modifyConfig- , setConfig- , modifyConfigSection- , setConfigSection+ modifyConfig,+ setConfig,+ modifyConfigSection,+ setConfigSection,+ -- ** Documents- , createDoc- , openDoc- , closeDoc- , changeDoc- , documentContents- , getDocumentEdit- , getDocUri- , getVersionedDoc+ createDoc,+ openDoc,+ closeDoc,+ changeDoc,+ documentContents,+ getDocumentEdit,+ getDocUri,+ getVersionedDoc,+ -- ** Symbols- , getDocumentSymbols+ getDocumentSymbols,+ -- ** Diagnostics- , waitForDiagnostics- , waitForDiagnosticsSource- , noDiagnostics- , getCurrentDiagnostics- , getIncompleteProgressSessions+ waitForDiagnostics,+ waitForDiagnosticsSource,+ noDiagnostics,+ getCurrentDiagnostics,+ getIncompleteProgressSessions,+ -- ** Commands- , executeCommand+ executeCommand,+ -- ** Code Actions- , getCodeActions- , getAndResolveCodeActions- , getAllCodeActions- , executeCodeAction- , resolveCodeAction- , resolveAndExecuteCodeAction+ getCodeActions,+ getAndResolveCodeActions,+ getAllCodeActions,+ executeCodeAction,+ resolveCodeAction,+ resolveAndExecuteCodeAction,+ -- ** Completions- , getCompletions- , getAndResolveCompletions+ getCompletions,+ getAndResolveCompletions,+ -- ** References- , getReferences+ getReferences,+ -- ** Definitions- , getDeclarations- , getDefinitions- , getTypeDefinitions- , getImplementations+ getDeclarations,+ getDefinitions,+ getTypeDefinitions,+ getImplementations,+ -- ** Renaming- , rename+ rename,+ -- ** Hover- , getHover+ getHover,+ -- ** Highlights- , getHighlights+ getHighlights,+ -- ** Formatting- , formatDoc- , formatRange+ formatDoc,+ formatRange,+ -- ** Edits- , applyEdit+ applyEdit,+ -- ** Code lenses- , getCodeLenses- , getAndResolveCodeLenses- , resolveCodeLens+ getCodeLenses,+ getAndResolveCodeLenses,+ resolveCodeLens,+ -- ** Call hierarchy- , prepareCallHierarchy- , incomingCalls- , outgoingCalls+ prepareCallHierarchy,+ incomingCalls,+ outgoingCalls,+ -- ** SemanticTokens- , getSemanticTokens+ getSemanticTokens,+ -- ** Capabilities- , getRegisteredCapabilities- ) where+ getRegisteredCapabilities,+) where import Control.Applicative.Combinators import Control.Concurrent+import Control.Exception+import Control.Lens hiding (Empty, List, (.=)) import Control.Monad import Control.Monad.IO.Class-import Control.Exception-import Control.Lens hiding ((.=), List, Empty)-import qualified Data.Map.Strict as Map-import qualified Data.Set as Set-import qualified Data.Text as T-import qualified Data.Text.IO as T+import Control.Monad.State (execState) import Data.Aeson hiding (Null)-import qualified Data.Aeson as J+import Data.Aeson qualified as J import Data.Default import Data.List+import Data.Map.Strict qualified as Map import Data.Maybe-import Language.LSP.Protocol.Types+import Data.Set qualified as Set+import Data.String (fromString)+import Data.Text qualified as T+import Data.Text.IO qualified as T+import Data.Traversable (for)+import Language.LSP.Protocol.Capabilities qualified as C+import Language.LSP.Protocol.Lens qualified as L 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.Protocol.Types import Language.LSP.Test.Compat import Language.LSP.Test.Decoding import Language.LSP.Test.Exceptions import Language.LSP.Test.Parsing-import Language.LSP.Test.Session import Language.LSP.Test.Server-import System.Environment-import System.IO+import Language.LSP.Test.Session+import Language.LSP.VFS import System.Directory+import System.Environment import System.FilePath-import System.Process (ProcessHandle, CreateProcess)-import qualified System.FilePath.Glob as Glob-import Control.Monad.State (execState)-import Data.Traversable (for)-import Data.String (fromString)+import System.FilePath.Glob qualified as Glob+import System.IO+import System.Process (CreateProcess, ProcessHandle) --- | Starts a new session.------ > runSession "hie" fullCaps "path/to/root/dir" $ do--- > doc <- openDoc "Desktop/simple.hs" "haskell"--- > diags <- waitForDiagnostics--- > let pos = Position 12 5--- > params = TextDocumentPositionParams doc--- > hover <- request STextdocumentHover params-runSession :: String -- ^ The command to run the server.- -> 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+{- | Starts a new session.++ > runSession "hie" fullCaps "path/to/root/dir" $ do+ > doc <- openDoc "Desktop/simple.hs" "haskell"+ > diags <- waitForDiagnostics+ > let pos = Position 12 5+ > params = TextDocumentPositionParams doc+ > hover <- request STextdocumentHover params+-}+runSession ::+ -- | The command to run the server.+ String ->+ -- | The capabilities that the client should declare.+ ClientCapabilities ->+ -- | The filepath to the root directory for the session.+ FilePath ->+ -- | The session to run.+ Session a ->+ IO a runSession = runSessionWithConfig def -- | Starts a new session with a custom configuration.-runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.- -> String -- ^ The command to run the server.- -> 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+runSessionWithConfig ::+ -- | Configuration options for the session.+ SessionConfig ->+ -- | The command to run the server.+ String ->+ -- | The capabilities that the client should declare.+ ClientCapabilities ->+ -- | The filepath to the root directory for the session.+ FilePath ->+ -- | The session to run.+ Session a ->+ IO a runSessionWithConfig = runSessionWithConfigCustomProcess id -- | Starts a new session with a custom configuration and server 'CreateProcess'.-runSessionWithConfigCustomProcess :: (CreateProcess -> CreateProcess) -- ^ Tweak the 'CreateProcess' used to start the server.- -> SessionConfig -- ^ Configuration options for the session.- -> String -- ^ The command to run the server.- -> 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+runSessionWithConfigCustomProcess ::+ -- | Tweak the 'CreateProcess' used to start the server.+ (CreateProcess -> CreateProcess) ->+ -- | Configuration options for the session.+ SessionConfig ->+ -- | The command to run the server.+ String ->+ -- | The capabilities that the client should declare.+ ClientCapabilities ->+ -- | The filepath to the root directory for the session.+ FilePath ->+ -- | The session to run.+ Session a ->+ IO a runSessionWithConfigCustomProcess modifyCreateProcess config' serverExe caps rootDir session = do config <- envOverrideConfig config' withServer serverExe (logStdErr config) modifyCreateProcess $ \serverIn serverOut serverProc -> runSessionWithHandles' (Just serverProc) serverIn serverOut config caps rootDir session --- | Starts a new session, using the specified handles to communicate with the--- server. You can use this to host the server within the same process.--- An example with lsp might look like:------ > (hinRead, hinWrite) <- createPipe--- > (houtRead, houtWrite) <- createPipe--- >--- > forkIO $ void $ runServerWithHandles hinRead houtWrite serverDefinition--- > runSessionWithHandles hinWrite houtRead defaultConfig fullCaps "." $ do--- > -- ...-runSessionWithHandles :: Handle -- ^ The input handle- -> Handle -- ^ The output handle- -> SessionConfig- -> 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-runSessionWithHandles = runSessionWithHandles' Nothing+{- | Starts a new session, using the specified handles to communicate with the+ server. You can use this to host the server within the same process.+ An example with lsp might look like: + > (hinRead, hinWrite) <- createPipe+ > (houtRead, houtWrite) <- createPipe+ >+ > forkIO $ void $ runServerWithHandles hinRead houtWrite serverDefinition+ > runSessionWithHandles hinWrite houtRead defaultConfig fullCaps "." $ do+ > -- ...+-}+runSessionWithHandles ::+ -- | The input handle+ Handle ->+ -- | The output handle+ Handle ->+ SessionConfig ->+ -- | The capabilities that the client should declare.+ ClientCapabilities ->+ -- | The filepath to the root directory for the session.+ FilePath ->+ -- | The session to run.+ Session a ->+ IO a+runSessionWithHandles = runSessionWithHandles' Nothing -runSessionWithHandles' :: Maybe ProcessHandle- -> Handle -- ^ The input handle- -> Handle -- ^ The output handle- -> SessionConfig- -> 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+runSessionWithHandles' ::+ Maybe ProcessHandle ->+ -- | The input handle+ Handle ->+ -- | The output handle+ Handle ->+ SessionConfig ->+ -- | The capabilities that the client should declare.+ ClientCapabilities ->+ -- | The filepath to the root directory for the session.+ FilePath ->+ -- | The session to run.+ Session a ->+ IO a runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir session = do pid <- getCurrentProcessID absRootDir <- canonicalizePath rootDir config <- envOverrideConfig config' - let initializeParams = InitializeParams Nothing- -- Narrowing to Int32 here, but it's unlikely that a PID will- -- be outside the range- (InL $ fromIntegral pid)- (Just lspTestClientInfo)- (Just $ T.pack absRootDir)- Nothing- (InL $ filePathToUri absRootDir)- caps- -- TODO: make this configurable?- (Just $ Object $ lspConfig config')- (Just TraceValues_Off)- (fmap InL $ initialWorkspaceFolders config)+ let initializeParams =+ InitializeParams+ Nothing+ -- Narrowing to Int32 here, but it's unlikely that a PID will+ -- be outside the range+ (InL $ fromIntegral pid)+ (Just lspTestClientInfo)+ (Just $ T.pack absRootDir)+ Nothing+ (InL $ filePathToUri absRootDir)+ caps+ -- TODO: make this configurable?+ (Just $ Object $ 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 SMethod_Initialize initializeParams@@ -261,12 +317,12 @@ -- Run the actual test session- where- -- | Asks the server to shutdown and exit politely+ where+ -- \| Asks the server to shutdown and exit politely exitServer :: Session () exitServer = request_ SMethod_Shutdown Nothing >> sendNotification SMethod_Exit Nothing - -- | Listens to the server output until the shutdown ACK,+ -- \| Listens to the server output until the shutdown ACK, -- makes sure it matches the record and signals any semaphores listenServer :: Handle -> SessionContext -> IO () listenServer serverOut context = do@@ -278,9 +334,9 @@ case msg of (FromServerRsp SMethod_Shutdown _) -> return ()- _ -> listenServer serverOut context+ _ -> listenServer serverOut context - -- | Is this message allowed to be sent by the server between the intialize+ -- \| 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 ()@@ -295,11 +351,12 @@ envOverrideConfig cfg = do logMessages' <- fromMaybe (logMessages cfg) <$> checkEnv "LSP_TEST_LOG_MESSAGES" logStdErr' <- fromMaybe (logStdErr cfg) <$> checkEnv "LSP_TEST_LOG_STDERR"- return $ cfg { logMessages = logMessages', logStdErr = logStdErr' }- where checkEnv :: String -> IO (Maybe Bool)- checkEnv s = fmap convertVal <$> lookupEnv s- convertVal "0" = False- convertVal _ = True+ return $ cfg{logMessages = logMessages', logStdErr = logStdErr'}+ where+ checkEnv :: String -> IO (Maybe Bool)+ checkEnv s = fmap convertVal <$> lookupEnv s+ convertVal "0" = False+ convertVal _ = True -- | The current text contents of a document. documentContents :: TextDocumentIdentifier -> Session T.Text@@ -308,33 +365,36 @@ 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+{- | 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 SMethod_WorkspaceApplyEdit unless (checkDocumentChanges req || checkChanges req) $- liftIO $ throw (IncorrectApplyEditRequest (show req))+ liftIO $+ throw (IncorrectApplyEditRequest (show req)) documentContents doc- where- checkDocumentChanges req =- let changes = req ^. L.params . L.edit . L.documentChanges- maybeDocs = fmap (fmap documentChangeUri) changes- in case maybeDocs of- Just docs -> (doc ^. L.uri) `elem` docs- Nothing -> False- checkChanges req =- let mMap = req ^. L.params . L.edit . L.changes- in maybe False (Map.member (doc ^. L.uri)) mMap+ where+ checkDocumentChanges req =+ let changes = req ^. L.params . L.edit . L.documentChanges+ maybeDocs = fmap (fmap documentChangeUri) changes+ in case maybeDocs of+ Just docs -> (doc ^. L.uri) `elem` docs+ Nothing -> False+ checkChanges req =+ 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--- @--- rsp <- request STextDocumentDocumentSymbol params--- @--- Note: will skip any messages in between the request and the response.+{- | Sends a request to the server and waits for its response.+ Will skip any messages in between the request and the response+ @+ rsp <- request STextDocumentDocumentSymbol params+ @+ Note: will skip any messages in between the request and the response.+-} request :: SClientMethod m -> MessageParams m -> Session (TResponseMessage m) request m = sendRequest m >=> skipManyTill anyMessage . responseForId m @@ -343,21 +403,25 @@ request_ p = void . request p -- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.-sendRequest- :: SClientMethod m -- ^ The request method.- -> MessageParams m -- ^ The request parameters.- -> Session (LspId m) -- ^ The id of the request that was sent.+sendRequest ::+ -- | The request method.+ SClientMethod m ->+ -- | The request parameters.+ MessageParams m ->+ -- | The id of the request that was sent.+ Session (LspId m) sendRequest method params = do idn <- curReqId <$> get- modify $ \c -> c { curReqId = idn+1 }+ modify $ \c -> c{curReqId = idn + 1} let id = IdInt idn let mess = TRequestMessage "2.0" id method params -- Update the request map reqMap <- requestMap <$> ask- liftIO $ modifyMVar_ reqMap $- \r -> return $ fromJust $ updateRequestMap r id method+ liftIO $+ modifyMVar_ reqMap $+ \r -> return $ fromJust $ updateRequestMap r id method ~() <- case splitClientMethod method of IsClientReq -> sendMessage mess@@ -366,15 +430,18 @@ return id -- | Sends a notification to the server.-sendNotification :: SClientMethod (m :: Method ClientToServer Notification) -- ^ The notification method.- -> MessageParams m -- ^ The notification parameters.- -> Session ()+sendNotification ::+ -- | The notification method.+ SClientMethod (m :: Method ClientToServer Notification) ->+ -- | The notification parameters.+ MessageParams m ->+ Session () -- Open a virtual file if we send a did open text document notification 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 })+ modify (\s -> s{vfs = newVFS}) sendMessage n -- Close a virtual file if we send a close text document notification@@ -382,16 +449,14 @@ let n = TNotificationMessage "2.0" SMethod_TextDocumentDidClose params oldVFS <- vfs <$> get let newVFS = flip execState oldVFS $ closeVFS mempty n- modify (\s -> s { vfs = newVFS })+ modify (\s -> s{vfs = newVFS}) sendMessage n- 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 })+ modify (\s -> s{vfs = newVFS}) sendMessage n- sendNotification method params = case splitClientMethod method of IsClientNot -> sendMessage (TNotificationMessage "2.0" method params)@@ -401,27 +466,29 @@ 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.+{- | 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 (TResponseMessage Method_Initialize) initializeResponse = ask >>= (liftIO . readMVar) . initRsp setIgnoringLogNotifications :: Bool -> Session () setIgnoringLogNotifications value = do- modify (\ss -> ss { ignoringLogNotifications = value })+ modify (\ss -> ss{ignoringLogNotifications = value}) setIgnoringConfigurationRequests :: Bool -> Session () setIgnoringConfigurationRequests value = do- modify (\ss -> ss { ignoringConfigurationRequests = value })+ modify (\ss -> ss{ignoringConfigurationRequests = value}) --- | Modify the client config. This will send a notification to the server that the--- config has changed.+{- | Modify the client config. This will send a notification to the server that the+ config has changed.+-} modifyConfig :: (Object -> Object) -> Session () modifyConfig f = do oldConfig <- curLspConfig <$> get let newConfig = f oldConfig- modify (\ss -> ss { curLspConfig = newConfig })+ modify (\ss -> ss{curLspConfig = newConfig}) caps <- asks sessionCapabilities let supportsConfiguration = fromMaybe False $ caps ^? L.workspace . _Just . L.configuration . _Just@@ -431,34 +498,43 @@ configToSend = if supportsConfiguration then J.Null else Object newConfig sendNotification SMethod_WorkspaceDidChangeConfiguration $ DidChangeConfigurationParams configToSend --- | Set the client config. This will send a notification to the server that the--- config has changed.+{- | Set the client config. This will send a notification to the server that the+ config has changed.+-} setConfig :: Object -> Session () setConfig newConfig = modifyConfig (const newConfig) --- | Modify a client config section (if already present, otherwise does nothing).--- This will send a notification to the server that the config has changed.+{- | Modify a client config section (if already present, otherwise does nothing).+ This will send a notification to the server that the config has changed.+-} modifyConfigSection :: String -> (Value -> Value) -> Session () modifyConfigSection section f = modifyConfig (\o -> o & ix (fromString section) %~ f) --- | Set a client config section. This will send a notification to the server that the--- config has changed.+{- | Set a client config section. This will send a notification to the server that the+ config has changed.+-} setConfigSection :: String -> Value -> Session ()-setConfigSection section settings = modifyConfig (\o -> o & at(fromString section) ?~ settings)+setConfigSection section settings = modifyConfig (\o -> o & at (fromString section) ?~ settings) --- | /Creates/ a new text document. This is different from 'openDoc'--- as it sends a workspace/didChangeWatchedFiles notification letting the server--- know that a file was created within the workspace, __provided that the server--- has registered for it__, and the file matches any patterns the server--- registered for.--- It /does not/ actually create a file on disk, but is useful for convincing--- the server that one does exist.------ @since 11.0.0.0-createDoc :: FilePath -- ^ The path to the document to open, __relative to the root directory__.- -> T.Text -- ^ The text document's language identifier, e.g. @"haskell"@.- -> T.Text -- ^ The content of the text document to create.- -> Session TextDocumentIdentifier -- ^ The identifier of the document just created.+{- | /Creates/ a new text document. This is different from 'openDoc'+ as it sends a workspace/didChangeWatchedFiles notification letting the server+ know that a file was created within the workspace, __provided that the server+ has registered for it__, and the file matches any patterns the server+ registered for.+ It /does not/ actually create a file on disk, but is useful for convincing+ the server that one does exist.++ @since 11.0.0.0+-}+createDoc ::+ -- | The path to the document to open, __relative to the root directory__.+ FilePath ->+ -- | The text document's language identifier, e.g. @"haskell"@.+ T.Text ->+ -- | The content of the text document to create.+ T.Text ->+ -- | The identifier of the document just created.+ Session TextDocumentIdentifier createDoc file languageId contents = do dynCaps <- curDynCaps <$> get rootDir <- asks rootDir@@ -476,26 +552,29 @@ watchHits _ = False fileMatches pattern = Glob.match (Glob.compile pattern) relOrAbs+ where -- If the pattern is absolute then match against the absolute fp- where relOrAbs- | isAbsolute pattern = absFile- | otherwise = file+ relOrAbs+ | isAbsolute pattern = absFile+ | otherwise = file regHits :: TRegistration Method_WorkspaceDidChangeWatchedFiles -> Bool regHits reg = foldl' (\acc w -> acc || watchHits w) False (reg ^. L.registerOptions . _Just . L.watchers) clientCapsSupports =- caps ^? L.workspace . _Just . L.didChangeWatchedFiles . _Just . L.dynamicRegistration . _Just- == Just True+ 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 SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $- [ FileEvent (filePathToUri (rootDir </> file)) FileChangeType_Created ]+ 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--- textDocument/didOpen notification to the server.+{- | Opens a text document that /exists on disk/, and sends a+ textDocument/didOpen notification to the server.+-} openDoc :: FilePath -> T.Text -> Session TextDocumentIdentifier openDoc file languageId = do context <- ask@@ -503,8 +582,9 @@ contents <- liftIO $ T.readFile fp openDoc' file languageId contents --- | This is a variant of `openDoc` that takes the file content as an argument.--- Use this is the file exists /outside/ of the current workspace.+{- | This is a variant of `openDoc` that takes the file content as an argument.+ Use this is the file exists /outside/ of the current workspace.+-} openDoc' :: FilePath -> T.Text -> T.Text -> Session TextDocumentIdentifier openDoc' file languageId contents = do context <- ask@@ -541,8 +621,9 @@ let diags = diagsNot ^. L.params . L.diagnostics return diags --- | The same as 'waitForDiagnostics', but will only match a specific--- 'Language.LSP.Types._source'.+{- | The same as 'waitForDiagnostics', but will only match a specific+ 'Language.LSP.Types._source'.+-} waitForDiagnosticsSource :: String -> Session [Diagnostic] waitForDiagnosticsSource src = do diags <- waitForDiagnostics@@ -550,13 +631,14 @@ if null res then waitForDiagnosticsSource src else return res- where- matches :: Diagnostic -> Bool- matches d = d ^. L.source == Just (T.pack src)+ where+ matches :: Diagnostic -> Bool+ matches d = d ^. L.source == Just (T.pack src) --- | Expects a 'PublishDiagnosticsNotification' and throws an--- 'UnexpectedDiagnostics' exception if there are any diagnostics--- returned.+{- | Expects a 'PublishDiagnosticsNotification' and throws an+ 'UnexpectedDiagnostics' exception if there are any diagnostics+ returned.+-} noDiagnostics :: Session () noDiagnostics = do diagsNot <- message SMethod_TextDocumentPublishDiagnostics@@ -583,51 +665,52 @@ Right (InR _) -> return [] Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error) --- | Returns the code actions in the specified range, resolving any with --- a non empty _data_ field.+{- | Returns the code actions in the specified range, resolving any with+ a non empty _data_ field.+-} getAndResolveCodeActions :: TextDocumentIdentifier -> Range -> Session [Command |? CodeAction] getAndResolveCodeActions doc range = do items <- getCodeActions doc range- for items $ \case + for items $ \case l@(InL _) -> pure l- (InR r) | isJust (r ^. L.data_) -> InR <$> resolveCodeAction r+ (InR r) | isJust (r ^. L.data_) -> InR <$> resolveCodeAction r r@(InR _) -> pure r --- | Returns all the code actions in a document by--- querying the code actions at each of the current--- diagnostics' positions.+{- | Returns all the code actions in a document by+ querying the code actions at each of the current+ diagnostics' positions.+-} getAllCodeActions :: TextDocumentIdentifier -> Session [Command |? CodeAction] getAllCodeActions doc = do ctx <- getCodeActionContext doc foldM (go ctx) [] =<< getCurrentDiagnostics doc-- where- go :: CodeActionContext -> [Command |? CodeAction] -> Diagnostic -> Session [Command |? CodeAction]- go ctx acc diag = do- TResponseMessage _ rspLid res <- request SMethod_TextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. L.range) ctx)+ where+ go :: CodeActionContext -> [Command |? CodeAction] -> Diagnostic -> Session [Command |? CodeAction]+ go ctx acc diag = do+ 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 (InL cmdOrCAs) -> pure (acc ++ cmdOrCAs)- Right (InR _) -> pure acc+ case res of+ Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e)+ Right (InL cmdOrCAs) -> pure (acc ++ cmdOrCAs)+ Right (InR _) -> pure acc getCodeActionContextInRange :: TextDocumentIdentifier -> Range -> Session CodeActionContext getCodeActionContextInRange doc caRange = do curDiags <- getCurrentDiagnostics doc- let diags = [ d | d@Diagnostic{_range=range} <- curDiags- , overlappingRange caRange range- ]+ let diags =+ [ d | d@Diagnostic{_range = range} <- curDiags, overlappingRange caRange range+ ] return $ CodeActionContext diags Nothing Nothing- where- overlappingRange :: Range -> Range -> Bool- overlappingRange (Range s e) range =- positionInRange s range+ where+ overlappingRange :: Range -> Range -> Bool+ overlappingRange (Range s e) range =+ positionInRange s range || positionInRange e range - positionInRange :: Position -> Range -> Bool- positionInRange (Position pl po) (Range (Position sl so) (Position el eo)) =- pl > sl && pl < el+ positionInRange :: Position -> Range -> Bool+ positionInRange (Position pl po) (Range (Position sl so) (Position el eo)) =+ pl > sl && pl < el || pl == sl && pl == el && po >= so && po <= eo || pl == sl && po >= so || pl == el && po <= eo@@ -637,8 +720,9 @@ curDiags <- getCurrentDiagnostics doc 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.+{- | 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 ^. L.uri) . curDiagnostics <$> get @@ -653,20 +737,21 @@ execParams = ExecuteCommandParams Nothing (cmd ^. L.command) args void $ sendRequest SMethod_WorkspaceExecuteCommand execParams --- | Executes a code action.--- Matching with the specification, if a code action--- contains both an edit and a command, the edit will--- be applied first.+{- | Executes a code action.+ Matching with the specification, if a code action+ contains both an edit and a command, the edit will+ be applied first.+-} executeCodeAction :: CodeAction -> Session () executeCodeAction action = do 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 = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e)- in updateState (FromServerMess SMethod_WorkspaceApplyEdit req)+ where+ handleEdit :: WorkspaceEdit -> Session ()+ handleEdit e =+ -- Its ok to pass in dummy parameters here as they aren't used+ let req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e)+ in updateState (FromServerMess SMethod_WorkspaceApplyEdit req) -- |Resolves the provided code action. resolveCodeAction :: CodeAction -> Session CodeAction@@ -676,10 +761,11 @@ Right ca -> return ca Left er -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) er) --- |If a code action contains a _data_ field: resolves the code action, then --- executes it. Otherwise, just executes it.+{- |If a code action contains a _data_ field: resolves the code action, then+ executes it. Otherwise, just executes it.+-} resolveAndExecuteCodeAction :: CodeAction -> Session ()-resolveAndExecuteCodeAction ca@CodeAction{_data_=Just _} = do+resolveAndExecuteCodeAction ca@CodeAction{_data_ = Just _} = do caRsp <- resolveCodeAction ca executeCodeAction caRsp resolveAndExecuteCodeAction ca = executeCodeAction ca@@ -696,20 +782,20 @@ -- | Applys an edit to the document and returns the updated document version. applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier applyEdit doc edit = do- verDoc <- getVersionedDoc doc caps <- asks sessionCapabilities let supportsDocChanges = fromMaybe False $ caps ^? L.workspace . _Just . L.workspaceEdit . _Just . L.documentChanges . _Just - let wEdit = if supportsDocChanges- then- let docEdit = TextDocumentEdit (review _versionedTextDocumentIdentifier verDoc) [InL edit]- in WorkspaceEdit Nothing (Just [InL docEdit]) Nothing- else- let changes = Map.singleton (doc ^. L.uri) [edit]- in WorkspaceEdit (Just changes) Nothing Nothing+ let wEdit =+ if supportsDocChanges+ then+ let docEdit = TextDocumentEdit (review _versionedTextDocumentIdentifier verDoc) [InL edit]+ in WorkspaceEdit Nothing (Just [InL docEdit]) Nothing+ else+ let changes = Map.singleton (doc ^. L.uri) [edit]+ in WorkspaceEdit (Just changes) Nothing Nothing let req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) updateState (FromServerMess SMethod_WorkspaceApplyEdit req)@@ -727,8 +813,9 @@ InR (InL c) -> return $ c ^. L.items InR (InR _) -> return [] --- | Returns the completions for the position in the document, resolving any with --- a non empty _data_ field.+{- | Returns the completions for the position in the document, resolving any with+ a non empty _data_ field.+-} getAndResolveCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem] getAndResolveCompletions doc pos = do items <- getCompletions doc pos@@ -743,43 +830,60 @@ Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error) -- | 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 [Location] -- ^ The locations of the references.+getReferences ::+ -- | The document to lookup in.+ TextDocumentIdentifier ->+ -- | The position to lookup.+ Position ->+ -- | Whether to include declarations as references.+ Bool ->+ -- | The locations of the references.+ Session [Location] getReferences doc pos inclDecl = let ctx = ReferenceContext inclDecl params = ReferenceParams doc pos Nothing Nothing ctx- in absorbNull . getResponseResult <$> request SMethod_TextDocumentReferences 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 (Declaration |? [DeclarationLink] |? Null)+getDeclarations ::+ -- | The document the term is in.+ TextDocumentIdentifier ->+ -- | The position the term is at.+ Position ->+ 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 (Definition |? [DefinitionLink] |? Null)+getDefinitions ::+ -- | The document the term is in.+ TextDocumentIdentifier ->+ -- | The position the term is at.+ Position ->+ 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 (Definition |? [DefinitionLink] |? Null)+getTypeDefinitions ::+ -- | The document the term is in.+ TextDocumentIdentifier ->+ -- | The position the term is at.+ Position ->+ 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 (Definition |? [DefinitionLink] |? Null)+getImplementations ::+ -- | The document the term is in.+ TextDocumentIdentifier ->+ -- | The position the term is at.+ Position ->+ Session (Definition |? [DefinitionLink] |? Null) getImplementations doc pos = do rsp <- request SMethod_TextDocumentImplementation (ImplementationParams doc pos Nothing Nothing) pure $ getResponseResult rsp@@ -800,16 +904,17 @@ getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover) getHover doc pos = let params = HoverParams doc pos Nothing- in nullToMaybe . getResponseResult <$> request SMethod_TextDocumentHover params+ in nullToMaybe . getResponseResult <$> request SMethod_TextDocumentHover params -- | Returns the highlighted occurrences of the term at the specified position getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight] getHighlights doc pos = let params = DocumentHighlightParams doc pos Nothing Nothing- in absorbNull . getResponseResult <$> request SMethod_TextDocumentDocumentHighlight params+ in absorbNull . getResponseResult <$> request SMethod_TextDocumentDocumentHighlight params --- | Checks the response for errors and throws an exception if needed.--- Returns the result if successful.+{- | Checks the response for errors and throws an exception if needed.+ Returns the result if successful.+-} getResponseResult :: (ToJSON (ErrorData m)) => TResponseMessage m -> MessageResult m getResponseResult rsp = case rsp ^. L.result of@@ -835,20 +940,21 @@ let wEdit = WorkspaceEdit (Just (Map.singleton (doc ^. L.uri) edits)) Nothing Nothing -- Send a dummy message to updateState so it can do bookkeeping req = TRequestMessage "" (IdInt 0) SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)- in updateState (FromServerMess SMethod_WorkspaceApplyEdit req)+ in updateState (FromServerMess SMethod_WorkspaceApplyEdit req) -- | Returns the code lenses for the specified document. getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] getCodeLenses tId = do- rsp <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing tId)- pure $ absorbNull $ getResponseResult rsp+ rsp <- request SMethod_TextDocumentCodeLens (CodeLensParams Nothing Nothing tId)+ pure $ absorbNull $ getResponseResult rsp --- | Returns the code lenses for the specified document, resolving any with --- a non empty _data_ field.+{- | Returns the code lenses for the specified document, resolving any with+ a non empty _data_ field.+-} getAndResolveCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] getAndResolveCodeLenses tId = do- codeLenses <- getCodeLenses tId- for codeLenses $ \codeLens -> if isJust (codeLens ^. L.data_) then resolveCodeLens codeLens else pure codeLens+ codeLenses <- getCodeLenses tId+ for codeLenses $ \codeLens -> if isJust (codeLens ^. L.data_) then resolveCodeLens codeLens else pure codeLens -- |Resolves the provided code lens. resolveCodeLens :: CodeLens -> Session CodeLens@@ -869,11 +975,12 @@ outgoingCalls = resolveRequestWithListResp SMethod_CallHierarchyOutgoingCalls -- | Send a request and receive a response with list.-resolveRequestWithListResp :: forall (m :: Method ClientToServer Request) a- . (ToJSON (ErrorData m), MessageResult m ~ ([a] |? Null))- => SMethod 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 pure $ absorbNull $ getResponseResult rsp@@ -885,9 +992,10 @@ rsp <- request SMethod_TextDocumentSemanticTokensFull params pure $ getResponseResult rsp --- | Returns a list of capabilities that the server has requested to /dynamically/--- register during the 'Session'.------ @since 0.11.0.0+{- | Returns a list of capabilities that the server has requested to /dynamically/+ register during the 'Session'.++ @since 0.11.0.0+-} getRegisteredCapabilities :: Session [SomeRegistration] getRegisteredCapabilities = Map.elems . curDynCaps <$> get
src/Language/LSP/Test/Compat.hs view
@@ -1,17 +1,18 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-} {-# 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 Data.Row+import Data.Text qualified as T import System.IO #if MIN_VERSION_process(1,6,3)@@ -44,7 +45,6 @@ import qualified System.Posix.Process #endif - getCurrentProcessID :: IO Int #ifdef mingw32_HOST_OS getCurrentProcessID = fromIntegral <$> System.Win32.Process.getCurrentProcessId@@ -54,7 +54,7 @@ getProcessID :: ProcessHandle -> IO Int getProcessID p = fromIntegral . fromJust <$> getProcessID' p- where+ where #if MIN_VERSION_process(1,6,3) getProcessID' = System.Process.getPid #else@@ -75,13 +75,12 @@ _ -> return Nothing #endif -cleanupProcess- :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()--withCreateProcess- :: CreateProcess- -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)- -> IO a+cleanupProcess ::+ (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()+withCreateProcess ::+ CreateProcess ->+ (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) ->+ IO a #if MIN_VERSION_process(1,6,4)
src/Language/LSP/Test/Decoding.hs view
@@ -1,55 +1,59 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeInType #-}+ module Language.LSP.Test.Decoding where -import Prelude hiding ( id )-import Data.Aeson-import Data.Aeson.Types-import Data.Foldable-import Data.Functor.Product-import Data.Functor.Const-import Control.Exception-import Control.Lens-import qualified Data.ByteString.Lazy.Char8 as B-import Data.Maybe-import System.IO-import System.IO.Error-import Language.LSP.Protocol.Message-import qualified Language.LSP.Protocol.Lens as L-import Language.LSP.Test.Exceptions+import Control.Exception+import Control.Lens+import Data.Aeson+import Data.Aeson.Types+import Data.ByteString.Lazy.Char8 qualified as B+import Data.Foldable+import Data.Functor.Const+import Data.Functor.Product+import Data.Maybe+import Language.LSP.Protocol.Lens qualified as L+import Language.LSP.Protocol.Message+import Language.LSP.Test.Exceptions+import System.IO+import System.IO.Error+import Prelude hiding (id) import Data.IxMap import Data.Kind --- | Fetches the next message bytes based on--- the Content-Length header+{- | Fetches the next message bytes based on+ the Content-Length header+-} getNextMessage :: Handle -> IO B.ByteString getNextMessage h = do headers <- getHeaders h case read . init <$> lookup "Content-Length" headers of- Nothing -> throw NoContentLengthHeader+ Nothing -> throw NoContentLengthHeader Just size -> B.hGet h size addHeader :: B.ByteString -> B.ByteString-addHeader content = B.concat- [ "Content-Length: "- , B.pack $ show $ B.length content- , "\r\n"- , "\r\n"- , content- ]+addHeader content =+ B.concat+ [ "Content-Length: "+ , B.pack $ show $ B.length content+ , "\r\n"+ , "\r\n"+ , content+ ] getHeaders :: Handle -> IO [(String, String)] getHeaders h = do l <- catch (hGetLine h) eofHandler let (name, val) = span (/= ':') l if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h- where eofHandler e- | isEOFError e = throw UnexpectedServerTermination- | otherwise = throw e+ where+ eofHandler e+ | isEOFError e = throw UnexpectedServerTermination+ | otherwise = throw e -type RequestMap = IxMap LspId (SMethod :: Method ClientToServer Request -> Type )+type RequestMap = IxMap LspId (SMethod :: Method ClientToServer Request -> Type) newRequestMap :: RequestMap newRequestMap = emptyIxMap@@ -72,22 +76,24 @@ decodeFromServerMsg :: RequestMap -> B.ByteString -> (RequestMap, FromServerMessage) decodeFromServerMsg reqMap bytes = unP $ parse p obj- where obj = fromJust $ decode bytes :: Value- p = parseServerMessage $ \lid ->- let (mm, newMap) = pickFromIxMap lid reqMap- in case mm of- Nothing -> Nothing- Just m -> Just $ (m, Pair m (Const newMap))- unP (Success (FromServerMess m msg)) = (reqMap, FromServerMess m msg)- unP (Success (FromServerRsp (Pair m (Const newMap)) msg)) = (newMap, FromServerRsp m msg)- unP (Error e) = error $ "Error decoding " <> show obj <> " :" <> e- {-- WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet"- WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet"- CustomServerMethod _- | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes- | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes- | otherwise -> NotCustomServer $ fromJust $ decode bytes+ where+ obj = fromJust $ decode bytes :: Value+ p = parseServerMessage $ \lid ->+ let (mm, newMap) = pickFromIxMap lid reqMap+ in case mm of+ Nothing -> Nothing+ Just m -> Just $ (m, Pair m (Const newMap))+ unP (Success (FromServerMess m msg)) = (reqMap, FromServerMess m msg)+ unP (Success (FromServerRsp (Pair m (Const newMap)) msg)) = (newMap, FromServerRsp m msg)+ unP (Error e) = error $ "Error decoding " <> show obj <> " :" <> e - Error e -> error e- -}+{-+ WorkspaceWorkspaceFolders -> error "ReqWorkspaceFolders not supported yet"+ WorkspaceConfiguration -> error "ReqWorkspaceConfiguration not supported yet"+ CustomServerMethod _+ | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes+ | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes+ | otherwise -> NotCustomServer $ fromJust $ decode bytes++Error e -> error e+-}
src/Language/LSP/Test/Exceptions.hs view
@@ -1,59 +1,75 @@ module Language.LSP.Test.Exceptions where import Control.Exception-import Language.LSP.Protocol.Message import Data.Aeson import Data.Aeson.Encode.Pretty import Data.Algorithm.Diff import Data.Algorithm.DiffOutput+import Data.ByteString.Lazy.Char8 qualified as B import Data.List-import qualified Data.ByteString.Lazy.Char8 as B+import Language.LSP.Protocol.Message -- | An exception that can be thrown during a 'Haskell.LSP.Test.Session.Session'-data SessionException = Timeout (Maybe FromServerMessage)- | NoContentLengthHeader- | UnexpectedMessage String FromServerMessage- | ReplayOutOfOrder FromServerMessage [FromServerMessage]- | UnexpectedDiagnostics- | IncorrectApplyEditRequest String- | UnexpectedResponseError SomeLspId ResponseError- | UnexpectedServerTermination- | IllegalInitSequenceMessage FromServerMessage- | MessageSendError Value IOError- deriving Eq+data SessionException+ = Timeout (Maybe FromServerMessage)+ | NoContentLengthHeader+ | UnexpectedMessage String FromServerMessage+ | ReplayOutOfOrder FromServerMessage [FromServerMessage]+ | UnexpectedDiagnostics+ | IncorrectApplyEditRequest String+ | UnexpectedResponseError SomeLspId ResponseError+ | UnexpectedServerTermination+ | IllegalInitSequenceMessage FromServerMessage+ | MessageSendError Value IOError+ deriving (Eq) instance Exception SessionException instance Show SessionException where show (Timeout lastMsg) =- "Timed out waiting to receive a message from the server." ++- case lastMsg of- Just msg -> "\nLast message received:\n" ++ B.unpack (encodePretty msg)- Nothing -> mempty+ "Timed out waiting to receive a message from the server."+ ++ case lastMsg of+ Just msg -> "\nLast message received:\n" ++ B.unpack (encodePretty msg)+ Nothing -> mempty show NoContentLengthHeader = "Couldn't read Content-Length header from the server." show (UnexpectedMessage expected lastMsg) =- "Received an unexpected message from the server:\n" ++- "Was parsing: " ++ expected ++ "\n" ++- "But the last message received was:\n" ++ B.unpack (encodePretty lastMsg)+ "Received an unexpected message from the server:\n"+ ++ "Was parsing: "+ ++ expected+ ++ "\n"+ ++ "But the last message received was:\n"+ ++ B.unpack (encodePretty lastMsg) show (ReplayOutOfOrder received expected) = let expected' = nub expected getJsonDiff = lines . B.unpack . encodePretty- showExp exp = B.unpack (encodePretty exp) ++ "\nDiff:\n" ++- ppDiff (getGroupedDiff (getJsonDiff received) (getJsonDiff exp))- in "Replay is out of order:\n" ++- -- Print json so its a bit easier to update the session logs- "Received from server:\n" ++ B.unpack (encodePretty received) ++ "\n" ++- "Raw from server:\n" ++ B.unpack (encode received) ++ "\n" ++- "Expected one of:\n" ++ unlines (map showExp expected')+ showExp exp =+ B.unpack (encodePretty exp)+ ++ "\nDiff:\n"+ ++ ppDiff (getGroupedDiff (getJsonDiff received) (getJsonDiff exp))+ in "Replay is out of order:\n"+ +++ -- Print json so its a bit easier to update the session logs+ "Received from server:\n"+ ++ B.unpack (encodePretty received)+ ++ "\n"+ ++ "Raw from server:\n"+ ++ B.unpack (encode received)+ ++ "\n"+ ++ "Expected one of:\n"+ ++ unlines (map showExp expected') show UnexpectedDiagnostics = "Unexpectedly received diagnostics from the server."- show (IncorrectApplyEditRequest msgStr) = "ApplyEditRequest didn't contain document, instead received:\n"- ++ msgStr- show (UnexpectedResponseError lid e) = "Received an expected error in a response for id " ++ show lid ++ ":\n"- ++ show e+ show (IncorrectApplyEditRequest msgStr) =+ "ApplyEditRequest didn't contain document, instead received:\n"+ ++ msgStr+ show (UnexpectedResponseError lid e) =+ "Received an expected error in a response for id "+ ++ show lid+ ++ ":\n"+ ++ show e show UnexpectedServerTermination = "Language server unexpectedly terminated" show (IllegalInitSequenceMessage msg) = "Received an illegal message between the initialize request and response:\n"- ++ B.unpack (encodePretty msg)+ ++ B.unpack (encodePretty msg) show (MessageSendError msg e) = "IO exception:\n" ++ show e ++ "\narose while trying to send message:\n" ++ B.unpack (encodePretty msg)
src/Language/LSP/Test/Files.hs view
@@ -1,25 +1,26 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeInType #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-}-module Language.LSP.Test.Files- ( swapFiles- , rootDir- )+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}++module Language.LSP.Test.Files (+ swapFiles,+ rootDir,+) where -import Language.LSP.Protocol.Message-import Language.LSP.Protocol.Types-import qualified Language.LSP.Protocol.Lens as L-import Control.Lens-import qualified Data.Map.Strict as M-import qualified Data.Text as T-import Data.Maybe-import System.Directory-import System.FilePath+import Control.Lens+import Data.Map.Strict qualified as M+import Data.Maybe+import Data.Text qualified as T import Data.Time.Clock+import Language.LSP.Protocol.Lens qualified as L+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types+import System.Directory+import System.FilePath data Event = ClientEv UTCTime FromClientMessage@@ -33,17 +34,17 @@ let transform uri = let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri) newFp = curBaseDir </> makeRelative capturedBaseDir fp- in filePathToUri newFp+ in filePathToUri newFp newMsgs = map (mapUris transform) msgs return newMsgs rootDir :: [Event] -> FilePath-rootDir (ClientEv _ (FromClientMess SMethod_Initialize req):_) =+rootDir (ClientEv _ (FromClientMess SMethod_Initialize req) : _) = fromMaybe (error "Couldn't find root dir") $ do rootUri <- case req ^. L.params . L.rootUri of- InL r -> Just r- InR _ -> error "Couldn't find root dir"+ InL r -> Just r+ InR _ -> error "Couldn't find root dir" uriToFilePath rootUri rootDir _ = error "Couldn't find initialize request in session" @@ -52,58 +53,59 @@ case event of ClientEv t msg -> ClientEv t (fromClientMsg msg) ServerEv t msg -> ServerEv t (fromServerMsg msg)-- where- --TODO: Handle all other URIs that might need swapped- 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+ where+ -- TODO: Handle all other URIs that might need swapped+ 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@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+ fromServerMsg :: FromServerMessage -> FromServerMessage+ 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 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 $ L.newUri .~ f (renameFile ^. L.newUri) $ renameFile- swapDocumentChangeUri (InR (InR (InR deleteFile))) = InR $ InR $ InR $ swapUri id deleteFile- in e & L.changes . _Just %~ swapKeys f- & L.documentChanges . _Just . traversed%~ swapDocumentChangeUri+ swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit+ swapWorkspaceEdit e =+ let swapDocumentChangeUri :: DocumentChange -> DocumentChange+ 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 $ L.newUri .~ f (renameFile ^. L.newUri) $ renameFile+ swapDocumentChangeUri (InR (InR (InR deleteFile))) = InR $ InR $ InR $ swapUri id deleteFile+ in e+ & L.changes . _Just %~ swapKeys f+ & L.documentChanges . _Just . traversed %~ swapDocumentChangeUri - 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+ 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 :: L.HasUri b Uri => Lens' a b -> a -> a- swapUri lens x =- let newUri = f (x ^. lens . L.uri)- in (lens . L.uri) .~ newUri $ x+ swapUri :: L.HasUri b Uri => Lens' a b -> a -> a+ swapUri lens x =+ let newUri = f (x ^. lens . L.uri)+ in (lens . L.uri) .~ newUri $ x - -- | Transforms rootUri/rootPath.- transformInit :: InitializeParams -> InitializeParams- transformInit 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+ -- \| Transforms rootUri/rootPath.+ transformInit :: InitializeParams -> InitializeParams+ transformInit 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
src/Language/LSP/Test/Parsing.hs view
@@ -1,97 +1,100 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeInType #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeInType #-} -module Language.LSP.Test.Parsing- ( -- $receiving- satisfy- , satisfyMaybe- , message- , response- , responseForId- , customRequest- , customNotification- , anyRequest- , anyResponse- , anyNotification- , anyMessage- , loggingNotification- , configurationRequest- , loggingOrConfiguration- , publishDiagnosticsNotification- ) where+module Language.LSP.Test.Parsing (+ -- $receiving+ satisfy,+ satisfyMaybe,+ message,+ response,+ responseForId,+ customRequest,+ customNotification,+ anyRequest,+ anyResponse,+ anyNotification,+ anyMessage,+ loggingNotification,+ configurationRequest,+ loggingOrConfiguration,+ publishDiagnosticsNotification,+) where import Control.Applicative import Control.Concurrent-import Control.Monad.IO.Class import Control.Monad+import Control.Monad.IO.Class import Data.Conduit.Parser hiding (named)-import qualified Data.Conduit.Parser (named)-import qualified Data.Text as T+import Data.Conduit.Parser qualified (named)+import Data.GADT.Compare+import Data.Text qualified as T import Data.Typeable+import GHC.TypeLits (KnownSymbol, symbolVal) 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:------ @--- msg1 <- message SWorkspaceApplyEdit--- msg2 <- message STextDocumentHover--- @------ 'Language.LSP.Test.Session' is actually just a parser--- that operates on messages under the hood. This means that you--- can create and combine parsers to match specific sequences of--- messages that you expect.------ For example, if you wanted to match either a definition or--- references request:------ > defOrImpl = message STextDocumentDefinition--- > <|> message STextDocumentReferences------ If you wanted to match any number of telemetry--- notifications immediately followed by a response:------ @--- logThenDiags =--- skipManyTill (message STelemetryEvent)--- anyResponse--- @+{- $receiving+ To receive a message, specify the method of the message to expect: --- | Consumes and returns the next message, if it satisfies the specified predicate.------ @since 0.5.2.0+ @+ msg1 <- message SWorkspaceApplyEdit+ msg2 <- message STextDocumentHover+ @++ 'Language.LSP.Test.Session' is actually just a parser+ that operates on messages under the hood. This means that you+ can create and combine parsers to match specific sequences of+ messages that you expect.++ For example, if you wanted to match either a definition or+ references request:++ > defOrImpl = message STextDocumentDefinition+ > <|> message STextDocumentReferences++ If you wanted to match any number of telemetry+ notifications immediately followed by a response:++ @+ logThenDiags =+ skipManyTill (message STelemetryEvent)+ anyResponse+ @+-}++{- | Consumes and returns the next message, if it satisfies the specified predicate.++ @since 0.5.2.0+-} satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing) --- | Consumes and returns the result of the specified predicate if it returns `Just`.------ @since 0.6.1.0+{- | Consumes and returns the result of the specified predicate if it returns `Just`.++ @since 0.6.1.0+-} satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a satisfyMaybe pred = satisfyMaybeM (pure . pred) satisfyMaybeM :: (FromServerMessage -> Session (Maybe a)) -> Session a-satisfyMaybeM pred = do - +satisfyMaybeM pred = do skipTimeout <- overridingTimeout <$> get timeoutId <- getCurTimeoutId mtid <- if skipTimeout- then pure Nothing- else Just <$> do- chan <- asks messageChan- timeout <- asks (messageTimeout . config)- liftIO $ forkIO $ do- threadDelay (timeout * 1000000)- writeChan chan (TimeoutMessage timeoutId)+ then pure Nothing+ else+ Just <$> do+ chan <- asks messageChan+ timeout <- asks (messageTimeout . config)+ liftIO $ forkIO $ do+ threadDelay (timeout * 1000000)+ writeChan chan (TimeoutMessage timeoutId) x <- Session await @@ -99,7 +102,7 @@ bumpTimeoutId timeoutId liftIO $ killThread tid - modify $ \s -> s { lastReceivedMessage = Just x }+ modify $ \s -> s{lastReceivedMessage = Just x} res <- pred x @@ -112,9 +115,9 @@ named :: T.Text -> Session a -> Session a named s (Session x) = Session (Data.Conduit.Parser.named s x) ---- | Matches a request or a notification coming from the server.--- Doesn't match Custom Messages+{- | Matches a request or a notification coming from the server.+ Doesn't match Custom Messages+-} 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@@ -128,28 +131,28 @@ 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+ 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- _ -> Nothing 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+ 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- _ -> Nothing -- | Matches if the message is a notification. anyNotification :: Session FromServerMessage@@ -202,25 +205,26 @@ -- | Matches if the message is a log message notification or a show message notification/request. loggingNotification :: Session FromServerMessage loggingNotification = named "Logging notification" $ satisfy shouldSkip- where- shouldSkip (FromServerMess SMethod_WindowLogMessage _) = True- shouldSkip (FromServerMess SMethod_WindowShowMessage _) = True- shouldSkip (FromServerMess SMethod_WindowShowMessageRequest _) = True- shouldSkip (FromServerMess SMethod_WindowShowDocument _) = True- shouldSkip _ = False+ where+ shouldSkip (FromServerMess SMethod_WindowLogMessage _) = True+ shouldSkip (FromServerMess SMethod_WindowShowMessage _) = True+ shouldSkip (FromServerMess SMethod_WindowShowMessageRequest _) = True+ shouldSkip (FromServerMess SMethod_WindowShowDocument _) = True+ shouldSkip _ = False -- | Matches if the message is a configuration request from the server. configurationRequest :: Session FromServerMessage configurationRequest = named "Configuration request" $ satisfy shouldSkip- where- shouldSkip (FromServerMess SMethod_WorkspaceConfiguration _) = True- shouldSkip _ = False+ where+ shouldSkip (FromServerMess SMethod_WorkspaceConfiguration _) = True+ shouldSkip _ = False loggingOrConfiguration :: Session FromServerMessage loggingOrConfiguration = loggingNotification <|> configurationRequest --- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics'--- (textDocument/publishDiagnostics) notification.+{- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics'+ (textDocument/publishDiagnostics) notification.+-} publishDiagnosticsNotification :: Session (TMessage Method_TextDocumentPublishDiagnostics) publishDiagnosticsNotification = named "Publish diagnostics notification" $ satisfyMaybe $ \msg -> case msg of
src/Language/LSP/Test/Server.hs view
@@ -10,8 +10,8 @@ withServer serverExe logStdErr modifyCreateProcess f = do -- TODO Probably should just change runServer to accept -- separate command and arguments- let cmd:args = words serverExe- createProc = (proc cmd args) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }+ let cmd : args = words serverExe+ createProc = (proc cmd args){std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe} withCreateProcess (modifyCreateProcess createProc) $ \(Just serverIn) (Just serverOut) (Just serverErr) serverProc -> do -- Need to continuously consume to stderr else it gets blocked -- Can't pass NoStream either to std_err
src/Language/LSP/Test/Session.hs view
@@ -1,3 +1,5 @@+{- ORMOLU_DISABLE -}+ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}@@ -280,8 +282,8 @@ mainThreadId <- myThreadId let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps- initState vfs = SessionState 0 vfs mempty False Nothing mempty (lspConfig config) mempty (ignoreLogNotifications config) (ignoreConfigurationRequests config)- runSession' ses = initVFS $ \vfs -> runSessionMonad context (initState vfs) ses+ initState = SessionState 0 emptyVFS mempty False Nothing mempty (lspConfig config) mempty (ignoreLogNotifications config) (ignoreConfigurationRequests config)+ runSession' = runSessionMonad context initState errorHandler = throwTo mainThreadId :: SessionException -> IO () serverListenerLauncher =@@ -304,7 +306,7 @@ (result, _) <- bracket serverListenerLauncher serverAndListenerFinalizer- (const $ initVFS $ \vfs -> runSessionMonad context (initState vfs) session)+ (const $ runSessionMonad context initState session) return result updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
test/DummyServer.hs view
@@ -1,27 +1,28 @@-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeInType #-}+ module DummyServer where import Control.Monad import Control.Monad.Reader-import Data.Aeson hiding (defaultOptions, Null)-import qualified Data.Aeson as J-import qualified Data.Map.Strict as M+import Data.Aeson hiding (Null, defaultOptions)+import Data.Aeson qualified as J import Data.List (isSuffixOf)-import qualified Data.Text as T+import Data.Map.Strict qualified as M+import Data.Proxy import Data.String-import UnliftIO.Concurrent+import Data.Text qualified as T+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types import Language.LSP.Server-import System.IO-import UnliftIO import System.Directory import System.FilePath+import System.IO import System.Process-import Language.LSP.Protocol.Types-import Language.LSP.Protocol.Message-import Data.Proxy+import UnliftIO+import UnliftIO.Concurrent withDummyServer :: ((Handle, Handle) -> IO ()) -> IO () withDummyServer f = do@@ -30,7 +31,8 @@ handlerEnv <- HandlerEnv <$> newEmptyMVar <*> newEmptyMVar let- definition = ServerDefinition+ definition =+ ServerDefinition { doInitialize = \env _req -> pure $ Right env , defaultConfig = 1 :: Int , configSection = "dummy"@@ -41,7 +43,7 @@ , staticHandlers = \_caps -> handlers , interpretHandler = \env -> Iso (\m -> runLspT env (runReaderT m handlerEnv)) liftIO- , options = defaultOptions {optExecuteCommandCommands = Just ["doAnEdit"]}+ , options = defaultOptions{optExecuteCommandCommands = Just ["doAnEdit"]} } bracket@@ -49,7 +51,6 @@ killThread (const $ f (hinWrite, houtRead)) - data HandlerEnv = HandlerEnv { relRegToken :: MVar (RegistrationToken Method_WorkspaceDidChangeWatchedFiles) , absRegToken :: MVar (RegistrationToken Method_WorkspaceDidChangeWatchedFiles)@@ -62,11 +63,9 @@ \_noti -> sendNotification SMethod_WindowLogMessage $ LogMessageParams MessageType_Log "initialized"- , requestHandler (SMethod_CustomMethod (Proxy @"getConfig")) $ \_req resp -> do config <- getConfig resp $ Right $ toJSON config- , requestHandler SMethod_TextDocumentHover $ \_req responder -> responder $@@ -77,18 +76,19 @@ \_req responder -> responder $ Right $- InR $ InL- [ DocumentSymbol- "foo"- Nothing- SymbolKind_Object- Nothing- Nothing- (mkRange 0 0 3 6)- (mkRange 0 0 3 6)- Nothing- ]- , notificationHandler SMethod_TextDocumentDidOpen $+ 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 TNotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti TextDocumentItem uri _ _ _ = doc@@ -153,37 +153,35 @@ do Just token <- runInIO $ asks absRegToken >>= tryReadMVar runInIO $ unregisterCapability token-- -- this handler is used by the+ , -- this handler is used by the -- "text document VFS / sends back didChange notifications (documentChanges)" test- , notificationHandler SMethod_TextDocumentDidChange $ \noti -> do+ notificationHandler SMethod_TextDocumentDidChange $ \noti -> do let TNotificationMessage _ _ params = noti void $ sendNotification (SMethod_CustomMethod (Proxy @"custom/textDocument/didChange")) (toJSON params)-- , requestHandler SMethod_WorkspaceExecuteCommand $ \req resp -> do- case req of- TRequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just [val])) -> do- let- Success docUri = fromJSON val- edit = [TextEdit (mkRange 0 0 0 5) "howdy"]- params =- ApplyWorkspaceEditParams (Just "Howdy edit") $- 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 = [InL (TextEdit (mkRange 0 0 0 5) "howdy")]- documentEdit = TextDocumentEdit versionedDocUri edit- params =- ApplyWorkspaceEditParams (Just "Howdy edit") $- 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 SMethod_TextDocumentCodeAction $ \req resp -> do+ , requestHandler SMethod_WorkspaceExecuteCommand $ \req resp -> do+ case req of+ TRequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just [val])) -> do+ let+ Success docUri = fromJSON val+ edit = [TextEdit (mkRange 0 0 0 5) "howdy"]+ params =+ ApplyWorkspaceEditParams (Just "Howdy edit") $+ 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 = [InL (TextEdit (mkRange 0 0 0 5) "howdy")]+ documentEdit = TextDocumentEdit versionedDocUri edit+ params =+ ApplyWorkspaceEditParams (Just "Howdy edit") $+ 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 SMethod_TextDocumentCodeAction $ \req resp -> do let TRequestMessage _ _ _ params = req CodeActionParams _ _ _ _ cactx = params CodeActionContext diags _ _ = cactx@@ -199,7 +197,7 @@ (Just (Command "" "deleteThis" Nothing)) Nothing resp $ Right $ InL $ InR <$> codeActions- , requestHandler SMethod_TextDocumentCompletion $ \_req resp -> do+ , requestHandler SMethod_TextDocumentCompletion $ \_req resp -> do let res = CompletionList True Nothing [item] item = CompletionItem@@ -223,7 +221,7 @@ Nothing Nothing resp $ Right $ InR $ InL res- , requestHandler SMethod_TextDocumentPrepareCallHierarchy $ \req resp -> do+ , requestHandler SMethod_TextDocumentPrepareCallHierarchy $ \req resp -> do let TRequestMessage _ _ _ params = req CallHierarchyPrepareParams _ pos _ = params Position x y = pos@@ -240,17 +238,21 @@ if x == 0 && y == 0 then resp $ Right $ InR Null else resp $ Right $ InL [item]- , requestHandler SMethod_CallHierarchyIncomingCalls $ \req resp -> do+ , requestHandler SMethod_CallHierarchyIncomingCalls $ \req resp -> do let TRequestMessage _ _ _ params = req CallHierarchyIncomingCallsParams _ _ item = params- resp $ Right $ InL- [CallHierarchyIncomingCall item [Range (Position 2 3) (Position 4 5)]]- , requestHandler SMethod_CallHierarchyOutgoingCalls $ \req resp -> do+ 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 $ InL- [CallHierarchyOutgoingCall item [Range (Position 4 5) (Position 2 3)]]- , requestHandler SMethod_TextDocumentSemanticTokensFull $ \_req resp -> do+ 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 (InR ErrorCodes_InternalError) t Nothing
test/Test.hs view
@@ -1,46 +1,44 @@-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeInType #-} +import Control.Applicative.Combinators+import Control.Concurrent+import Control.Lens hiding (Iso, List)+import Control.Monad+import Control.Monad.IO.Class+import Data.Aeson+import Data.Aeson qualified as J+import Data.Default+import Data.Either+import Data.Map.Strict qualified as M+import Data.Maybe+import Data.Proxy+import Data.Text qualified as T+import Data.Type.Equality import DummyServer-import Test.Hspec-import Data.Aeson-import qualified Data.Aeson as J-import Data.Default-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.Protocol.Message-import Language.LSP.Protocol.Types-import qualified Language.LSP.Protocol.Lens as L-import System.Directory-import System.FilePath-import System.Timeout-+import Language.LSP.Protocol.Lens qualified as L+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types+import Language.LSP.Test+import System.Directory+import System.FilePath+import System.Timeout+import Test.Hspec {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-} - main = hspec $ around withDummyServer $ do describe "Session" $ do it "fails a test" $ \(hin, hout) -> let session = runSessionWithHandles hin hout def fullCaps "." $ do- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"- anyRequest- in session `shouldThrow` anySessionException+ openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"+ anyRequest+ in session `shouldThrow` anySessionException it "initializeResponse" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do rsp <- initializeResponse liftIO $ rsp ^. L.result `shouldSatisfy` isRight@@ -51,20 +49,20 @@ describe "withTimeout" $ do it "times out" $ \(hin, hout) -> let sesh = runSessionWithHandles hin hout def fullCaps "." $ do- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"- -- won't receive a request - will timeout- -- incoming logging requests shouldn't increase the- -- timeout- 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+ openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"+ -- won't receive a request - will timeout+ -- incoming logging requests shouldn't increase the+ -- timeout+ withTimeout 5 $ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit)+ in -- wait just a bit longer than 5 seconds so we have time+ -- to open the document+ timeout 6000000 sesh `shouldThrow` anySessionException it "doesn't time out" $ \(hin, hout) -> let sesh = runSessionWithHandles hin hout def fullCaps "." $ do- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"- withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification- in void $ timeout 6000000 sesh+ openDoc "test/data/renamePass/Desktop/simple.hs" "haskell"+ withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification+ in void $ timeout 6000000 sesh it "further timeout messages are ignored" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do@@ -72,24 +70,24 @@ -- shouldn't timeout withTimeout 3 $ getDocumentSymbols doc -- longer than the original timeout- liftIO $ threadDelay (5 * 10^6)+ liftIO $ threadDelay (5 * 10 ^ 6) -- shouldn't throw an exception getDocumentSymbols doc return () it "overrides global message timeout" $ \(hin, hout) -> let sesh =- runSessionWithHandles hin hout (def { messageTimeout = 5 }) fullCaps "." $ do+ runSessionWithHandles hin hout (def{messageTimeout = 5}) fullCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" -- shouldn't time out in here since we are overriding it withTimeout 10 $ liftIO $ threadDelay 7000000 getDocumentSymbols doc return True- in sesh `shouldReturn` True+ in sesh `shouldReturn` True it "unoverrides global message timeout" $ \(hin, hout) -> let sesh =- runSessionWithHandles hin hout (def { messageTimeout = 5 }) fullCaps "." $ do+ runSessionWithHandles hin hout (def{messageTimeout = 5}) fullCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" -- shouldn't time out in here since we are overriding it withTimeout 10 $ liftIO $ threadDelay 7000000@@ -98,18 +96,17 @@ skipManyTill anyMessage (message SMethod_WorkspaceApplyEdit) isTimeout (Timeout _) = True isTimeout _ = False- in sesh `shouldThrow` isTimeout-+ in sesh `shouldThrow` isTimeout describe "SessionException" $ do it "throw on time out" $ \(hin, hout) ->- let sesh = runSessionWithHandles hin hout (def {messageTimeout = 10}) fullCaps "." $ do- _ <- message SMethod_WorkspaceApplyEdit- return ()- in sesh `shouldThrow` anySessionException+ let sesh = runSessionWithHandles hin hout (def{messageTimeout = 10}) fullCaps "." $ do+ _ <- message SMethod_WorkspaceApplyEdit+ return ()+ in sesh `shouldThrow` anySessionException it "don't throw when no time out" $ \(hin, hout) ->- runSessionWithHandles hin hout (def {messageTimeout = 5}) fullCaps "." $ do+ runSessionWithHandles hin hout (def{messageTimeout = 5}) fullCaps "." $ do liftIO $ threadDelay $ 6 * 1000000 _ <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" return ()@@ -118,7 +115,7 @@ it "throws when there's an unexpected message" $ \(hin, hout) -> let selector (UnexpectedMessage "Publish diagnostics notification" (FromServerMess SMethod_WindowLogMessage _)) = True selector _ = False- in runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." publishDiagnosticsNotification `shouldThrow` selector+ in runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "." publishDiagnosticsNotification `shouldThrow` selector it "provides the correct types that were expected and received" $ \(hin, hout) -> let selector (UnexpectedMessage "Response for: SMethod_TextDocumentRename" (FromServerRsp SMethod_TextDocumentDocumentSymbol _)) = True selector _ = False@@ -127,12 +124,12 @@ sendRequest SMethod_TextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) skipMany anyNotification response SMethod_TextDocumentRename -- the wrong type- in runSessionWithHandles hin hout def fullCaps "." sesh- `shouldThrow` selector+ in runSessionWithHandles hin hout def fullCaps "." sesh+ `shouldThrow` selector describe "config" $ do it "updates config correctly" $ \(hin, hout) ->- runSessionWithHandles hin hout (def { ignoreConfigurationRequests = False }) fullCaps "." $ do+ runSessionWithHandles hin hout (def{ignoreConfigurationRequests = False}) fullCaps "." $ do configurationRequest -- initialized configuration request let requestConfig = do resp <- request (SMethod_CustomMethod (Proxy @"getConfig")) J.Null@@ -166,13 +163,13 @@ editReq <- message SMethod_WorkspaceApplyEdit liftIO $ do- let Just [InL(TextDocumentEdit vdoc [InL edit_])] =+ let Just [InL (TextDocumentEdit vdoc [InL edit_])] = editReq ^. L.params . L.edit . L.documentChanges- vdoc `shouldBe` OptionalVersionedTextDocumentIdentifier (doc ^. L.uri) (InL beforeVersion)+ vdoc `shouldBe` OptionalVersionedTextDocumentIdentifier (doc ^. L.uri) (InL beforeVersion) edit_ `shouldBe` TextEdit (Range (Position 0 0) (Position 0 5)) "howdy" change <- customNotification (Proxy @"custom/textDocument/didChange")- let NotMess (TNotificationMessage _ _ (c::Value)) = change+ let NotMess (TNotificationMessage _ _ (c :: Value)) = change Success (DidChangeTextDocumentParams reportedVDoc _edit) = fromJSON c VersionedTextDocumentIdentifier _ reportedVersion = reportedVDoc @@ -229,13 +226,13 @@ liftIO $ do let [InR action] = actions action ^. L.title `shouldBe` "Delete this"- action ^. L.command . _Just . L.command `shouldBe` "deleteThis"+ action ^. L.command . _Just . L.command `shouldBe` "deleteThis" describe "getDocumentSymbols" $ it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" - Right (mainSymbol:_) <- getDocumentSymbols doc+ Right (mainSymbol : _) <- getDocumentSymbols doc liftIO $ do mainSymbol ^. L.name `shouldBe` "foo"@@ -341,24 +338,24 @@ closeDoc doc -- need to evaluate to throw documentContents doc >>= liftIO . print- in sesh `shouldThrow` anyException+ in sesh `shouldThrow` anyException describe "satisfy" $- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." $ do+ it "works" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "." $ do openDoc "test/data/Format.hs" "haskell" 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 {ignoreLogNotifications=False}) fullCaps "." $ do+ it "returns matched data on match" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "." $ do -- Wait for window/logMessage "initialized" from the server. 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 {ignoreLogNotifications=False}) fullCaps "." $ do+ it "doesn't return if no match" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "." $ do let pred (FromServerMess SMethod_TextDocumentPublishDiagnostics _) = Just "matched" :: Maybe String pred _ = Nothing :: Maybe String -- We expect a window/logMessage from the server, but@@ -368,13 +365,12 @@ describe "ignoreLogNotifications" $ it "works" $ \(hin, hout) ->- runSessionWithHandles hin hout (def { ignoreLogNotifications = True }) fullCaps "." $ do+ runSessionWithHandles hin hout (def{ignoreLogNotifications = True}) fullCaps "." $ do openDoc "test/data/Format.hs" "haskell" void publishDiagnosticsNotification describe "dynamic capabilities" $ do-- it "keeps track" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "." $ do+ it "keeps track" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "." $ do loggingNotification -- initialized log message createDoc ".register" "haskell" "" message SMethod_ClientRegisterCapability@@ -387,8 +383,11 @@ liftIO $ do case regMethod `mEqClient` SMethod_WorkspaceDidChangeWatchedFiles of Just (Right HRefl) ->- regOpts `shouldBe` (Just $ DidChangeWatchedFilesRegistrationOptions- [ FileSystemWatcher (GlobPattern $ InL $ Pattern "*.watch") (Just WatchKind_Create) ])+ 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@@ -399,7 +398,7 @@ void $ sendRequest SMethod_TextDocumentHover $ HoverParams doc (Position 0 0) Nothing void $ anyResponse - it "handles absolute patterns" $ \(hin, hout) -> runSessionWithHandles hin hout (def {ignoreLogNotifications=False}) fullCaps "" $ do+ it "handles absolute patterns" $ \(hin, hout) -> runSessionWithHandles hin hout (def{ignoreLogNotifications = False}) fullCaps "" $ do loggingNotification -- initialized log message curDir <- liftIO $ getCurrentDirectory @@ -422,10 +421,16 @@ let workPos = Position 1 0 notWorkPos = Position 0 0 params pos = CallHierarchyPrepareParams (TextDocumentIdentifier (Uri "")) pos Nothing- item = CallHierarchyItem "foo" SymbolKind_Function Nothing Nothing (Uri "")- (Range (Position 1 2) (Position 3 4))- (Range (Position 1 2) (Position 3 4))- Nothing+ 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 ^. L.range `shouldBe` Range (Position 2 3) (Position 4 5)@@ -443,4 +448,4 @@ it "full works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do let doc = TextDocumentIdentifier (Uri "") InL toks <- getSemanticTokens doc- liftIO $ toks ^. L.data_ `shouldBe` [0,1,2,1,0]+ liftIO $ toks ^. L.data_ `shouldBe` [0, 1, 2, 1, 0]
test/data/Format.hs view
@@ -1,4 +1,5 @@ module Format where-foo 3 = 2-foo x = x-bar _ = 2++foo 3 = 2+foo x = x+bar _ = 2
test/data/documentSymbolFail/example/Main.hs view
@@ -1,20 +1,21 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+ module Main where -import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP-import qualified Language.Haskell.LSP.TH.ClientCapabilities as LSP-import qualified LSP.Client as Client-import Data.Proxy-import qualified Data.Text.IO as T import Control.Concurrent-import System.Process import Control.Lens-import System.IO-import System.Exit-import System.Environment-import System.Directory import Control.Monad+import Data.Proxy+import qualified Data.Text.IO as T+import qualified LSP.Client as Client+import qualified Language.Haskell.LSP.TH.ClientCapabilities as LSP+import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP+import System.Directory+import System.Environment+import System.Exit+import System.IO+import System.Process import qualified Compat @@ -39,43 +40,55 @@ pid <- Compat.getPID let caps = LSP.ClientCapabilities (Just workspaceCaps) (Just textDocumentCaps) Nothing- workspaceCaps = LSP.WorkspaceClientCapabilities- (Just False)- (Just (LSP.WorkspaceEditClientCapabilities (Just False)))- (Just (LSP.DidChangeConfigurationClientCapabilities (Just False)))- (Just (LSP.DidChangeWatchedFilesClientCapabilities (Just False)))- (Just (LSP.SymbolClientCapabilities (Just False)))- (Just (LSP.ExecuteClientCapabilities (Just False)))- textDocumentCaps = LSP.TextDocumentClientCapabilities- (Just (LSP.SynchronizationTextDocumentClientCapabilities- (Just False)- (Just False)- (Just False)- (Just False)))- (Just (LSP.CompletionClientCapabilities- (Just False)- (Just (LSP.CompletionItemClientCapabilities (Just False)))))- (Just (LSP.HoverClientCapabilities (Just False)))- (Just (LSP.SignatureHelpClientCapabilities (Just False)))- (Just (LSP.ReferencesClientCapabilities (Just False)))- (Just (LSP.DocumentHighlightClientCapabilities (Just False)))- (Just (LSP.DocumentSymbolClientCapabilities (Just False)))- (Just (LSP.FormattingClientCapabilities (Just False)))- (Just (LSP.RangeFormattingClientCapabilities (Just False)))- (Just (LSP.OnTypeFormattingClientCapabilities (Just False)))- (Just (LSP.DefinitionClientCapabilities (Just False)))- (Just (LSP.CodeActionClientCapabilities (Just False)))- (Just (LSP.CodeLensClientCapabilities (Just False)))- (Just (LSP.DocumentLinkClientCapabilities (Just False)))- (Just (LSP.RenameClientCapabilities (Just False)))- (Just (LSP.CallHierarchyClientCapabilities (Just False)))+ workspaceCaps =+ LSP.WorkspaceClientCapabilities+ (Just False)+ (Just (LSP.WorkspaceEditClientCapabilities (Just False)))+ (Just (LSP.DidChangeConfigurationClientCapabilities (Just False)))+ (Just (LSP.DidChangeWatchedFilesClientCapabilities (Just False)))+ (Just (LSP.SymbolClientCapabilities (Just False)))+ (Just (LSP.ExecuteClientCapabilities (Just False)))+ textDocumentCaps =+ LSP.TextDocumentClientCapabilities+ ( Just+ ( LSP.SynchronizationTextDocumentClientCapabilities+ (Just False)+ (Just False)+ (Just False)+ (Just False)+ )+ )+ ( Just+ ( LSP.CompletionClientCapabilities+ (Just False)+ (Just (LSP.CompletionItemClientCapabilities (Just False)))+ )+ )+ (Just (LSP.HoverClientCapabilities (Just False)))+ (Just (LSP.SignatureHelpClientCapabilities (Just False)))+ (Just (LSP.ReferencesClientCapabilities (Just False)))+ (Just (LSP.DocumentHighlightClientCapabilities (Just False)))+ (Just (LSP.DocumentSymbolClientCapabilities (Just False)))+ (Just (LSP.FormattingClientCapabilities (Just False)))+ (Just (LSP.RangeFormattingClientCapabilities (Just False)))+ (Just (LSP.OnTypeFormattingClientCapabilities (Just False)))+ (Just (LSP.DefinitionClientCapabilities (Just False)))+ (Just (LSP.CodeActionClientCapabilities (Just False)))+ (Just (LSP.CodeLensClientCapabilities (Just False)))+ (Just (LSP.DocumentLinkClientCapabilities (Just False)))+ (Just (LSP.RenameClientCapabilities (Just False)))+ (Just (LSP.CallHierarchyClientCapabilities (Just False))) initializeParams :: LSP.InitializeParams initializeParams = LSP.InitializeParams (Just pid) Nothing Nothing Nothing caps Nothing -- (Just inp, Just out, _, _) <- createProcess (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "--debug"])- {std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe}+ (Just inp, Just out, _, _) <-+ createProcess+ (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "--debug"])+ { std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ } client <- Client.start (Client.Config inp out testNotificationMessageHandler testRequestMessageHandler) @@ -93,7 +106,8 @@ client (Proxy :: Proxy LSP.DefinitionRequest) LSP.TextDocumentDefinition- (LSP.TextDocumentPositionParams (LSP.TextDocumentIdentifier uri) (LSP.Position 88 36)) >>= \case+ (LSP.TextDocumentPositionParams (LSP.TextDocumentIdentifier uri) (LSP.Position 88 36))+ >>= \case Just (Right pos) -> print pos _ -> putStrLn "Server couldn't give us defnition position" @@ -108,21 +122,23 @@ Client.stop client testRequestMessageHandler :: Client.RequestMessageHandler-testRequestMessageHandler = Client.RequestMessageHandler- (\m -> emptyResponse m <$ print m)- (\m -> emptyResponse m <$ print m)- (\m -> emptyResponse m <$ print m)- (\m -> emptyResponse m <$ print m)- where- toRspId (LSP.IdInt i) = LSP.IdRspInt i- toRspId (LSP.IdString t) = LSP.IdRspString t+testRequestMessageHandler =+ Client.RequestMessageHandler+ (\m -> emptyResponse m <$ print m)+ (\m -> emptyResponse m <$ print m)+ (\m -> emptyResponse m <$ print m)+ (\m -> emptyResponse m <$ print m)+ where+ toRspId (LSP.IdInt i) = LSP.IdRspInt i+ toRspId (LSP.IdString t) = LSP.IdRspString t - emptyResponse :: LSP.RequestMessage m req resp -> LSP.ResponseMessage a- emptyResponse m = LSP.ResponseMessage (m ^. LSP.jsonrpc) (toRspId (m ^. LSP.id)) Nothing Nothing+ emptyResponse :: LSP.RequestMessage m req resp -> LSP.ResponseMessage a+ emptyResponse m = LSP.ResponseMessage (m ^. LSP.jsonrpc) (toRspId (m ^. LSP.id)) Nothing Nothing testNotificationMessageHandler :: Client.NotificationMessageHandler-testNotificationMessageHandler = Client.NotificationMessageHandler- (T.putStrLn . view (LSP.params . LSP.message))- (T.putStrLn . view (LSP.params . LSP.message))- (print . view LSP.params)- (mapM_ T.putStrLn . (^.. LSP.params . LSP.diagnostics . traverse . LSP.message))+testNotificationMessageHandler =+ Client.NotificationMessageHandler+ (T.putStrLn . view (LSP.params . LSP.message))+ (T.putStrLn . view (LSP.params . LSP.message))+ (print . view LSP.params)+ (mapM_ T.putStrLn . (^.. LSP.params . LSP.diagnostics . traverse . LSP.message))
test/data/renameFail/Desktop/simple.hs view
@@ -8,11 +8,12 @@ type Item = String type Items = [Item] -data Command = Quit- | DisplayItems- | AddItem String- | RemoveItem Int- | Help+data Command+ = Quit+ | DisplayItems+ | AddItem String+ | RemoveItem Int+ | Help type Error = String @@ -35,8 +36,9 @@ removeItem i items | i < 0 || i >= length items = Left "Out of range" | otherwise = Right result- where (front, back) = splitAt (i + 1) items- result = init front ++ back+ where+ (front, back) = splitAt (i + 1) items+ result = init front ++ back interactWithUser :: Items -> IO () interactWithUser items = do@@ -45,12 +47,10 @@ Right DisplayItems -> do putStrLn $ displayItems items interactWithUser items- Right (AddItem item) -> do let newItems = addItem item items putStrLn "Added" interactWithUser newItems- Right (RemoveItem i) -> case removeItem i items of Right newItems -> do@@ -59,10 +59,7 @@ Left err -> do putStrLn err interactWithUser items-- Right Quit -> return ()- Right Help -> do putStrLn "Commands:" putStrLn "help"@@ -70,7 +67,6 @@ putStrLn "add" putStrLn "quit" interactWithUser items- Left err -> do putStrLn $ "Error: " ++ err interactWithUser items
test/data/renamePass/Desktop/simple.hs view
@@ -8,11 +8,12 @@ type Item = String type Items = [Item] -data Command = Quit- | DisplayItems- | AddItem String- | RemoveItem Int- | Help+data Command+ = Quit+ | DisplayItems+ | AddItem String+ | RemoveItem Int+ | Help type Error = String @@ -35,8 +36,9 @@ removeItem i items | i < 0 || i >= length items = Left "Out of range" | otherwise = Right result- where (front, back) = splitAt (i + 1) items- result = init front ++ back+ where+ (front, back) = splitAt (i + 1) items+ result = init front ++ back interactWithUser :: Items -> IO () interactWithUser items = do@@ -45,12 +47,10 @@ Right DisplayItems -> do putStrLn $ displayItems items interactWithUser items- Right (AddItem item) -> do let newItems = addItem item items putStrLn "Added" interactWithUser newItems- Right (RemoveItem i) -> case removeItem i items of Right newItems -> do@@ -59,10 +59,7 @@ Left err -> do putStrLn err interactWithUser items-- Right Quit -> return ()- Right Help -> do putStrLn "Commands:" putStrLn "help"@@ -70,7 +67,6 @@ putStrLn "add" putStrLn "quit" interactWithUser items- Left err -> do putStrLn $ "Error: " ++ err interactWithUser items