From: Luke Lau Date: Fri, 18 Oct 2019 23:49:15 +0000 (+0100) Subject: Merge branch 'master' into github-actions X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=commitdiff_plain;h=ba2031ed9c5237c40dc6de1376bf74ec134f78bf;hp=38bf0b76556e21891319a2e2af92efe8ff4bf5b7 Merge branch 'master' into github-actions --- diff --git a/ChangeLog.md b/ChangeLog.md index 8bbc01f..f01ba4f 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # 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 diff --git a/lsp-test.cabal b/lsp-test.cabal index 14e0046..80283b7 100644 --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -1,5 +1,5 @@ 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 @@ -36,7 +36,7 @@ library , 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 @@ -52,7 +52,7 @@ library , lens , mtl , parser-combinators - , process + , process >= 1.6 , rope-utf16-splay , text , transformers @@ -79,7 +79,7 @@ test-suite tests build-depends: base >= 4.10 && < 5 , hspec , lens - , haskell-lsp == 0.16.* + , haskell-lsp == 0.17.* , lsp-test , data-default , aeson diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 1b2e7ba..22091c3 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -8,7 +8,7 @@ Module : Language.Haskell.LSP.Test 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 . @@ -163,8 +163,7 @@ runSessionWithConfig config serverExe caps rootDir session = do Nothing -> return () -- Run the actual test - result <- session - return result + session where -- | Asks the server to shutdown and exit politely exitServer :: Session () @@ -378,7 +377,7 @@ noDiagnostics = do -- | 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) @@ -389,7 +388,7 @@ getDocumentSymbols doc = do 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 @@ -407,7 +406,7 @@ getAllCodeActions doc = do 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) @@ -429,7 +428,7 @@ getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. 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. @@ -488,7 +487,7 @@ applyEdit doc edit = do -- | 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 @@ -501,7 +500,7 @@ getReferences :: TextDocumentIdentifier -- ^ The document to lookup in. -> 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. @@ -509,7 +508,7 @@ 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 + let params = TextDocumentPositionParams doc pos Nothing rsp <- request TextDocumentDefinition params :: Session DefinitionResponse case getResponseResult rsp of SingleLoc loc -> pure [loc] @@ -520,13 +519,13 @@ 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 = - 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) @@ -535,13 +534,13 @@ rename doc pos newName = do -- | 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. @@ -554,14 +553,14 @@ getResponseResult rsp = fromMaybe exc (rsp ^. result) -- | 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 @@ -574,6 +573,6 @@ 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 diff --git a/src/Language/Haskell/LSP/Test/Decoding.hs b/src/Language/Haskell/LSP/Test/Decoding.hs index af91928..e635267 100644 --- a/src/Language/Haskell/LSP/Test/Decoding.hs +++ b/src/Language/Haskell/LSP/Test/Decoding.hs @@ -3,6 +3,7 @@ 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 @@ -131,9 +132,9 @@ decodeFromServerMsg reqMap bytes = 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 diff --git a/src/Language/Haskell/LSP/Test/Messages.hs b/src/Language/Haskell/LSP/Test/Messages.hs index f41a77b..f8b1822 100644 --- a/src/Language/Haskell/LSP/Test/Messages.hs +++ b/src/Language/Haskell/LSP/Test/Messages.hs @@ -60,6 +60,7 @@ handleServerMessage request response notification msg = case msg of (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 @@ -92,9 +93,9 @@ handleServerMessage request response notification msg = case msg of (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 @@ -148,6 +149,6 @@ handleClientMessage request response notification msg = case msg of (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 diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index 52f97ae..70481b9 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -23,7 +23,8 @@ import Control.Monad.IO.Class 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 @@ -81,7 +82,7 @@ satisfyMaybe pred = do threadDelay (timeout * 1000000) writeChan chan (TimeoutMessage timeoutId) - x <- await + x <- Session await unless skipTimeout $ modify $ \s -> s { curTimeoutId = timeoutId + 1 } @@ -94,6 +95,9 @@ satisfyMaybe pred = do 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 = diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index b8286a2..b8dbe2a 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -1,12 +1,13 @@ {-# 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(..) @@ -28,6 +29,7 @@ module Language.Haskell.LSP.Test.Session where +import Control.Applicative import Control.Concurrent hiding (yield) import Control.Exception import Control.Lens hiding (List) @@ -40,7 +42,7 @@ import Control.Monad.Fail 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 @@ -76,7 +78,8 @@ import System.Timeout -- '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 @@ -121,10 +124,10 @@ class Monad m => HasReader r m 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 @@ -150,19 +153,22 @@ class Monad m => HasState s m where 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) @@ -235,7 +241,8 @@ updateStateC = awaitForever $ \msg -> do 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 diff --git a/stack.yaml b/stack.yaml index 07b7ffc..1e8b3c2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,5 +4,8 @@ packages: 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 diff --git a/stack.yaml.lock b/stack.yaml.lock index e894dd7..d72396d 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -12,19 +12,37 @@ packages: 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 diff --git a/test/Test.hs b/test/Test.hs index 75e1628..d689bff 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -118,7 +118,7 @@ main = hspec $ do 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 @@ -154,7 +154,7 @@ main = hspec $ do 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 @@ -177,7 +177,7 @@ main = hspec $ do 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"