# Revision history for lsp-test
+## 0.8.0.0 -- 2019-10-18
+
+* Make `Session` a newtype
+* Update for haskell-lsp-0.17.0.0 (@cocreature)
+
## 0.7.0.0 -- 2019-09-08
* Update for haskell-lsp-0.16.0.0
name: lsp-test
-version: 0.7.0.0
+version: 0.8.0.0
synopsis: Functional test framework for LSP servers.
description:
A test framework for writing tests against
, parser-combinators:Control.Applicative.Combinators
default-language: Haskell2010
build-depends: base >= 4.10 && < 5
- , haskell-lsp == 0.16.*
+ , haskell-lsp == 0.17.*
, aeson
, aeson-pretty
, ansi-terminal
, lens
, mtl
, parser-combinators
- , process
+ , process >= 1.6
, rope-utf16-splay
, text
, transformers
build-depends: base >= 4.10 && < 5
, hspec
, lens
- , haskell-lsp == 0.16.*
+ , haskell-lsp == 0.17.*
, lsp-test
, data-default
, aeson
Description : A functional testing framework for LSP servers.
Maintainer : luke_lau@icloud.com
Stability : experimental
-Portability : POSIX
+Portability : non-portable
Provides the framework to start functionally testing
<https://github.com/Microsoft/language-server-protocol Language Server Protocol servers>.
Nothing -> return ()
-- Run the actual test
- result <- session
- return result
+ session
where
-- | Asks the server to shutdown and exit politely
exitServer :: Session ()
-- | Returns the symbols in a document.
getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])
getDocumentSymbols doc = do
- ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc) :: Session DocumentSymbolsResponse
+ ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse
maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr
case mRes of
Just (DSDocumentSymbols (List xs)) -> return (Left xs)
getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]
getCodeActions doc range = do
ctx <- getCodeActionContext doc
- rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx)
+ rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx Nothing)
case rsp ^. result of
Just (List xs) -> return xs
where
go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]
go ctx acc diag = do
- ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)
+ ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing)
case mErr of
Just e -> throw (UnexpectedResponseError rspLid e)
executeCommand :: Command -> Session ()
executeCommand cmd = do
let args = decode $ encode $ fromJust $ cmd ^. arguments
- execParams = ExecuteCommandParams (cmd ^. command) args
+ execParams = ExecuteCommandParams (cmd ^. command) args Nothing
request_ WorkspaceExecuteCommand execParams
-- | Executes a code action.
-- | Returns the completions for the position in the document.
getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]
getCompletions doc pos = do
- rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos)
+ rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos Nothing)
case getResponseResult rsp of
Completions (List items) -> return items
-> Session [Location] -- ^ The locations of the references.
getReferences doc pos inclDecl =
let ctx = ReferenceContext inclDecl
- params = ReferenceParams doc pos ctx
+ params = ReferenceParams doc pos ctx Nothing
in getResponseResult <$> request TextDocumentReferences params
-- | Returns the definition(s) for the term at the specified position.
-> Position -- ^ The position the term is at.
-> Session [Location] -- ^ The location(s) of the definitions
getDefinitions doc pos = do
- let params = TextDocumentPositionParams doc pos
+ let params = TextDocumentPositionParams doc pos Nothing
rsp <- request TextDocumentDefinition params :: Session DefinitionResponse
case getResponseResult rsp of
SingleLoc loc -> pure [loc]
-> Position -- ^ The position the term is at.
-> Session [Location] -- ^ The location(s) of the definitions
getTypeDefinitions doc pos =
- let params = TextDocumentPositionParams doc pos
+ let params = TextDocumentPositionParams doc pos Nothing
in getResponseResult <$> request TextDocumentTypeDefinition params
-- | 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)
+ let params = RenameParams doc pos (T.pack newName) Nothing
rsp <- request TextDocumentRename params :: Session RenameResponse
let wEdit = getResponseResult rsp
req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)
-- | Returns the hover information at the specified position.
getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)
getHover doc pos =
- let params = TextDocumentPositionParams doc pos
+ let params = TextDocumentPositionParams doc pos Nothing
in getResponseResult <$> request TextDocumentHover params
-- | Returns the highlighted occurences of the term at the specified position
getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]
getHighlights doc pos =
- let params = TextDocumentPositionParams doc pos
+ let params = TextDocumentPositionParams doc pos Nothing
in getResponseResult <$> request TextDocumentDocumentHighlight params
-- | Checks the response for errors and throws an exception if needed.
-- | Applies formatting to the specified document.
formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()
formatDoc doc opts = do
- let params = DocumentFormattingParams doc opts
+ let params = DocumentFormattingParams doc opts Nothing
edits <- getResponseResult <$> request TextDocumentFormatting params
applyTextEdits doc edits
-- | Applies formatting to the specified range in a document.
formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()
formatRange doc opts range = do
- let params = DocumentRangeFormattingParams doc range opts
+ let params = DocumentRangeFormattingParams doc range opts Nothing
edits <- getResponseResult <$> request TextDocumentRangeFormatting params
applyTextEdits doc edits
-- | Returns the code lenses for the specified document.
getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens]
getCodeLenses tId = do
- rsp <- request TextDocumentCodeLens (CodeLensParams tId) :: Session CodeLensResponse
+ rsp <- request TextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse
case getResponseResult rsp of
List res -> pure res
import Prelude hiding ( id )
import Data.Aeson
+import Data.Foldable
import Control.Exception
import Control.Lens
import qualified Data.ByteString.Lazy.Char8 as B
WindowShowMessage -> NotShowMessage $ fromJust $ decode bytes
WindowLogMessage -> NotLogMessage $ fromJust $ decode bytes
CancelRequestServer -> NotCancelRequestFromServer $ fromJust $ decode bytes
- WindowProgressStart -> NotProgressStart $ fromJust $ decode bytes
- WindowProgressReport -> NotProgressReport $ fromJust $ decode bytes
- WindowProgressDone -> NotProgressDone $ 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
(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
(NotPublishDiagnostics m) -> notification m
(NotLogMessage m) -> notification m
(NotShowMessage m) -> notification m
- (NotProgressStart m) -> notification m
- (NotProgressReport m) -> notification m
- (NotProgressDone 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
(NotDidSaveTextDocument m) -> notification m
(NotDidChangeWatchedFiles m) -> notification m
(NotDidChangeWorkspaceFolders m) -> notification m
- (NotProgressCancel m) -> notification m
+ (NotWorkDoneProgressCancel m) -> notification m
(ReqCustomClient m) -> request m
(NotCustomClient m) -> notification m
import Control.Monad
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as B
-import Data.Conduit.Parser
+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
threadDelay (timeout * 1000000)
writeChan chan (TimeoutMessage timeoutId)
- x <- await
+ x <- Session await
unless skipTimeout $
modify $ \s -> s { curTimeoutId = timeoutId + 1 }
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 =
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Language.Haskell.LSP.Test.Session
- ( Session
+ ( Session(..)
, SessionConfig(..)
, defaultConfig
, SessionMessage(..)
where
+import Control.Applicative
import Control.Concurrent hiding (yield)
import Control.Exception
import Control.Lens hiding (List)
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import qualified Control.Monad.Trans.Reader as Reader (ask)
import Control.Monad.Trans.State (StateT, runStateT)
-import qualified Control.Monad.Trans.State as State (get, put)
+import qualified Control.Monad.Trans.State as State
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Aeson
import Data.Aeson.Encode.Pretty
-- 'Language.Haskell.LSP.Test.sendRequest' and
-- 'Language.Haskell.LSP.Test.sendNotification'.
-type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
+newtype Session a = Session (ConduitParser FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) a)
+ deriving (Functor, Applicative, Monad, MonadIO, Alternative)
#if __GLASGOW_HASKELL__ >= 806
instance MonadFail Session where
asks :: (r -> b) -> m b
asks f = f <$> ask
-instance Monad m => HasReader r (ParserStateReader a s r m) where
- ask = lift $ lift Reader.ask
+instance HasReader SessionContext Session where
+ ask = Session (lift $ lift Reader.ask)
-instance Monad m => HasReader SessionContext (ConduitM a b (StateT s (ReaderT SessionContext m))) where
+instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where
ask = lift $ lift Reader.ask
data SessionState = SessionState
modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()
modifyM f = get >>= f >>= put
-instance Monad m => HasState s (ParserStateReader a s r m) where
+instance HasState SessionState Session where
+ get = Session (lift State.get)
+ put = Session . lift . State.put
+
+instance Monad m => HasState s (ConduitM a b (StateT s m))
+ where
get = lift State.get
put = lift . State.put
-instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m))
+instance Monad m => HasState s (ConduitParser a (StateT s m))
where
get = lift State.get
put = lift . State.put
-type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
-
runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
-runSession context state session = runReaderT (runStateT conduit state) context
+runSession context state (Session session) = runReaderT (runStateT conduit state) context
where
conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)
updateState msg
yield msg
-updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m ()
+updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)
+ => FromServerMessage -> m ()
updateState (NotPublishDiagnostics n) = do
let List diags = n ^. params . diagnostics
doc = n ^. params . uri
extra-deps:
- rope-utf16-splay-0.3.1.0
- - haskell-lsp-0.16.0.0
- - haskell-lsp-types-0.16.0.0
+ - github: alanz/haskell-lsp
+ commit: 2aacc5ca706bcce111e976a1af4a95a376137c5e
+ subdirs:
+ - .
+ - haskell-lsp-types
original:
hackage: rope-utf16-splay-0.3.1.0
- completed:
- hackage: haskell-lsp-0.16.0.0@sha256:6ac4b58e6caef43546a3c115f1aaaae0e23d30f0e37b8c4e94525468e9982d09,5264
+ size: 86224
+ subdir: .
+ url: https://github.com/alanz/haskell-lsp/archive/2aacc5ca706bcce111e976a1af4a95a376137c5e.tar.gz
+ cabal-file:
+ size: 5264
+ sha256: ddfcc2798f04bcb1ec20fafc02c03faa197322192578e879cef5852aba43ebcb
+ name: haskell-lsp
+ version: 0.17.0.0
+ sha256: fbbc3ebdbb2c0f6eacdb9f3c8a3550e71617aff9df279da175c8b99c422ddeb9
pantry-tree:
- size: 1725
- sha256: 31b245f4da5b5b844be9802bb2bfd397c90c0a50b063e5bae26648c6220aaf7f
+ size: 5675
+ sha256: 80539460483f0459786fce73d842b203eef003fd1c657281daec8aea2957db3f
original:
- hackage: haskell-lsp-0.16.0.0
+ subdir: .
+ url: https://github.com/alanz/haskell-lsp/archive/2aacc5ca706bcce111e976a1af4a95a376137c5e.tar.gz
- completed:
- hackage: haskell-lsp-types-0.16.0.0@sha256:57729b32b1ca65d4869e1e518fa4df749d4488ec5f11e23b50c2b89417f5f211,2882
+ size: 86224
+ subdir: haskell-lsp-types
+ url: https://github.com/alanz/haskell-lsp/archive/2aacc5ca706bcce111e976a1af4a95a376137c5e.tar.gz
+ cabal-file:
+ size: 2941
+ sha256: 9078237412d0596a7d09d432389c8fa21d6f3e21ed2ed761b3093a21607d6c28
+ name: haskell-lsp-types
+ version: 0.17.0.0
+ sha256: fbbc3ebdbb2c0f6eacdb9f3c8a3550e71617aff9df279da175c8b99c422ddeb9
pantry-tree:
- size: 2369
- sha256: cc24c23f741e777b9c01ccd700af034e2258e560f5fdb271d08befd4b03196b7
+ size: 2501
+ sha256: a575ce26976bd31d34a9db27e20e8e34d9b50b8d2e34a2e3772b3236b8cf778c
original:
- hackage: haskell-lsp-types-0.16.0.0
+ subdir: haskell-lsp-types
+ url: https://github.com/alanz/haskell-lsp/archive/2aacc5ca706bcce111e976a1af4a95a376137c5e.tar.gz
snapshots:
- completed:
size: 499889
selector _ = False
sesh = do
doc <- openDoc "Desktop/simple.hs" "haskell"
- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
+ sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing)
skipMany anyNotification
message :: Session RenameResponse -- the wrong type
in runSession "hie" fullCaps "test/data/renamePass" sesh
let args = toJSON $ AOP (doc ^. uri)
(Position 1 14)
"Redundant bracket"
- reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
+ reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) Nothing
request_ WorkspaceExecuteCommand reqParams
editReq <- message :: Session ApplyWorkspaceEditRequest
let args = toJSON $ AOP (doc ^. uri)
(Position 1 14)
"Redundant bracket"
- reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
+ reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) Nothing
request_ WorkspaceExecuteCommand reqParams
contents <- getDocumentEdit doc
liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"