steps:
- uses: actions/checkout@v2
- - uses: actions/setup-haskell@v1.1.1
+ - uses: actions/setup-haskell@v1.1.4
with:
ghc-version: ${{ matrix.ghc }}
cabal-version: '3.2'
lsp-test is a functional testing framework for Language Server Protocol servers.
```haskell
-import Language.Haskell.LSP.Test
+import Language.LSP.Test
main = runSession "hie" fullCaps "proj/dir" $ do
doc <- openDoc "Foo.hs" "haskell"
skipMany anyNotification
packages: .
+ ./example
flags: +DummyServer
test-show-details: direct
haddock-quickjump: True
import Control.Applicative.Combinators
import Control.Monad.IO.Class
-import Language.Haskell.LSP.Test
-import Language.Haskell.LSP.Types
+import Language.LSP.Test
+import Language.LSP.Types
-main = runSession "hie" fullCaps "../test/data/" $ do
- docItem <- openDoc "Rename.hs" "haskell"
+main = runSession "haskell-language-server" fullCaps "../test/data/" $ do
+ doc <- openDoc "Rename.hs" "haskell"
-- Use your favourite favourite combinators.
skipManyTill loggingNotification (count 2 publishDiagnosticsNotification)
-- Send requests and notifications and receive responses
- let params = DocumentSymbolParams docItem
- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
+ rsp <- request STextDocumentDocumentSymbol $
+ DocumentSymbolParams Nothing Nothing doc
liftIO $ print rsp
-- Or use one of the helper functions
- getDocumentSymbols docItem >>= liftIO . print
+ getDocumentSymbols doc >>= liftIO . print
--- /dev/null
+cradle:
+ multi:
+ - path: "./test/data/"
+ config: { cradle: { none: } }
+ - path: "./example/"
+ config: { cradle: { none: } }
+ - path: "./"
+ config:
+ cradle:
+ cabal:
+ - path: "src"
+ component: "lib:lsp-test"
+ - path: "test/dummy-server"
+ component: "exe:dummy-server"
+ - path: "test"
+ component: "test:tests"
description:
A test framework for writing tests against
<https://microsoft.github.io/language-server-protocol/ Language Server Protocol servers>.
- @Language.Haskell.LSP.Test@ launches your server as a subprocess and allows you to simulate a session
- down to the wire, and @Language.Haskell.LSP.Test@ can replay captured sessions from
+ @Language.LSP.Test@ launches your server as a subprocess and allows you to simulate a session
+ down to the wire, and @Language.LSP.Test@ can replay captured sessions from
<haskell-lsp https://hackage.haskell.org/package/haskell-lsp>.
To see examples of it in action, check out <https://github.com/haskell/haskell-ide-engine haskell-ide-engine>,
<https://github.com/haskell/haskell-language-server haskell-language-server> and
cabal-version: 2.0
extra-source-files: README.md
, ChangeLog.md
-tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1
+tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1, GHC == 8.10.2
source-repository head
type: git
library
hs-source-dirs: src
- exposed-modules: Language.Haskell.LSP.Test
- , Language.Haskell.LSP.Test.Replay
- reexported-modules: haskell-lsp:Language.Haskell.LSP.Types
- , haskell-lsp:Language.Haskell.LSP.Types.Capabilities
+ exposed-modules: Language.LSP.Test
+ reexported-modules: lsp-types:Language.LSP.Types
+ , lsp-types:Language.LSP.Types.Capabilities
, parser-combinators:Control.Applicative.Combinators
default-language: Haskell2010
build-depends: base >= 4.10 && < 5
- , haskell-lsp >= 0.22 && < 0.24
+ , lsp-types >= 1.0.0.1 && < 1.1
, aeson
+ , time
, aeson-pretty
, ansi-terminal
, async
, text
, transformers
, unordered-containers
+ , some
if os(windows)
build-depends: Win32
else
build-depends: unix
- other-modules: Language.Haskell.LSP.Test.Compat
- Language.Haskell.LSP.Test.Decoding
- Language.Haskell.LSP.Test.Exceptions
- Language.Haskell.LSP.Test.Files
- Language.Haskell.LSP.Test.Messages
- Language.Haskell.LSP.Test.Parsing
- Language.Haskell.LSP.Test.Server
- Language.Haskell.LSP.Test.Session
+ other-modules: Language.LSP.Test.Compat
+ Language.LSP.Test.Decoding
+ Language.LSP.Test.Exceptions
+ Language.LSP.Test.Files
+ Language.LSP.Test.Parsing
+ Language.LSP.Test.Server
+ Language.LSP.Test.Session
ghc-options: -W
executable dummy-server
main-is: Main.hs
hs-source-dirs: test/dummy-server
ghc-options: -W
- build-depends: base >= 4.10 && < 5
- , haskell-lsp >= 0.23 && < 0.24
- , data-default
+ build-depends: base >= 4.11 && < 5
+ , lsp >= 1.0.0.1 && < 1.1
, aeson
, unordered-containers
, directory
, filepath
+ , unliftio
+ , mtl
default-language: Haskell2010
scope: private
if !flag(DummyServer)
build-depends: base >= 4.10 && < 5
, hspec
, lens
- , haskell-lsp >= 0.22 && < 0.24
+ , lsp-types >= 1.0.0.1 && < 1.1
, lsp-test
, data-default
, aeson
+++ /dev/null
-{-# LANGUAGE OverloadedStrings #-}
-module Language.Haskell.LSP.Test.Decoding where
-
-import Prelude hiding ( id )
-import Data.Aeson
-import Data.Foldable
-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.Haskell.LSP.Types
-import Language.Haskell.LSP.Types.Lens
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Test.Exceptions
-import qualified Data.HashMap.Strict as HM
-
-getAllMessages :: Handle -> IO [B.ByteString]
-getAllMessages h = do
- done <- hIsEOF h
- if done
- then return []
- else do
- msg <- getNextMessage h
-
- (msg :) <$> getAllMessages h
-
--- | 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
- 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
- ]
-
-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
-
-type RequestMap = HM.HashMap LspId ClientMethod
-
-newRequestMap :: RequestMap
-newRequestMap = HM.empty
-
-updateRequestMap :: RequestMap -> LspId -> ClientMethod -> RequestMap
-updateRequestMap reqMap id method = HM.insert id method reqMap
-
-getRequestMap :: [FromClientMessage] -> RequestMap
-getRequestMap = foldl helper HM.empty
- where
- helper acc msg = case msg of
- (ReqInitialize val) -> insert val acc
- (ReqShutdown val) -> insert val acc
- (ReqHover val) -> insert val acc
- (ReqCompletion val) -> insert val acc
- (ReqCompletionItemResolve val) -> insert val acc
- (ReqSignatureHelp val) -> insert val acc
- (ReqDefinition val) -> insert val acc
- (ReqTypeDefinition val) -> insert val acc
- (ReqFindReferences val) -> insert val acc
- (ReqDocumentHighlights val) -> insert val acc
- (ReqDocumentSymbols val) -> insert val acc
- (ReqWorkspaceSymbols val) -> insert val acc
- (ReqCodeAction val) -> insert val acc
- (ReqCodeLens val) -> insert val acc
- (ReqCodeLensResolve val) -> insert val acc
- (ReqDocumentFormatting val) -> insert val acc
- (ReqDocumentRangeFormatting val) -> insert val acc
- (ReqDocumentOnTypeFormatting val) -> insert val acc
- (ReqRename val) -> insert val acc
- (ReqExecuteCommand val) -> insert val acc
- (ReqDocumentLink val) -> insert val acc
- (ReqDocumentLinkResolve val) -> insert val acc
- (ReqWillSaveWaitUntil val) -> insert val acc
- _ -> acc
- insert m = HM.insert (m ^. id) (m ^. method)
-
-matchResponseMsgType :: ClientMethod -> B.ByteString -> FromServerMessage
-matchResponseMsgType req = case req of
- Initialize -> RspInitialize . decoded
- Shutdown -> RspShutdown . decoded
- TextDocumentHover -> RspHover . decoded
- TextDocumentCompletion -> RspCompletion . decoded
- CompletionItemResolve -> RspCompletionItemResolve . decoded
- TextDocumentSignatureHelp -> RspSignatureHelp . decoded
- TextDocumentDefinition -> RspDefinition . decoded
- TextDocumentTypeDefinition -> RspTypeDefinition . decoded
- TextDocumentReferences -> RspFindReferences . decoded
- TextDocumentDocumentHighlight -> RspDocumentHighlights . decoded
- TextDocumentDocumentSymbol -> RspDocumentSymbols . decoded
- WorkspaceSymbol -> RspWorkspaceSymbols . decoded
- TextDocumentCodeAction -> RspCodeAction . decoded
- TextDocumentCodeLens -> RspCodeLens . decoded
- CodeLensResolve -> RspCodeLensResolve . decoded
- TextDocumentFormatting -> RspDocumentFormatting . decoded
- TextDocumentRangeFormatting -> RspDocumentRangeFormatting . decoded
- TextDocumentOnTypeFormatting -> RspDocumentOnTypeFormatting . decoded
- TextDocumentRename -> RspRename . decoded
- WorkspaceExecuteCommand -> RspExecuteCommand . decoded
- TextDocumentDocumentLink -> RspDocumentLink . decoded
- DocumentLinkResolve -> RspDocumentLinkResolve . decoded
- TextDocumentWillSaveWaitUntil -> RspWillSaveWaitUntil . decoded
- CustomClientMethod{} -> RspCustomServer . decoded
- x -> error . ((show x ++ " is not a request: ") ++) . show
- where decoded x = fromMaybe (error $ "Couldn't decode response for the request type: "
- ++ show req ++ "\n" ++ show x)
- (decode x)
-
-decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage
-decodeFromServerMsg reqMap bytes =
- case HM.lookup "method" obj of
- Just methodStr -> case fromJSON methodStr of
- Success method -> case method of
- -- We can work out the type of the message
- TextDocumentPublishDiagnostics -> NotPublishDiagnostics $ fromJust $ decode bytes
- WindowShowMessage -> NotShowMessage $ fromJust $ decode bytes
- WindowLogMessage -> NotLogMessage $ fromJust $ decode bytes
- CancelRequestServer -> NotCancelRequestFromServer $ fromJust $ decode bytes
- Progress ->
- fromJust $ asum [NotWorkDoneProgressBegin <$> decode bytes, NotWorkDoneProgressReport <$> decode bytes, NotWorkDoneProgressEnd <$> decode bytes]
- WindowWorkDoneProgressCreate -> ReqWorkDoneProgressCreate $ fromJust $ decode bytes
- TelemetryEvent -> NotTelemetry $ fromJust $ decode bytes
- WindowShowMessageRequest -> ReqShowMessage $ fromJust $ decode bytes
- ClientRegisterCapability -> ReqRegisterCapability $ fromJust $ decode bytes
- ClientUnregisterCapability -> ReqUnregisterCapability $ fromJust $ decode bytes
- WorkspaceApplyEdit -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes
- 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
-
- Nothing -> case decode bytes :: Maybe (ResponseMessage Value) of
- Just msg -> case HM.lookup (requestId $ msg ^. id) reqMap of
- Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type
- Nothing -> error "Couldn't match up response with request"
- Nothing -> error "Couldn't decode message"
- where obj = fromJust $ decode bytes :: Object
+++ /dev/null
-{-# LANGUAGE RankNTypes #-}
-module Language.Haskell.LSP.Test.Messages where
-
-import Data.Aeson
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Types
-
-isServerResponse :: FromServerMessage -> Bool
-isServerResponse (RspInitialize _) = True
-isServerResponse (RspShutdown _) = True
-isServerResponse (RspHover _) = True
-isServerResponse (RspCompletion _) = True
-isServerResponse (RspCompletionItemResolve _) = True
-isServerResponse (RspSignatureHelp _) = True
-isServerResponse (RspDefinition _) = True
-isServerResponse (RspTypeDefinition _) = True
-isServerResponse (RspFindReferences _) = True
-isServerResponse (RspDocumentHighlights _) = True
-isServerResponse (RspDocumentSymbols _) = True
-isServerResponse (RspWorkspaceSymbols _) = True
-isServerResponse (RspCodeAction _) = True
-isServerResponse (RspCodeLens _) = True
-isServerResponse (RspCodeLensResolve _) = True
-isServerResponse (RspDocumentFormatting _) = True
-isServerResponse (RspDocumentRangeFormatting _) = True
-isServerResponse (RspDocumentOnTypeFormatting _) = True
-isServerResponse (RspRename _) = True
-isServerResponse (RspExecuteCommand _) = True
-isServerResponse (RspError _) = True
-isServerResponse (RspDocumentLink _) = True
-isServerResponse (RspDocumentLinkResolve _) = True
-isServerResponse (RspWillSaveWaitUntil _) = True
-isServerResponse _ = False
-
-isServerRequest :: FromServerMessage -> Bool
-isServerRequest (ReqRegisterCapability _) = True
-isServerRequest (ReqApplyWorkspaceEdit _) = True
-isServerRequest (ReqShowMessage _) = True
-isServerRequest (ReqUnregisterCapability _) = True
-isServerRequest _ = False
-
-isServerNotification :: FromServerMessage -> Bool
-isServerNotification (NotPublishDiagnostics _) = True
-isServerNotification (NotLogMessage _) = True
-isServerNotification (NotShowMessage _) = True
-isServerNotification (NotTelemetry _) = True
-isServerNotification (NotCancelRequestFromServer _) = True
-isServerNotification _ = False
-
-handleServerMessage
- :: forall a.
- (forall b c. RequestMessage ServerMethod b c -> a)
- -> (forall d. ResponseMessage d -> a)
- -> (forall e. NotificationMessage ServerMethod e -> a)
- -> FromServerMessage
- -> a
-handleServerMessage request response notification msg = case msg of
- (ReqRegisterCapability m) -> request m
- (ReqApplyWorkspaceEdit m) -> request m
- (ReqShowMessage m) -> request m
- (ReqUnregisterCapability m) -> request m
- (ReqCustomServer m) -> request m
- (ReqWorkDoneProgressCreate m) -> request m
- (RspInitialize m) -> response m
- (RspShutdown m) -> response m
- (RspHover m) -> response m
- (RspCompletion m) -> response m
- (RspCompletionItemResolve m) -> response m
- (RspSignatureHelp m) -> response m
- (RspDefinition m) -> response m
- (RspFindReferences m) -> response m
- (RspDocumentHighlights m) -> response m
- (RspDocumentSymbols m) -> response m
- (RspWorkspaceSymbols m) -> response m
- (RspCodeAction m) -> response m
- (RspCodeLens m) -> response m
- (RspCodeLensResolve m) -> response m
- (RspDocumentFormatting m) -> response m
- (RspDocumentRangeFormatting m) -> response m
- (RspDocumentOnTypeFormatting m) -> response m
- (RspRename m) -> response m
- (RspExecuteCommand m) -> response m
- (RspError m) -> response m
- (RspDocumentLink m) -> response m
- (RspDocumentLinkResolve m) -> response m
- (RspWillSaveWaitUntil m) -> response m
- (RspTypeDefinition m) -> response m
- (RspImplementation m) -> response m
- (RspDocumentColor m) -> response m
- (RspColorPresentation m) -> response m
- (RspFoldingRange m) -> response m
- (RspCustomServer m) -> response m
- (NotPublishDiagnostics m) -> notification m
- (NotLogMessage m) -> notification m
- (NotShowMessage m) -> notification m
- (NotWorkDoneProgressBegin m) -> notification m
- (NotWorkDoneProgressReport m) -> notification m
- (NotWorkDoneProgressEnd m) -> notification m
- (NotTelemetry m) -> notification m
- (NotCancelRequestFromServer m) -> notification m
- (NotCustomServer m) -> notification m
-
-handleClientMessage
- :: forall a.
- (forall b c . (ToJSON b, ToJSON c) => RequestMessage ClientMethod b c -> a)
- -> (forall d . ToJSON d => ResponseMessage d -> a)
- -> (forall e . ToJSON e => NotificationMessage ClientMethod e -> a)
- -> FromClientMessage
- -> a
-handleClientMessage request response notification msg = case msg of
- (ReqInitialize m) -> request m
- (ReqShutdown m) -> request m
- (ReqHover m) -> request m
- (ReqCompletion m) -> request m
- (ReqCompletionItemResolve m) -> request m
- (ReqSignatureHelp m) -> request m
- (ReqDefinition m) -> request m
- (ReqFindReferences m) -> request m
- (ReqDocumentHighlights m) -> request m
- (ReqDocumentSymbols m) -> request m
- (ReqWorkspaceSymbols m) -> request m
- (ReqCodeAction m) -> request m
- (ReqCodeLens m) -> request m
- (ReqCodeLensResolve m) -> request m
- (ReqDocumentFormatting m) -> request m
- (ReqDocumentRangeFormatting m) -> request m
- (ReqDocumentOnTypeFormatting m) -> request m
- (ReqPrepareRename m) -> request m
- (ReqRename m) -> request m
- (ReqExecuteCommand m) -> request m
- (ReqDocumentLink m) -> request m
- (ReqDocumentLinkResolve m) -> request m
- (ReqWillSaveWaitUntil m) -> request m
- (ReqImplementation m) -> request m
- (ReqTypeDefinition m) -> request m
- (ReqDocumentColor m) -> request m
- (ReqColorPresentation m) -> request m
- (ReqFoldingRange m) -> request m
- (RspApplyWorkspaceEdit m) -> response m
- (RspFromClient m) -> response m
- (NotInitialized m) -> notification m
- (NotExit m) -> notification m
- (NotCancelRequestFromClient m) -> notification m
- (NotDidChangeConfiguration m) -> notification m
- (NotDidOpenTextDocument m) -> notification m
- (NotDidChangeTextDocument m) -> notification m
- (NotDidCloseTextDocument m) -> notification m
- (NotWillSaveTextDocument m) -> notification m
- (NotDidSaveTextDocument m) -> notification m
- (NotDidChangeWatchedFiles m) -> notification m
- (NotDidChangeWorkspaceFolders m) -> notification m
- (NotWorkDoneProgressCancel m) -> notification m
- (ReqCustomClient m) -> request m
- (NotCustomClient m) -> notification m
+++ /dev/null
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Language.Haskell.LSP.Test.Parsing
- ( -- $receiving
- satisfy
- , satisfyMaybe
- , message
- , anyRequest
- , anyResponse
- , anyNotification
- , anyMessage
- , loggingNotification
- , publishDiagnosticsNotification
- , responseForId
- ) where
-
-import Control.Applicative
-import Control.Concurrent
-import Control.Lens
-import Control.Monad.IO.Class
-import Control.Monad
-import Data.Aeson
-import qualified Data.ByteString.Lazy.Char8 as B
-import Data.Conduit.Parser hiding (named)
-import qualified Data.Conduit.Parser (named)
-import qualified Data.Text as T
-import Data.Typeable
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Types
-import qualified Language.Haskell.LSP.Types.Lens as LSP
-import Language.Haskell.LSP.Test.Messages
-import Language.Haskell.LSP.Test.Session
-
--- $receiving
--- To receive a message, just specify the type that expect:
---
--- @
--- msg1 <- message :: Session ApplyWorkspaceEditRequest
--- msg2 <- message :: Session HoverResponse
--- @
---
--- 'Language.Haskell.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 speicifc sequences of
--- messages that you expect.
---
--- For example, if you wanted to match either a definition or
--- references request:
---
--- > defOrImpl = (message :: Session DefinitionRequest)
--- > <|> (message :: Session ReferencesRequest)
---
--- If you wanted to match any number of telemetry
--- notifications immediately followed by a response:
---
--- @
--- logThenDiags =
--- skipManyTill (message :: Session TelemetryNotification)
--- 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
-satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a
-satisfyMaybe pred = do
-
- skipTimeout <- overridingTimeout <$> get
- timeoutId <- getCurTimeoutId
- unless skipTimeout $ do
- chan <- asks messageChan
- timeout <- asks (messageTimeout . config)
- void $ liftIO $ forkIO $ do
- threadDelay (timeout * 1000000)
- writeChan chan (TimeoutMessage timeoutId)
-
- x <- Session await
-
- unless skipTimeout (bumpTimeoutId timeoutId)
-
- modify $ \s -> s { lastReceivedMessage = Just x }
-
- case pred x of
- Just a -> do
- logMsg LogServer x
- return a
- Nothing -> empty
-
-named :: T.Text -> Session a -> Session a
-named s (Session x) = Session (Data.Conduit.Parser.named s x)
-
--- | Matches a message of type @a@.
-message :: forall a. (Typeable a, FromJSON a) => Session a
-message =
- let parser = decode . encodeMsg :: FromServerMessage -> Maybe a
- in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $
- satisfyMaybe parser
-
--- | Matches if the message is a notification.
-anyNotification :: Session FromServerMessage
-anyNotification = named "Any notification" $ satisfy isServerNotification
-
--- | Matches if the message is a request.
-anyRequest :: Session FromServerMessage
-anyRequest = named "Any request" $ satisfy isServerRequest
-
--- | Matches if the message is a response.
-anyResponse :: Session FromServerMessage
-anyResponse = named "Any response" $ satisfy isServerResponse
-
--- | Matches a response for a specific id.
-responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a)
-responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do
- let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
- satisfyMaybe $ \msg -> do
- z <- parser msg
- guard (z ^. LSP.id == responseId lid)
- pure z
-
--- | Matches any type of message.
-anyMessage :: Session FromServerMessage
-anyMessage = satisfy (const True)
-
--- | A version of encode that encodes FromServerMessages as if they
--- weren't wrapped.
-encodeMsg :: FromServerMessage -> B.ByteString
-encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
-
--- | 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 (NotLogMessage _) = True
- shouldSkip (NotShowMessage _) = True
- shouldSkip (ReqShowMessage _) = True
- shouldSkip _ = False
-
--- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification'
--- (textDocument/publishDiagnostics) notification.
-publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
-publishDiagnosticsNotification = named "Publish diagnostics notification" $
- satisfyMaybe $ \msg -> case msg of
- NotPublishDiagnostics diags -> Just diags
- _ -> Nothing
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeInType #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}
{-|
-Module : Language.Haskell.LSP.Test
+Module : Language.LSP.Test
Description : A functional testing framework for LSP servers.
Maintainer : luke_lau@icloud.com
Stability : experimental
Provides the framework to start functionally testing
<https://github.com/Microsoft/language-server-protocol Language Server Protocol servers>.
-You should import "Language.Haskell.LSP.Types" alongside this.
+You should import "Language.LSP.Types" alongside this.
-}
-module Language.Haskell.LSP.Test
+module Language.LSP.Test
(
-- * Sessions
Session
, runSession
- -- ** Config
, runSessionWithConfig
+ , runSessionWithHandles
+ -- ** Config
, SessionConfig(..)
, defaultConfig
, C.fullCaps
-- ** Exceptions
- , module Language.Haskell.LSP.Test.Exceptions
+ , module Language.LSP.Test.Exceptions
, withTimeout
-- * Sending
, request
, sendNotification
, sendResponse
-- * Receving
- , module Language.Haskell.LSP.Test.Parsing
+ , module Language.LSP.Test.Parsing
-- * Utilities
-- | Quick helper functions for common tasks.
-- ** References
, getReferences
-- ** Definitions
+ , getDeclarations
, getDefinitions
, getTypeDefinitions
+ , getImplementations
-- ** Renaming
, rename
-- ** Hover
import Control.Monad
import Control.Monad.IO.Class
import Control.Exception
-import Control.Lens hiding ((.=), List)
+import Control.Lens hiding ((.=), List, Empty)
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.HashMap.Strict as HashMap
import Data.List
import Data.Maybe
-import Language.Haskell.LSP.Types
-import Language.Haskell.LSP.Types.Lens hiding
+import Language.LSP.Types
+import Language.LSP.Types.Lens hiding
(id, capabilities, message, executeCommand, applyEdit, rename)
-import qualified Language.Haskell.LSP.Types.Lens as LSP
-import qualified Language.Haskell.LSP.Types.Capabilities as C
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.VFS
-import Language.Haskell.LSP.Test.Compat
-import Language.Haskell.LSP.Test.Decoding
-import Language.Haskell.LSP.Test.Exceptions
-import Language.Haskell.LSP.Test.Parsing
-import Language.Haskell.LSP.Test.Session
-import Language.Haskell.LSP.Test.Server
+import qualified Language.LSP.Types.Lens as LSP
+import qualified Language.LSP.Types.Capabilities as C
+import Language.LSP.VFS
+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 System.Directory
import System.FilePath
+import System.Process (ProcessHandle)
import qualified System.FilePath.Glob as Glob
-- | Starts a new session.
-- > diags <- waitForDiagnostics
-- > let pos = Position 12 5
-- > params = TextDocumentPositionParams doc
--- > hover <- request TextDocumentHover params
+-- > hover <- request STextdocumentHover params
runSession :: String -- ^ The command to run the server.
-> C.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 config' serverExe caps rootDir session = do
+ config <- envOverrideConfig config'
+ withServer serverExe (logStdErr config) $ \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
+ -> C.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
+
+
+runSessionWithHandles' :: Maybe ProcessHandle
+ -> Handle -- ^ The input handle
+ -> Handle -- ^ The output handle
+ -> SessionConfig
+ -> C.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' serverProc serverIn serverOut config' caps rootDir session = do
pid <- getCurrentProcessID
absRootDir <- canonicalizePath rootDir
config <- envOverrideConfig config'
- let initializeParams = InitializeParams (Just pid)
+ let initializeParams = InitializeParams Nothing
+ (Just pid)
+ (Just lspTestClientInfo)
(Just $ T.pack absRootDir)
(Just $ filePathToUri absRootDir)
Nothing
caps
(Just TraceOff)
- Nothing
- withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc ->
- runSessionWithHandles serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do
+ (List <$> initialWorkspaceFolders config)
+ runSession' serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do
-- Wrap the session around initialize and shutdown calls
- -- initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse
- initReqId <- sendRequest Initialize initializeParams
+ initReqId <- sendRequest SInitialize initializeParams
-- Because messages can be sent in between the request and response,
-- collect them and then...
- (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId initReqId)
+ (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId SInitialize initReqId)
case initRspMsg ^. LSP.result of
Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error)
initRspVar <- initRsp <$> ask
liftIO $ putMVar initRspVar initRspMsg
- sendNotification Initialized InitializedParams
+ sendNotification SInitialized (Just InitializedParams)
case lspConfig config of
- Just cfg -> sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
+ Just cfg -> sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)
Nothing -> return ()
-- ... relay them back to the user Session so they can match on them!
where
-- | Asks the server to shutdown and exit politely
exitServer :: Session ()
- exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams
+ exitServer = request_ SShutdown Empty >> sendNotification SExit Empty
-- | Listens to the server output until the shutdown ack,
-- makes sure it matches the record and signals any semaphores
listenServer serverOut context = do
msgBytes <- getNextMessage serverOut
- reqMap <- readMVar $ requestMap context
-
- let msg = decodeFromServerMsg reqMap msgBytes
+ msg <- modifyMVar (requestMap context) $ \reqMap ->
+ pure $ decodeFromServerMsg reqMap msgBytes
writeChan (messageChan context) (ServerMessage msg)
case msg of
- (RspShutdown _) -> return ()
+ (FromServerRsp SShutdown _) -> return ()
_ -> listenServer serverOut context
-- | Is this message allowed to be sent by the server between the intialize
-- request and response?
-- https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#initialize
checkLegalBetweenMessage :: FromServerMessage -> Session ()
- checkLegalBetweenMessage (NotShowMessage _) = pure ()
- checkLegalBetweenMessage (NotLogMessage _) = pure ()
- checkLegalBetweenMessage (NotTelemetry _) = pure ()
- checkLegalBetweenMessage (ReqShowMessage _) = pure ()
+ checkLegalBetweenMessage (FromServerMess SWindowShowMessage _) = pure ()
+ checkLegalBetweenMessage (FromServerMess SWindowLogMessage _) = pure ()
+ checkLegalBetweenMessage (FromServerMess STelemetryEvent _) = pure ()
+ checkLegalBetweenMessage (FromServerMess SWindowShowMessageRequest _) = pure ()
checkLegalBetweenMessage msg = throw (IllegalInitSequenceMessage msg)
-- | Check environment variables to override the config
-- and returns the new content
getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
getDocumentEdit doc = do
- req <- message :: Session ApplyWorkspaceEditRequest
+ req <- message SWorkspaceApplyEdit
unless (checkDocumentChanges req || checkChanges req) $
liftIO $ throw (IncorrectApplyEditRequest (show req))
documentContents doc
where
- checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
checkDocumentChanges req =
let changes = req ^. params . edit . documentChanges
maybeDocs = fmap (fmap (^. textDocument . uri)) changes
in case maybeDocs of
Just docs -> (doc ^. uri) `elem` docs
Nothing -> False
- checkChanges :: ApplyWorkspaceEditRequest -> Bool
checkChanges req =
let mMap = req ^. params . edit . changes
in maybe False (HashMap.member (doc ^. 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 TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse
+-- rsp <- request STextDocumentDocumentSymbol params
-- @
-- Note: will skip any messages in between the request and the response.
-request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)
-request m = sendRequest m >=> skipManyTill anyMessage . responseForId
+request :: SClientMethod m -> MessageParams m -> Session (ResponseMessage m)
+request m = sendRequest m >=> skipManyTill anyMessage . responseForId m
-- | The same as 'sendRequest', but discard the response.
-request_ :: ToJSON params => ClientMethod -> params -> Session ()
-request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))
+request_ :: SClientMethod (m :: Method FromClient Request) -> MessageParams m -> Session ()
+request_ p = void . request p
-- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.
sendRequest
- :: ToJSON params
- => ClientMethod -- ^ The request method.
- -> params -- ^ The request parameters.
- -> Session LspId -- ^ The id of the request that was sent.
+ :: SClientMethod m -- ^ The request method.
+ -> MessageParams m -- ^ The request parameters.
+ -> Session (LspId m) -- ^ The id of the request that was sent.
sendRequest method params = do
- id <- curReqId <$> get
- modify $ \c -> c { curReqId = nextId id }
+ idn <- curReqId <$> get
+ modify $ \c -> c { curReqId = idn+1 }
+ let id = IdInt idn
- let req = RequestMessage' "2.0" id method params
+ let mess = RequestMessage "2.0" id method params
-- Update the request map
reqMap <- requestMap <$> ask
liftIO $ modifyMVar_ reqMap $
- \r -> return $ updateRequestMap r id method
+ \r -> return $ fromJust $ updateRequestMap r id method
- sendMessage req
+ ~() <- case splitClientMethod method of
+ IsClientReq -> sendMessage mess
+ IsClientEither -> sendMessage $ ReqMess mess
return id
- where nextId (IdInt i) = IdInt (i + 1)
- nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1
-
--- | A custom type for request message that doesn't
--- need a response type, allows us to infer the request
--- message type without using proxies.
-data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a
-
-instance ToJSON a => ToJSON (RequestMessage' a) where
- toJSON (RequestMessage' rpc id method params) =
- object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
-
-
-- | Sends a notification to the server.
-sendNotification :: ToJSON a
- => ClientMethod -- ^ The notification method.
- -> a -- ^ The notification parameters.
+sendNotification :: SClientMethod (m :: Method FromClient Notification) -- ^ The notification method.
+ -> MessageParams m -- ^ The notification parameters.
-> Session ()
-
-- Open a virtual file if we send a did open text document notification
-sendNotification TextDocumentDidOpen params = do
- let params' = fromJust $ decode $ encode params
- n :: DidOpenTextDocumentNotification
- n = NotificationMessage "2.0" TextDocumentDidOpen params'
+sendNotification STextDocumentDidOpen params = do
+ let n = NotificationMessage "2.0" STextDocumentDidOpen params
oldVFS <- vfs <$> get
let (newVFS,_) = openVFS oldVFS n
modify (\s -> s { vfs = newVFS })
sendMessage n
-- Close a virtual file if we send a close text document notification
-sendNotification TextDocumentDidClose params = do
- let params' = fromJust $ decode $ encode params
- n :: DidCloseTextDocumentNotification
- n = NotificationMessage "2.0" TextDocumentDidClose params'
+sendNotification STextDocumentDidClose params = do
+ let n = NotificationMessage "2.0" STextDocumentDidClose params
oldVFS <- vfs <$> get
let (newVFS,_) = closeVFS oldVFS n
modify (\s -> s { vfs = newVFS })
sendMessage n
-sendNotification TextDocumentDidChange params = do
- let params' = fromJust $ decode $ encode params
- n :: DidChangeTextDocumentNotification
- n = NotificationMessage "2.0" TextDocumentDidChange params'
+sendNotification STextDocumentDidChange params = do
+ let n = NotificationMessage "2.0" STextDocumentDidChange params
oldVFS <- vfs <$> get
let (newVFS,_) = changeFromClientVFS oldVFS n
modify (\s -> s { vfs = newVFS })
sendMessage n
-sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
+sendNotification method params =
+ case splitClientMethod method of
+ IsClientNot -> sendMessage (NotificationMessage "2.0" method params)
+ IsClientEither -> sendMessage (NotMess $ NotificationMessage "2.0" method params)
-- | Sends a response to the server.
-sendResponse :: ToJSON a => ResponseMessage a -> Session ()
+sendResponse :: ToJSON (ResponseResult m) => ResponseMessage m -> Session ()
sendResponse = sendMessage
-- | Returns the initialize response that was received from the server.
-- The initialize requests and responses are not included the session,
-- so if you need to test it use this.
-initializeResponse :: Session InitializeResponse
+initializeResponse :: Session (ResponseMessage Initialize)
initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
-- | /Creates/ a new text document. This is different from 'openDoc'
rootDir <- asks rootDir
caps <- asks sessionCapabilities
absFile <- liftIO $ canonicalizePath (rootDir </> file)
- let regs = filter (\r -> r ^. method == WorkspaceDidChangeWatchedFiles) $
- Map.elems dynCaps
+ let pred :: SomeRegistration -> [Registration WorkspaceDidChangeWatchedFiles]
+ pred (SomeRegistration r@(Registration _ SWorkspaceDidChangeWatchedFiles _)) = [r]
+ pred _ = mempty
+ regs = concatMap pred $ Map.elems dynCaps
watchHits :: FileSystemWatcher -> Bool
watchHits (FileSystemWatcher pattern kind) =
-- If WatchKind is exlcuded, defaults to all true as per spec
createHits (WatchKind create _ _) = create
- regHits :: Registration -> Bool
- regHits reg = isJust $ do
- opts <- reg ^. registerOptions
- fileWatchOpts <- case fromJSON opts :: Result DidChangeWatchedFilesRegistrationOptions of
- Success x -> Just x
- Error _ -> Nothing
- if foldl' (\acc w -> acc || watchHits w) False (fileWatchOpts ^. watchers)
- then Just ()
- else Nothing
+ regHits :: Registration WorkspaceDidChangeWatchedFiles -> Bool
+ regHits reg = foldl' (\acc w -> acc || watchHits w) False (reg ^. registerOptions . watchers)
clientCapsSupports =
caps ^? workspace . _Just . didChangeWatchedFiles . _Just . dynamicRegistration . _Just
shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs
when shouldSend $
- sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
+ sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
List [ FileEvent (filePathToUri (rootDir </> file)) FcCreated ]
openDoc' file languageId contents
let fp = rootDir context </> file
uri = filePathToUri fp
item = TextDocumentItem uri (T.pack languageId) 0 contents
- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
+ sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams item)
pure $ TextDocumentIdentifier uri
-- | Closes a text document and sends a textDocument/didOpen notification to the server.
closeDoc :: TextDocumentIdentifier -> Session ()
closeDoc docId = do
let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
- sendNotification TextDocumentDidClose params
+ sendNotification STextDocumentDidClose params
-- | Changes a text document and sends a textDocument/didOpen notification to the server.
changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
changeDoc docId changes = do
verDoc <- getVersionedDoc docId
let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)
- sendNotification TextDocumentDidChange params
+ sendNotification STextDocumentDidChange params
-- | Gets the Uri for the file corrected to the session directory.
getDocUri :: FilePath -> Session Uri
-- | Waits for diagnostics to be published and returns them.
waitForDiagnostics :: Session [Diagnostic]
waitForDiagnostics = do
- diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
+ diagsNot <- skipManyTill anyMessage (message STextDocumentPublishDiagnostics)
let (List diags) = diagsNot ^. params . LSP.diagnostics
return diags
-- | The same as 'waitForDiagnostics', but will only match a specific
--- 'Language.Haskell.LSP.Types._source'.
+-- 'Language.LSP.Types._source'.
waitForDiagnosticsSource :: String -> Session [Diagnostic]
waitForDiagnosticsSource src = do
diags <- waitForDiagnostics
-- returned.
noDiagnostics :: Session ()
noDiagnostics = do
- diagsNot <- message :: Session PublishDiagnosticsNotification
+ diagsNot <- message STextDocumentPublishDiagnostics
when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics
-- | Returns the symbols in a document.
getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
getDocumentSymbols doc = do
- ResponseMessage _ rspLid res <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse
+ ResponseMessage _ rspLid res <- request STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc)
case res of
- Right (DSDocumentSymbols (List xs)) -> return (Left xs)
- Right (DSSymbolInformation (List xs)) -> return (Right xs)
- Left err -> throw (UnexpectedResponseError rspLid err)
+ Right (InL (List xs)) -> return (Left xs)
+ Right (InR (List xs)) -> return (Right xs)
+ Left err -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) err)
-- | Returns the code actions in the specified range.
-getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
+getCodeActions :: TextDocumentIdentifier -> Range -> Session [Command |? CodeAction]
getCodeActions doc range = do
ctx <- getCodeActionContext doc
- rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx Nothing)
+ rsp <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc range ctx)
case rsp ^. result of
Right (List xs) -> return xs
- Left error -> throw (UnexpectedResponseError (rsp ^. LSP.id) error)
+ Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) error)
-- | Returns all the code actions in a document by
-- querying the code actions at each of the current
-- diagnostics' positions.
-getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]
+getAllCodeActions :: TextDocumentIdentifier -> Session [Command |? CodeAction]
getAllCodeActions doc = do
ctx <- getCodeActionContext doc
foldM (go ctx) [] =<< getCurrentDiagnostics doc
where
- go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
+ go :: CodeActionContext -> [Command |? CodeAction] -> Diagnostic -> Session [Command |? CodeAction]
go ctx acc diag = do
- ResponseMessage _ rspLid res <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing)
+ ResponseMessage _ rspLid res <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. range) ctx)
case res of
- Left e -> throw (UnexpectedResponseError rspLid e)
+ Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e)
Right (List cmdOrCAs) -> pure (acc ++ cmdOrCAs)
getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
executeCommand :: Command -> Session ()
executeCommand cmd = do
let args = decode $ encode $ fromJust $ cmd ^. arguments
- execParams = ExecuteCommandParams (cmd ^. command) args Nothing
- request_ WorkspaceExecuteCommand execParams
+ execParams = ExecuteCommandParams Nothing (cmd ^. command) args
+ void $ sendRequest SWorkspaceExecuteCommand execParams
-- | Executes a code action.
-- Matching with the specification, if a code action
where handleEdit :: WorkspaceEdit -> Session ()
handleEdit e =
-- Its ok to pass in dummy parameters here as they aren't used
- let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
- in updateState (ReqApplyWorkspaceEdit req)
+ let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e)
+ in updateState (FromServerMess SWorkspaceApplyEdit req)
-- | Adds the current version to the document, as tracked by the session.
getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier
caps <- asks sessionCapabilities
let supportsDocChanges = fromMaybe False $ do
- let mWorkspace = C._workspace caps
+ let mWorkspace = caps ^. LSP.workspace
C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
- C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
+ C.WorkspaceEditClientCapabilities mDocChanges _ _ <- mEdit
mDocChanges
let wEdit = if supportsDocChanges
let changes = HashMap.singleton (doc ^. uri) (List [edit])
in WorkspaceEdit (Just changes) Nothing
- let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
- updateState (ReqApplyWorkspaceEdit req)
+ let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)
+ updateState (FromServerMess SWorkspaceApplyEdit req)
-- version may have changed
getVersionedDoc doc
-- | Returns the completions for the position in the document.
getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
getCompletions doc pos = do
- rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos Nothing)
+ rsp <- request STextDocumentCompletion (CompletionParams doc pos Nothing Nothing Nothing)
case getResponseResult rsp of
- Completions (List items) -> return items
- CompletionList (CompletionListType _ (List items)) -> return items
+ InL (List items) -> return items
+ InR (CompletionList _ (List items)) -> return items
-- | 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.
+ -> Session (List Location) -- ^ The locations of the references.
getReferences doc pos inclDecl =
let ctx = ReferenceContext inclDecl
- params = ReferenceParams doc pos ctx Nothing
- in getResponseResult <$> request TextDocumentReferences params
+ params = ReferenceParams doc pos Nothing Nothing ctx
+ in getResponseResult <$> request STextDocumentReferences params
+
+-- | Returns the declarations(s) for the term at the specified position.
+getDeclarations :: TextDocumentIdentifier -- ^ The document the term is in.
+ -> Position -- ^ The position the term is at.
+ -> Session ([Location] |? [LocationLink])
+getDeclarations = getDeclarationyRequest STextDocumentDeclaration DeclarationParams
-- | Returns the definition(s) for the term at the specified position.
getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
-> Position -- ^ The position the term is at.
- -> Session [Location] -- ^ The location(s) of the definitions
-getDefinitions doc pos = do
- let params = TextDocumentPositionParams doc pos Nothing
- rsp <- request TextDocumentDefinition params :: Session DefinitionResponse
- case getResponseResult rsp of
- SingleLoc loc -> pure [loc]
- MultiLoc locs -> pure locs
+ -> Session ([Location] |? [LocationLink])
+getDefinitions = getDeclarationyRequest STextDocumentDefinition DefinitionParams
-- | Returns the type definition(s) for the term at the specified position.
getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.
-> Position -- ^ The position the term is at.
- -> Session [Location] -- ^ The location(s) of the definitions
-getTypeDefinitions doc pos = do
- let params = TextDocumentPositionParams doc pos Nothing
- rsp <- request TextDocumentTypeDefinition params :: Session TypeDefinitionResponse
+ -> Session ([Location] |? [LocationLink])
+getTypeDefinitions = getDeclarationyRequest STextDocumentTypeDefinition TypeDefinitionParams
+
+-- | Returns the type definition(s) for the term at the specified position.
+getImplementations :: TextDocumentIdentifier -- ^ The document the term is in.
+ -> Position -- ^ The position the term is at.
+ -> Session ([Location] |? [LocationLink])
+getImplementations = getDeclarationyRequest STextDocumentImplementation ImplementationParams
+
+
+getDeclarationyRequest :: (ResponseResult m ~ (Location |? (List Location |? List LocationLink)))
+ => SClientMethod m
+ -> (TextDocumentIdentifier
+ -> Position
+ -> Maybe ProgressToken
+ -> Maybe ProgressToken
+ -> MessageParams m)
+ -> TextDocumentIdentifier
+ -> Position
+ -> Session ([Location] |? [LocationLink])
+getDeclarationyRequest method paramCons doc pos = do
+ let params = paramCons doc pos Nothing Nothing
+ rsp <- request method params
case getResponseResult rsp of
- SingleLoc loc -> pure [loc]
- MultiLoc locs -> pure locs
+ InL loc -> pure (InL [loc])
+ InR (InL (List locs)) -> pure (InL locs)
+ InR (InR (List locLinks)) -> pure (InR locLinks)
-- | Renames the term at the specified position.
rename :: TextDocumentIdentifier -> Position -> String -> Session ()
rename doc pos newName = do
- let params = RenameParams doc pos (T.pack newName) Nothing
- rsp <- request TextDocumentRename params :: Session RenameResponse
+ let params = RenameParams doc pos Nothing (T.pack newName)
+ rsp <- request STextDocumentRename params
let wEdit = getResponseResult rsp
- req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
- updateState (ReqApplyWorkspaceEdit req)
+ req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)
+ updateState (FromServerMess SWorkspaceApplyEdit req)
-- | Returns the hover information at the specified position.
getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
getHover doc pos =
- let params = TextDocumentPositionParams doc pos Nothing
- in getResponseResult <$> request TextDocumentHover params
+ let params = HoverParams doc pos Nothing
+ in getResponseResult <$> request STextDocumentHover params
-- | Returns the highlighted occurences of the term at the specified position
-getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
+getHighlights :: TextDocumentIdentifier -> Position -> Session (List DocumentHighlight)
getHighlights doc pos =
- let params = TextDocumentPositionParams doc pos Nothing
- in getResponseResult <$> request TextDocumentDocumentHighlight params
+ let params = DocumentHighlightParams doc pos Nothing Nothing
+ in getResponseResult <$> request STextDocumentDocumentHighlight params
-- | Checks the response for errors and throws an exception if needed.
-- Returns the result if successful.
-getResponseResult :: ResponseMessage a -> a
+getResponseResult :: ResponseMessage m -> ResponseResult m
getResponseResult rsp =
case rsp ^. result of
Right x -> x
- Left err -> throw $ UnexpectedResponseError (rsp ^. LSP.id) err
+ Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) err
-- | Applies formatting to the specified document.
formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
formatDoc doc opts = do
- let params = DocumentFormattingParams doc opts Nothing
- edits <- getResponseResult <$> request TextDocumentFormatting params
+ let params = DocumentFormattingParams Nothing doc opts
+ edits <- getResponseResult <$> request STextDocumentFormatting params
applyTextEdits doc edits
-- | Applies formatting to the specified range in a document.
formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
formatRange doc opts range = do
- let params = DocumentRangeFormattingParams doc range opts Nothing
- edits <- getResponseResult <$> request TextDocumentRangeFormatting params
+ let params = DocumentRangeFormattingParams Nothing doc range opts
+ edits <- getResponseResult <$> request STextDocumentRangeFormatting params
applyTextEdits doc edits
applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()
applyTextEdits doc edits =
let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing
-- Send a dummy message to updateState so it can do bookkeeping
- req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
- in updateState (ReqApplyWorkspaceEdit req)
+ req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)
+ in updateState (FromServerMess SWorkspaceApplyEdit req)
-- | Returns the code lenses for the specified document.
getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens]
getCodeLenses tId = do
- rsp <- request TextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse
+ rsp <- request STextDocumentCodeLens (CodeLensParams Nothing Nothing tId)
case getResponseResult rsp of
List res -> pure res
-- register during the 'Session'.
--
-- @since 0.11.0.0
-getRegisteredCapabilities :: Session [Registration]
+getRegisteredCapabilities :: Session [SomeRegistration]
getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, OverloadedStrings #-}
-- For some reason ghc warns about not using
-- Control.Monad.IO.Class but it's needed for
-- MonadIO
{-# OPTIONS_GHC -Wunused-imports #-}
-module Language.Haskell.LSP.Test.Compat where
+module Language.LSP.Test.Compat where
import Data.Maybe
import System.IO
+import Language.LSP.Types
#if MIN_VERSION_process(1,6,3)
-- We have to hide cleanupProcess for process-1.6.3.0
(\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)
#endif
+
+
+lspTestClientInfo :: ClientInfo
+lspTestClientInfo = ClientInfo "lsp-test" (Just CURRENT_PACKAGE_VERSION)
--- /dev/null
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# 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.Types
+import Language.LSP.Types.Lens
+import Language.LSP.Test.Exceptions
+
+import Data.IxMap
+import Data.Kind
+
+getAllMessages :: Handle -> IO [B.ByteString]
+getAllMessages h = do
+ done <- hIsEOF h
+ if done
+ then return []
+ else do
+ msg <- getNextMessage h
+
+ (msg :) <$> getAllMessages h
+
+-- | 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
+ 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
+ ]
+
+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
+
+type RequestMap = IxMap LspId (SMethod :: Method FromClient Request -> Type )
+
+newRequestMap :: RequestMap
+newRequestMap = emptyIxMap
+
+updateRequestMap :: RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap
+updateRequestMap reqMap id method = insertIxMap id method reqMap
+
+getRequestMap :: [FromClientMessage] -> RequestMap
+getRequestMap = foldl' helper emptyIxMap
+ where
+ helper :: RequestMap -> FromClientMessage -> RequestMap
+ helper acc msg = case msg of
+ FromClientMess m mess -> case splitClientMethod m of
+ IsClientNot -> acc
+ IsClientReq -> fromJust $ updateRequestMap acc (mess ^. id) m
+ IsClientEither -> case mess of
+ NotMess _ -> acc
+ ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. id) m
+ _ -> acc
+
+decodeFromServerMsg :: RequestMap -> B.ByteString -> (RequestMap, FromServerMessage)
+decodeFromServerMsg reqMap bytes = unP $ fromJust $ parseMaybe 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 (FromServerMess m msg) = (reqMap, FromServerMess m msg)
+ unP (FromServerRsp (Pair m (Const newMap)) msg) = (newMap, FromServerRsp m msg)
+ {-
+ 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
+ -}
-module Language.Haskell.LSP.Test.Exceptions where
+module Language.LSP.Test.Exceptions where
import Control.Exception
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Types
+import Language.LSP.Types
import Data.Aeson
import Data.Aeson.Encode.Pretty
import Data.Algorithm.Diff
| ReplayOutOfOrder FromServerMessage [FromServerMessage]
| UnexpectedDiagnostics
| IncorrectApplyEditRequest String
- | UnexpectedResponseError LspIdRsp ResponseError
+ | UnexpectedResponseError SomeLspId ResponseError
| UnexpectedServerTermination
| IllegalInitSequenceMessage FromServerMessage
deriving Eq
show (UnexpectedMessage expected lastMsg) =
"Received an unexpected message from the server:\n" ++
"Was parsing: " ++ expected ++ "\n" ++
- "Last message received:\n" ++ B.unpack (encodePretty lastMsg)
+ "But the last message received was:\n" ++ B.unpack (encodePretty lastMsg)
show (ReplayOutOfOrder received expected) =
let expected' = nub expected
getJsonDiff = lines . B.unpack . encodePretty
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
-module Language.Haskell.LSP.Test.Files
+module Language.LSP.Test.Files
( swapFiles
, rootDir
)
where
-import Language.Haskell.LSP.Capture
-import Language.Haskell.LSP.Types
-import Language.Haskell.LSP.Types.Lens
-import Language.Haskell.LSP.Messages
+import Language.LSP.Types
+import Language.LSP.Types.Lens
import Control.Lens
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import Data.Maybe
import System.Directory
import System.FilePath
+import Data.Time.Clock
+
+data Event
+ = ClientEv UTCTime FromClientMessage
+ | ServerEv UTCTime FromServerMessage
swapFiles :: FilePath -> [Event] -> IO [Event]
swapFiles relCurBaseDir msgs = do
return newMsgs
rootDir :: [Event] -> FilePath
-rootDir (FromClient _ (ReqInitialize req):_) =
+rootDir (ClientEv _ (FromClientMess SInitialize req):_) =
fromMaybe (error "Couldn't find root dir") $ do
rootUri <- req ^. params .rootUri
uriToFilePath rootUri
mapUris :: (Uri -> Uri) -> Event -> Event
mapUris f event =
case event of
- FromClient t msg -> FromClient t (fromClientMsg msg)
- FromServer t msg -> FromServer t (fromServerMsg msg)
+ 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 (NotDidOpenTextDocument n) = NotDidOpenTextDocument $ swapUri (params . textDocument) n
- fromClientMsg (NotDidChangeTextDocument n) = NotDidChangeTextDocument $ swapUri (params . textDocument) n
- fromClientMsg (NotWillSaveTextDocument n) = NotWillSaveTextDocument $ swapUri (params . textDocument) n
- fromClientMsg (NotDidSaveTextDocument n) = NotDidSaveTextDocument $ swapUri (params . textDocument) n
- fromClientMsg (NotDidCloseTextDocument n) = NotDidCloseTextDocument $ swapUri (params . textDocument) n
- fromClientMsg (ReqInitialize r) = ReqInitialize $ params .~ transformInit (r ^. params) $ r
- fromClientMsg (ReqDocumentSymbols r) = ReqDocumentSymbols $ swapUri (params . textDocument) r
- fromClientMsg (ReqRename r) = ReqRename $ swapUri (params . textDocument) r
+ fromClientMsg (FromClientMess m@SInitialize r) = FromClientMess m $ params .~ transformInit (r ^. params) $ r
+ fromClientMsg (FromClientMess m@STextDocumentDidOpen n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentDidChange n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentWillSave n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentDidSave n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentDidClose n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentDocumentSymbol n) = FromClientMess m $ swapUri (params . textDocument) n
+ fromClientMsg (FromClientMess m@STextDocumentRename n) = FromClientMess m $ swapUri (params . textDocument) n
fromClientMsg x = x
fromServerMsg :: FromServerMessage -> FromServerMessage
- fromServerMsg (ReqApplyWorkspaceEdit r) =
- ReqApplyWorkspaceEdit $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r
-
- fromServerMsg (NotPublishDiagnostics n) = NotPublishDiagnostics $ swapUri params n
-
- fromServerMsg (RspDocumentSymbols r) =
- let swapUri' (DSSymbolInformation si) = DSSymbolInformation (swapUri location <$> si)
- swapUri' (DSDocumentSymbols dss) = DSDocumentSymbols dss -- no file locations here
- in RspDocumentSymbols $ r & result %~ (fmap swapUri')
-
- fromServerMsg (RspRename r) = RspRename $ r & result %~ (fmap swapWorkspaceEdit)
-
+ fromServerMsg (FromServerMess m@SWorkspaceApplyEdit r) = FromServerMess m $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r
+ fromServerMsg (FromServerMess m@STextDocumentPublishDiagnostics n) = FromServerMess m $ swapUri params n
+ fromServerMsg (FromServerRsp m@STextDocumentDocumentSymbol r) =
+ let swapUri' :: (List DocumentSymbol |? List SymbolInformation) -> List DocumentSymbol |? List SymbolInformation
+ swapUri' (InR si) = InR (swapUri location <$> si)
+ swapUri' (InL dss) = InL dss -- no file locations here
+ in FromServerRsp m $ r & result %~ (fmap swapUri')
+ fromServerMsg (FromServerRsp m@STextDocumentRename r) = FromServerRsp m $ r & result %~ (fmap swapWorkspaceEdit)
fromServerMsg x = x
swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit
--- /dev/null
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Language.LSP.Test.Parsing
+ ( -- $receiving
+ satisfy
+ , satisfyMaybe
+ , message
+ , response
+ , responseForId
+ , customRequest
+ , customNotification
+ , anyRequest
+ , anyResponse
+ , anyNotification
+ , anyMessage
+ , loggingNotification
+ , publishDiagnosticsNotification
+ ) where
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Monad.IO.Class
+import Control.Monad
+import Data.Conduit.Parser hiding (named)
+import qualified Data.Conduit.Parser (named)
+import qualified Data.Text as T
+import Data.Typeable
+import Language.LSP.Types
+import Language.LSP.Test.Session
+
+-- $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 speicifc 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
+satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a
+satisfyMaybe pred = satisfyMaybeM (pure . pred)
+
+satisfyMaybeM :: (FromServerMessage -> Session (Maybe a)) -> Session a
+satisfyMaybeM pred = do
+
+ skipTimeout <- overridingTimeout <$> get
+ timeoutId <- getCurTimeoutId
+ unless skipTimeout $ do
+ chan <- asks messageChan
+ timeout <- asks (messageTimeout . config)
+ void $ liftIO $ forkIO $ do
+ threadDelay (timeout * 1000000)
+ writeChan chan (TimeoutMessage timeoutId)
+
+ x <- Session await
+
+ unless skipTimeout (bumpTimeoutId timeoutId)
+
+ modify $ \s -> s { lastReceivedMessage = Just x }
+
+ res <- pred x
+
+ case res of
+ Just a -> do
+ logMsg LogServer x
+ return a
+ Nothing -> empty
+
+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.
+message :: SServerMethod m -> Session (ServerMessage m)
+message m1 = named (T.pack $ show m1) $ satisfyMaybe $ \case
+ FromServerMess m2 msg -> do
+ HRefl <- mEqServer m1 m2
+ pure msg
+ _ -> Nothing
+
+customRequest :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Request))
+customRequest m = named m $ satisfyMaybe $ \case
+ FromServerMess m1 msg -> case splitServerMethod m1 of
+ IsServerEither -> case msg of
+ ReqMess _ | m1 == SCustomMethod m -> Just msg
+ _ -> Nothing
+ _ -> Nothing
+ _ -> Nothing
+
+customNotification :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Notification))
+customNotification m = named m $ satisfyMaybe $ \case
+ FromServerMess m1 msg -> case splitServerMethod m1 of
+ IsServerEither -> case msg of
+ NotMess _ | m1 == SCustomMethod m -> Just msg
+ _ -> Nothing
+ _ -> Nothing
+ _ -> Nothing
+
+-- | Matches if the message is a notification.
+anyNotification :: Session FromServerMessage
+anyNotification = named "Any notification" $ satisfy $ \case
+ FromServerMess m msg -> case splitServerMethod m of
+ IsServerNot -> True
+ IsServerEither -> case msg of
+ NotMess _ -> True
+ _ -> False
+ _ -> False
+ FromServerRsp _ _ -> False
+
+-- | Matches if the message is a request.
+anyRequest :: Session FromServerMessage
+anyRequest = named "Any request" $ satisfy $ \case
+ FromServerMess m _ -> case splitServerMethod m of
+ IsServerReq -> True
+ _ -> False
+ FromServerRsp _ _ -> False
+
+-- | Matches if the message is a response.
+anyResponse :: Session FromServerMessage
+anyResponse = named "Any response" $ satisfy $ \case
+ FromServerMess _ _ -> False
+ FromServerRsp _ _ -> True
+
+-- | Matches a response coming from the server.
+response :: SMethod (m :: Method FromClient Request) -> Session (ResponseMessage m)
+response m1 = named (T.pack $ show m1) $ satisfyMaybe $ \case
+ FromServerRsp m2 msg -> do
+ HRefl <- mEqClient m1 m2
+ pure msg
+ _ -> Nothing
+
+-- | Like 'response', but matches a response for a specific id.
+responseForId :: SMethod (m :: Method FromClient Request) -> LspId m -> Session (ResponseMessage m)
+responseForId m lid = named (T.pack $ "Response for id: " ++ show lid) $ do
+ satisfyMaybe $ \msg -> do
+ case msg of
+ FromServerMess _ _ -> Nothing
+ FromServerRsp m' rspMsg@(ResponseMessage _ lid' _) ->
+ case mEqClient m m' of
+ Just HRefl -> do
+ guard (lid' == Just lid)
+ pure rspMsg
+ Nothing
+ | SCustomMethod tm <- m
+ , SCustomMethod tm' <- m'
+ , tm == tm'
+ , lid' == Just lid -> pure rspMsg
+ _ -> empty
+
+-- | Matches any type of message.
+anyMessage :: Session FromServerMessage
+anyMessage = satisfy (const True)
+
+-- | 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 SWindowLogMessage _) = True
+ shouldSkip (FromServerMess SWindowShowMessage _) = True
+ shouldSkip (FromServerMess SWindowShowMessageRequest _) = True
+ shouldSkip _ = False
+
+-- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics'
+-- (textDocument/publishDiagnostics) notification.
+publishDiagnosticsNotification :: Session (Message TextDocumentPublishDiagnostics)
+publishDiagnosticsNotification = named "Publish diagnostics notification" $
+ satisfyMaybe $ \msg -> case msg of
+ FromServerMess STextDocumentPublishDiagnostics diags -> Just diags
+ _ -> Nothing
-- | A testing tool for replaying captured client logs back to a server,
-- and validating that the server output matches up with another log.
-module Language.Haskell.LSP.Test.Replay
- ( replaySession
+module Language.LSP.Test.Replay
+ ( -- replaySession
)
where
import Control.Monad.IO.Class
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.Text as T
-import Language.Haskell.LSP.Capture
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Types
-import Language.Haskell.LSP.Types.Lens as LSP
+import Language.LSP.Types
+import Language.LSP.Types.Lens as LSP
import Data.Aeson
import Data.Default
import Data.List
import Control.Monad
import System.FilePath
import System.IO
-import Language.Haskell.LSP.Test
-import Language.Haskell.LSP.Test.Compat
-import Language.Haskell.LSP.Test.Files
-import Language.Haskell.LSP.Test.Decoding
-import Language.Haskell.LSP.Test.Messages
-import Language.Haskell.LSP.Test.Server
-import Language.Haskell.LSP.Test.Session
-
+import Language.LSP.Test
+import Language.LSP.Test.Compat
+import Language.LSP.Test.Files
+import Language.LSP.Test.Decoding
+import Language.LSP.Test.Server
+import Language.LSP.Test.Session
+
+{-
-- | Replays a captured client output and
-- makes sure it matches up with an expected response.
-- The session directory should have a captured session file in it
swapPid pid t
| hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t
| otherwise = t
+-}
-module Language.Haskell.LSP.Test.Server (withServer) where
+module Language.LSP.Test.Server (withServer) where
import Control.Concurrent.Async
import Control.Monad
-import Language.Haskell.LSP.Test.Compat
+import Language.LSP.Test.Compat
import System.IO
import System.Process hiding (withCreateProcess)
{-# LANGUAGE CPP #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeInType #-}
-module Language.Haskell.LSP.Test.Session
+module Language.LSP.Test.Session
( Session(..)
, SessionConfig(..)
, defaultConfig
, SessionMessage(..)
, SessionContext(..)
, SessionState(..)
- , runSessionWithHandles
+ , runSession'
, get
, put
, modify
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe
import Data.Function
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Types.Capabilities
-import Language.Haskell.LSP.Types
-import Language.Haskell.LSP.Types.Lens
-import qualified Language.Haskell.LSP.Types.Lens as LSP
-import Language.Haskell.LSP.VFS
-import Language.Haskell.LSP.Test.Compat
-import Language.Haskell.LSP.Test.Decoding
-import Language.Haskell.LSP.Test.Exceptions
+import Language.LSP.Types.Capabilities
+import Language.LSP.Types
+import Language.LSP.Types.Lens
+import qualified Language.LSP.Types.Lens as LSP
+import Language.LSP.VFS
+import Language.LSP.Test.Compat
+import Language.LSP.Test.Decoding
+import Language.LSP.Test.Exceptions
import System.Console.ANSI
import System.Directory
import System.IO
-- | A session representing one instance of launching and connecting to a server.
--
-- You can send and receive messages to the server within 'Session' via
--- 'Language.Haskell.LSP.Test.message',
--- 'Language.Haskell.LSP.Test.sendRequest' and
--- 'Language.Haskell.LSP.Test.sendNotification'.
+-- 'Language.LSP.Test.message',
+-- 'Language.LSP.Test.sendRequest' and
+-- 'Language.LSP.Test.sendNotification'.
newtype Session a = Session (ConduitParser FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) a)
deriving (Functor, Applicative, Monad, MonadIO, Alternative)
, logColor :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.
, lspConfig :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing.
, ignoreLogNotifications :: Bool
- -- ^ Whether or not to ignore 'Language.Haskell.LSP.Types.ShowMessageNotification' and
- -- 'Language.Haskell.LSP.Types.LogMessageNotification', defaults to False.
+ -- ^ Whether or not to ignore 'Language.LSP.Types.ShowMessageNotification' and
+ -- 'Language.LSP.Types.LogMessageNotification', defaults to False.
--
-- @since 0.9.0.0
+ , initialWorkspaceFolders :: Maybe [WorkspaceFolder]
+ -- ^ The initial workspace folders to send in the @initialize@ request.
+ -- Defaults to Nothing.
}
--- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.
+-- | The configuration used in 'Language.LSP.Test.runSession'.
defaultConfig :: SessionConfig
-defaultConfig = SessionConfig 60 False False True Nothing False
+defaultConfig = SessionConfig 60 False False True Nothing False Nothing
instance Default SessionConfig where
def = defaultConfig
-- Keep curTimeoutId in SessionContext, as its tied to messageChan
, curTimeoutId :: MVar Int -- ^ The current timeout we are waiting on
, requestMap :: MVar RequestMap
- , initRsp :: MVar InitializeResponse
+ , initRsp :: MVar (ResponseMessage Initialize)
, config :: SessionConfig
, sessionCapabilities :: ClientCapabilities
}
data SessionState = SessionState
{
- curReqId :: LspId
+ curReqId :: Int
, vfs :: VFS
, curDiagnostics :: Map.Map NormalizedUri [Diagnostic]
, overridingTimeout :: Bool
-- ^ The last received message from the server.
-- Used for providing exception information
, lastReceivedMessage :: Maybe FromServerMessage
- , curDynCaps :: Map.Map T.Text Registration
+ , curDynCaps :: Map.Map T.Text SomeRegistration
-- ^ The capabilities that the server has dynamically registered with us so
-- far
}
get = lift get
put = lift . put
-runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
-runSession context state (Session session) = runReaderT (runStateT conduit state) context
+runSessionMonad :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
+runSessionMonad context state (Session session) = runReaderT (runStateT conduit state) context
where
conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
yield msg
chanSource
- isLogNotification (ServerMessage (NotShowMessage _)) = True
- isLogNotification (ServerMessage (NotLogMessage _)) = True
+ isLogNotification (ServerMessage (FromServerMess SWindowShowMessage _)) = True
+ isLogNotification (ServerMessage (FromServerMess SWindowLogMessage _)) = True
isLogNotification _ = False
watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
-- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
-- It also does not automatically send initialize and exit messages.
-runSessionWithHandles :: Handle -- ^ Server in
+runSession' :: Handle -- ^ Server in
-> Handle -- ^ Server out
- -> ProcessHandle -- ^ Server process
+ -> Maybe ProcessHandle -- ^ Server process
-> (Handle -> SessionContext -> IO ()) -- ^ Server listener
-> SessionConfig
-> ClientCapabilities
-> Session () -- ^ To exit the Server properly
-> Session a
-> IO a
-runSessionWithHandles serverIn serverOut serverProc serverHandler config caps rootDir exitServer session = do
+runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exitServer session = do
absRootDir <- canonicalizePath rootDir
hSetBuffering serverIn NoBuffering
mainThreadId <- myThreadId
let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps
- initState vfs = SessionState (IdInt 0) vfs mempty False Nothing mempty
- runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses
+ initState vfs = SessionState 0 vfs mempty False Nothing mempty
+ runSession' ses = initVFS $ \vfs -> runSessionMonad context (initState vfs) ses
errorHandler = throwTo mainThreadId :: SessionException -> IO ()
serverListenerLauncher =
forkIO $ catch (serverHandler serverOut context) errorHandler
- server = (Just serverIn, Just serverOut, Nothing, serverProc)
msgTimeoutMs = messageTimeout config * 10^6
serverAndListenerFinalizer tid = do
- finally (timeout msgTimeoutMs (runSession' exitServer)) $ do
- -- Make sure to kill the listener first, before closing
- -- handles etc via cleanupProcess
- killThread tid
+ let cleanup
+ | Just sp <- mServerProc = do
-- Give the server some time to exit cleanly
-- It makes the server hangs in windows so we have to avoid it
#ifndef mingw32_HOST_OS
- timeout msgTimeoutMs (waitForProcess serverProc)
+ timeout msgTimeoutMs (waitForProcess sp)
#endif
- cleanupProcess server
+ cleanupProcess (Just serverIn, Just serverOut, Nothing, sp)
+ | otherwise = pure ()
+ finally (timeout msgTimeoutMs (runSession' exitServer))
+ -- Make sure to kill the listener first, before closing
+ -- handles etc via cleanupProcess
+ (killThread tid >> cleanup)
(result, _) <- bracket serverListenerLauncher
serverAndListenerFinalizer
- (const $ runSession' session)
+ (const $ initVFS $ \vfs -> runSessionMonad context (initState vfs) session)
return result
updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()
=> FromServerMessage -> m ()
-- Keep track of dynamic capability registration
-updateState (ReqRegisterCapability req) = do
- let List newRegs = (\r -> (r ^. LSP.id, r)) <$> req ^. params . registrations
+updateState (FromServerMess SClientRegisterCapability req) = do
+ let List newRegs = (\sr@(SomeRegistration r) -> (r ^. LSP.id, sr)) <$> req ^. params . registrations
modify $ \s ->
s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) }
-updateState (ReqUnregisterCapability req) = do
- let List unRegs = (^. LSP.id) <$> req ^. params . unregistrations
+updateState (FromServerMess SClientUnregisterCapability req) = do
+ let List unRegs = (^. LSP.id) <$> req ^. params . unregisterations
modify $ \s ->
let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs
in s { curDynCaps = newCurDynCaps }
-updateState (NotPublishDiagnostics n) = do
+updateState (FromServerMess STextDocumentPublishDiagnostics n) = do
let List diags = n ^. params . diagnostics
doc = n ^. params . uri
modify $ \s ->
let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s)
in s { curDiagnostics = newDiags }
-updateState (ReqApplyWorkspaceEdit r) = do
+updateState (FromServerMess SWorkspaceApplyEdit r) = do
-- First, prefer the versioned documentChanges field
allChangeParams <- case r ^. params . edit . documentChanges of
mergedParams = map mergeParams groupedParams
-- TODO: Don't do this when replaying a session
- forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)
+ forM_ mergedParams (sendMessage . NotificationMessage "2.0" STextDocumentDidChange)
-- Update VFS to new document versions
let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams
let fp = fromJust $ uriToFilePath uri
contents <- liftIO $ T.readFile fp
let item = TextDocumentItem (filePathToUri fp) "" 0 contents
- msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
+ msg = NotificationMessage "2.0" STextDocumentDidOpen (DidOpenTextDocumentParams item)
liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
modifyM $ \s -> do
logMsg LogClient msg
liftIO $ B.hPut h (addHeader $ encode msg)
--- | Execute a block f that will throw a 'Language.Haskell.LSP.Test.Exception.Timeout' exception
+-- | Execute a block f that will throw a 'Language.LSP.Test.Exception.Timeout' exception
-- after duration seconds. This will override the global timeout
-- for waiting for messages to arrive defined in 'SessionConfig'.
withTimeout :: Int -> Session a -> Session a
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
import Control.Monad.IO.Class
import Control.Monad
import Control.Lens hiding (List)
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Test
-import Language.Haskell.LSP.Types
-import Language.Haskell.LSP.Types.Lens hiding
+import Language.LSP.Test
+import Language.LSP.Types
+import Language.LSP.Types.Lens hiding
(capabilities, message, rename, applyEdit)
-import qualified Language.Haskell.LSP.Types.Lens as LSP
-import Language.Haskell.LSP.Types.Capabilities as LSP
+import qualified Language.LSP.Types.Lens as LSP
+import Language.LSP.Types.Capabilities as LSP
import System.Directory
import System.FilePath
import System.Timeout
+import Data.Type.Equality
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
{-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-}
-- won't receive a request - will timeout
-- incoming logging requests shouldn't increase the
-- timeout
- withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
+ withTimeout 5 $ skipManyTill anyMessage (message SWorkspaceApplyEdit)
-- wait just a bit longer than 5 seconds so we have time
-- to open the document
in timeout 6000000 sesh `shouldThrow` anySessionException
withTimeout 10 $ liftIO $ threadDelay 7000000
getDocumentSymbols doc
-- should now timeout
- skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
+ skipManyTill anyMessage (message SWorkspaceApplyEdit)
isTimeout (Timeout _) = True
isTimeout _ = False
in sesh `shouldThrow` isTimeout
it "throw on time out" $
let sesh = runSessionWithConfig (def {messageTimeout = 10}) serverExe fullCaps "test/data/renamePass" $ do
skipMany loggingNotification
- _ <- message :: Session ApplyWorkspaceEditRequest
+ _ <- message SWorkspaceApplyEdit
return ()
in sesh `shouldThrow` anySessionException
describe "UnexpectedMessageException" $ do
it "throws when there's an unexpected message" $
- let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True
+ let selector (UnexpectedMessage "Publish diagnostics notification" (FromServerMess SWindowLogMessage _)) = True
selector _ = False
in runSession serverExe fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
it "provides the correct types that were expected and received" $
- let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True
+ let selector (UnexpectedMessage "STextDocumentRename" (FromServerRsp STextDocumentDocumentSymbol _)) = True
selector _ = False
sesh = do
doc <- openDoc "Desktop/simple.hs" "haskell"
- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing)
+ sendRequest STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc)
skipMany anyNotification
- message :: Session RenameResponse -- the wrong type
+ response STextDocumentRename -- the wrong type
in runSession serverExe fullCaps "test/data/renamePass" sesh
`shouldThrow` selector
- -- This is too fickle at the moment
- -- describe "replaySession" $
- -- it "passes a test" $
- -- replaySession serverExe "test/data/renamePass"
- -- it "fails a test" $
- -- let selector (ReplayOutOfOrder _ _) = True
- -- selector _ = False
- -- in replaySession serverExe "test/data/renameFail" `shouldThrow` selector
-
- -- describe "manual javascript session" $
- -- it "passes a test" $
- -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do
- -- doc <- openDoc "test.js" "javascript"
-
- -- noDiagnostics
-
- -- Right (fooSymbol:_) <- getDocumentSymbols doc
-
- -- liftIO $ do
- -- fooSymbol ^. name `shouldBe` "foo"
- -- fooSymbol ^. kind `shouldBe` SkFunction
-
describe "text document VFS" $
it "sends back didChange notifications" $
runSession serverExe def "test/data/refactor" $ do
doc <- openDoc "Main.hs" "haskell"
let args = toJSON (doc ^. uri)
- reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing
- request_ WorkspaceExecuteCommand reqParams
+ reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args]))
+ request_ SWorkspaceExecuteCommand reqParams
- editReq <- message :: Session ApplyWorkspaceEditRequest
+ editReq <- message SWorkspaceApplyEdit
liftIO $ do
let (Just cs) = editReq ^. params . edit . changes
[(u, List es)] = HM.toList cs
doc <- openDoc "Main.hs" "haskell"
let args = toJSON (doc ^. uri)
- reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing
- request_ WorkspaceExecuteCommand reqParams
+ reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args]))
+ request_ SWorkspaceExecuteCommand reqParams
contents <- getDocumentEdit doc
liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n"
it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
doc <- openDoc "Main.hs" "haskell"
waitForDiagnostics
- [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
+ [InR action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
liftIO $ action ^. title `shouldBe` "Delete this"
describe "getAllCodeActions" $
_ <- waitForDiagnostics
actions <- getAllCodeActions doc
liftIO $ do
- let [CACodeAction action] = actions
+ let [InR action] = actions
action ^. title `shouldBe` "Delete this"
action ^. command . _Just . command `shouldBe` "deleteThis"
describe "satisfy" $
it "works" $ runSession serverExe fullCaps "test/data" $ do
openDoc "Format.hs" "haskell"
- let pred (NotLogMessage _) = True
+ let pred (FromServerMess SWindowLogMessage _) = True
pred _ = False
void $ satisfy pred
void publishDiagnosticsNotification
describe "dynamic capabilities" $ do
+
it "keeps track" $ runSession serverExe fullCaps "test/data" $ do
loggingNotification -- initialized log message
createDoc ".register" "haskell" ""
- message :: Session RegisterCapabilityRequest
+ message SClientRegisterCapability
doc <- createDoc "Foo.watch" "haskell" ""
- NotLogMessage msg <- loggingNotification
+ msg <- message SWindowLogMessage
liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
- caps <- getRegisteredCapabilities
- liftIO $ caps `shouldBe`
- [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $
- DidChangeWatchedFilesRegistrationOptions $ List
- [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ]
- ]
+ [SomeRegistration (Registration _ regMethod regOpts)] <- getRegisteredCapabilities
+ liftIO $ do
+ case regMethod `mEqClient` SWorkspaceDidChangeWatchedFiles of
+ Just HRefl ->
+ regOpts `shouldBe` (DidChangeWatchedFilesRegistrationOptions $ List
+ [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ])
+ Nothing -> expectationFailure "Registration wasn't on workspace/didChangeWatchedFiles"
-- now unregister it by sending a specific createDoc
createDoc ".unregister" "haskell" ""
- message :: Session UnregisterCapabilityRequest
+ message SClientUnregisterCapability
createDoc "Bar.watch" "haskell" ""
- void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing
+ void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing
count 0 $ loggingNotification
void $ anyResponse
loggingNotification -- initialized log message
createDoc ".register.abs" "haskell" ""
- message :: Session RegisterCapabilityRequest
+ message SClientRegisterCapability
doc <- createDoc (curDir </> "Foo.watch") "haskell" ""
- NotLogMessage msg <- loggingNotification
+ msg <- message SWindowLogMessage
liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"
-- now unregister it by sending a specific createDoc
createDoc ".unregister.abs" "haskell" ""
- message :: Session UnregisterCapabilityRequest
+ message SClientUnregisterCapability
createDoc (curDir </> "Bar.watch") "haskell" ""
- void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing
+ void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing
count 0 $ loggingNotification
void $ anyResponse
-mkRange :: Int -> Int -> Int -> Int -> Range
-mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
-
didChangeCaps :: ClientCapabilities
didChangeCaps = def { _workspace = Just workspaceCaps }
where
docChangesCaps = def { _workspace = Just workspaceCaps }
where
workspaceCaps = def { _workspaceEdit = Just editCaps }
- editCaps = WorkspaceEditClientCapabilities (Just True)
+ editCaps = WorkspaceEditClientCapabilities (Just True) Nothing Nothing
findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath)
+{-# LANGUAGE TypeInType #-}
{-# LANGUAGE OverloadedStrings #-}
-import Data.Aeson
-import Data.Default
-import Data.List (isSuffixOf)
-import qualified Data.HashMap.Strict as HM
-import Language.Haskell.LSP.Core
-import Language.Haskell.LSP.Control
-import Language.Haskell.LSP.Messages
-import Language.Haskell.LSP.Types
-import Control.Concurrent
+
import Control.Monad
+import Control.Monad.Reader
+import Data.Aeson hiding (defaultOptions)
+import qualified Data.HashMap.Strict as HM
+import Data.List (isSuffixOf)
+import Language.LSP.Server
+import Language.LSP.Types
import System.Directory
import System.FilePath
+import UnliftIO
+import UnliftIO.Concurrent
main = do
- lfvar <- newEmptyMVar
- let initCbs = InitializeCallbacks
- { onInitialConfiguration = const $ Right ()
- , onConfigurationChange = const $ Right ()
- , onStartup = \lf -> do
- putMVar lfvar lf
-
- return Nothing
+ handlerEnv <- HandlerEnv <$> newEmptyMVar <*> newEmptyMVar
+ runServer $ ServerDefinition
+ { doInitialize = \env _req -> pure $ Right env,
+ onConfigurationChange = const $ pure $ Right (),
+ staticHandlers = handlers,
+ interpretHandler = \env ->
+ Iso
+ (\m -> runLspT env (runReaderT m handlerEnv))
+ liftIO,
+ options = defaultOptions {executeCommandCommands = Just ["doAnEdit"]}
}
- options = def
- { executeCommandCommands = Just ["doAnEdit"]
+
+data HandlerEnv = HandlerEnv
+ { relRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles),
+ absRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles)
}
- run initCbs (handlers lfvar) options Nothing
-handlers :: MVar (LspFuncs ()) -> Handlers
-handlers lfvar = def
- { initializedHandler = pure $ \_ -> send $ NotLogMessage $ fmServerLogMessageNotification MtLog "initialized"
- , hoverHandler = pure $ \req -> send $
- RspHover $ makeResponseMessage req (Just (Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing))
- , documentSymbolHandler = pure $ \req -> send $
- RspDocumentSymbols $ makeResponseMessage req $ DSDocumentSymbols $
- List [ DocumentSymbol "foo"
+handlers :: Handlers (ReaderT HandlerEnv (LspM ()))
+handlers =
+ mconcat
+ [ notificationHandler SInitialized $
+ \_noti ->
+ sendNotification SWindowLogMessage $
+ LogMessageParams MtLog "initialized",
+ requestHandler STextDocumentHover $
+ \_req responder ->
+ responder $
+ Right $
+ Just $
+ Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing,
+ requestHandler STextDocumentDocumentSymbol $
+ \_req responder ->
+ responder $
+ Right $
+ InL $
+ List
+ [ DocumentSymbol
+ "foo"
Nothing
SkObject
Nothing
(mkRange 0 0 3 6)
(mkRange 0 0 3 6)
Nothing
- ]
- , didOpenTextDocumentNotificationHandler = pure $ \noti -> do
+ ],
+ notificationHandler STextDocumentDidOpen $
+ \noti -> do
let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti
TextDocumentItem uri _ _ _ = doc
Just fp = uriToFilePath uri
- diag = Diagnostic (mkRange 0 0 0 1)
+ diag =
+ Diagnostic
+ (mkRange 0 0 0 1)
(Just DsWarning)
- (Just (NumberValue 42))
+ (Just (InL 42))
(Just "dummy-server")
"Here's a warning"
Nothing
Nothing
- when (".hs" `isSuffixOf` fp) $ void $ forkIO $ do
+ withRunInIO $
+ \runInIO -> do
+ when (".hs" `isSuffixOf` fp) $
+ void $
+ forkIO $
+ do
threadDelay (2 * 10 ^ 6)
- send $ NotPublishDiagnostics $
- fmServerPublishDiagnosticsNotification $ PublishDiagnosticsParams uri $ List [diag]
-
+ runInIO $
+ sendNotification STextDocumentPublishDiagnostics $
+ PublishDiagnosticsParams uri Nothing (List [diag])
-- also act as a registerer for workspace/didChangeWatchedFiles
- when (".register" `isSuffixOf` fp) $ do
- reqId <- readMVar lfvar >>= getNextReqId
- send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $
- RegistrationParams $ List $
- [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $
- DidChangeWatchedFilesRegistrationOptions $ List
- [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ]
+ when (".register" `isSuffixOf` fp) $
+ do
+ let regOpts =
+ DidChangeWatchedFilesRegistrationOptions $
+ List
+ [ FileSystemWatcher
+ "*.watch"
+ (Just (WatchKind True True True))
]
- when (".register.abs" `isSuffixOf` fp) $ do
+ Just token <- runInIO $
+ registerCapability SWorkspaceDidChangeWatchedFiles regOpts $
+ \_noti ->
+ sendNotification SWindowLogMessage $
+ LogMessageParams MtLog "got workspace/didChangeWatchedFiles"
+ runInIO $ asks relRegToken >>= \v -> putMVar v token
+ when (".register.abs" `isSuffixOf` fp) $
+ do
curDir <- getCurrentDirectory
- reqId <- readMVar lfvar >>= getNextReqId
- send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $
- RegistrationParams $ List $
- [ Registration "1" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $
- DidChangeWatchedFilesRegistrationOptions $ List
- [ FileSystemWatcher (curDir </> "*.watch") (Just (WatchKind True True True)) ]
+ let regOpts =
+ DidChangeWatchedFilesRegistrationOptions $
+ List
+ [ FileSystemWatcher
+ (curDir </> "*.watch")
+ (Just (WatchKind True True True))
]
-
+ Just token <- runInIO $
+ registerCapability SWorkspaceDidChangeWatchedFiles regOpts $
+ \_noti ->
+ sendNotification SWindowLogMessage $
+ LogMessageParams MtLog "got workspace/didChangeWatchedFiles"
+ runInIO $ asks absRegToken >>= \v -> putMVar v token
-- also act as an unregisterer for workspace/didChangeWatchedFiles
- when (".unregister" `isSuffixOf` fp) $ do
- reqId <- readMVar lfvar >>= getNextReqId
- send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $
- UnregistrationParams $ List [ Unregistration "0" "workspace/didChangeWatchedFiles" ]
- when (".unregister.abs" `isSuffixOf` fp) $ do
- reqId <- readMVar lfvar >>= getNextReqId
- send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $
- UnregistrationParams $ List [ Unregistration "1" "workspace/didChangeWatchedFiles" ]
- , executeCommandHandler = pure $ \req -> do
- send $ RspExecuteCommand $ makeResponseMessage req Null
- reqId <- readMVar lfvar >>= getNextReqId
- let RequestMessage _ _ _ (ExecuteCommandParams "doAnEdit" (Just (List [val])) _) = req
+ when (".unregister" `isSuffixOf` fp) $
+ do
+ Just token <- runInIO $ asks relRegToken >>= tryReadMVar
+ runInIO $ unregisterCapability token
+ when (".unregister.abs" `isSuffixOf` fp) $
+ do
+ Just token <- runInIO $ asks absRegToken >>= tryReadMVar
+ runInIO $ unregisterCapability token,
+ requestHandler SWorkspaceExecuteCommand $ \req resp -> do
+ let RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just (List [val]))) = req
Success docUri = fromJSON val
edit = List [TextEdit (mkRange 0 0 0 5) "howdy"]
- send $ ReqApplyWorkspaceEdit $ fmServerApplyWorkspaceEditRequest reqId $
- ApplyWorkspaceEditParams $ WorkspaceEdit (Just (HM.singleton docUri edit))
- Nothing
- , codeActionHandler = pure $ \req -> do
+ params =
+ ApplyWorkspaceEditParams (Just "Howdy edit") $
+ WorkspaceEdit (Just (HM.singleton docUri edit)) Nothing
+ resp $ Right Null
+ void $ sendRequest SWorkspaceApplyEdit params (const (pure ())),
+ requestHandler STextDocumentCodeAction $ \req resp -> do
let RequestMessage _ _ _ params = req
- CodeActionParams _ _ cactx _ = params
+ CodeActionParams _ _ _ _ cactx = params
CodeActionContext diags _ = cactx
- caresults = fmap diag2caresult diags
- diag2caresult d = CACodeAction $
- CodeAction "Delete this"
+ codeActions = fmap diag2ca diags
+ diag2ca d =
+ CodeAction
+ "Delete this"
Nothing
(Just (List [d]))
Nothing
+ Nothing
(Just (Command "" "deleteThis" Nothing))
- send $ RspCodeAction $ makeResponseMessage req caresults
- , didChangeWatchedFilesNotificationHandler = pure $ \_ ->
- send $ NotLogMessage $ fmServerLogMessageNotification MtLog "got workspace/didChangeWatchedFiles"
- , completionHandler = pure $ \req -> do
- let res = CompletionList (CompletionListType False (List [item]))
+ resp $ Right $ InR <$> codeActions,
+ requestHandler STextDocumentCompletion $ \_req resp -> do
+ let res = CompletionList True (List [item])
item =
- CompletionItem "foo" (Just CiConstant) (Just (List [])) Nothing
- Nothing Nothing Nothing Nothing Nothing Nothing Nothing
- Nothing Nothing Nothing Nothing Nothing
- send $ RspCompletion $ makeResponseMessage req res
- }
- where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg
-
-mkRange sl sc el ec = Range (Position sl sc) (Position el ec)
+ CompletionItem
+ "foo"
+ (Just CiConstant)
+ (Just (List []))
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ Nothing
+ resp $ Right $ InR res
+ ]
projects / lsp-test.git / commitdiff