From d8e460543b7cbc32550bed20d20ef4b13d6705a5 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 2 Jul 2018 12:40:44 +0100 Subject: [PATCH] Add nicer API sendRequest now gets the result too Add better helpers for document symbols and code actions --- example/Main.hs | 3 +- haskell-lsp-test.cabal | 1 + src/Language/Haskell/LSP/Test.hs | 73 ++++++++++++++------- src/Language/Haskell/LSP/Test/Exceptions.hs | 4 ++ src/Language/Haskell/LSP/Test/Parsing.hs | 12 +++- src/Language/Haskell/LSP/Test/Replay.hs | 2 +- src/Language/Haskell/LSP/Test/Session.hs | 10 ++- stack.yaml | 2 +- test/Test.hs | 61 ++++++++--------- 9 files changed, 111 insertions(+), 57 deletions(-) diff --git a/example/Main.hs b/example/Main.hs index 4891c6c..cc74026 100644 --- a/example/Main.hs +++ b/example/Main.hs @@ -6,7 +6,8 @@ import Control.Monad.IO.Class main = runSession "hie --lsp" "test/recordings/renamePass" $ do docItem <- openDoc "Desktop/simple.hs" "haskell" - sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams docItem) + let params = DocumentSymbolParams docItem + _ <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse skipMany loggingNotification diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index 4683c60..bc0f581 100644 --- a/haskell-lsp-test.cabal +++ b/haskell-lsp-test.cabal @@ -70,6 +70,7 @@ test-suite tests , conduit-parse , aeson , unordered-containers + , text other-modules: ParsingTests default-language: Haskell2010 diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 0e8f5bf..2a6db1f 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -24,8 +24,10 @@ module Language.Haskell.LSP.Test , anySessionException -- * Sending , sendRequest - , sendNotification + , sendRequest_ , sendRequest' + , sendNotification + , sendRequestMessage , sendNotification' , sendResponse -- * Receving @@ -35,6 +37,7 @@ module Language.Haskell.LSP.Test , response , anyNotification , notification + , anyMessage , loggingNotification , publishDiagnosticsNotification -- * Combinators @@ -66,7 +69,8 @@ module Language.Haskell.LSP.Test , getDocUri , noDiagnostics , getDocumentSymbols - , getDiagnostics + , waitForDiagnostics + , getAllCodeActions ) where import Control.Applicative @@ -126,8 +130,7 @@ runSessionWithConfig config serverExe rootDir session = do runSessionWithHandles serverIn serverOut listenServer config rootDir $ do -- Wrap the session around initialize and shutdown calls - sendRequest Initialize initializeParams - initRspMsg <- response :: Session InitializeResponse + initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error) @@ -187,20 +190,26 @@ getDocumentEdit doc = do let mMap = req ^. params . edit . changes in maybe False (HashMap.member (doc ^. uri)) mMap --- | Sends a request to the server. --- +-- | Sends a request to the server and waits for its response. -- @ --- sendRequest (Proxy :: Proxy DocumentSymbolRequest) --- TextDocumentDocumentSymbol --- (DocumentSymbolParams docId) +-- rsp <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse -- @ -sendRequest - :: (ToJSON params) - => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request. - ClientMethod -- ^ The request method. +-- Note: will skip any messages in between the request and the response. +sendRequest :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a) +sendRequest m = sendRequest' m >=> skipManyTill anyMessage . responseForId + +-- | Send a request to the server and wait for its response, +-- but discard it. +sendRequest_ :: ToJSON params => ClientMethod -> params -> Session () +sendRequest_ p = void . (sendRequest p :: ToJSON params => params -> Session (ResponseMessage Value)) + +-- | Sends a request to the server without waiting on the response. +sendRequest' + :: ToJSON params + => ClientMethod -- ^ The request method. -> params -- ^ The request parameters. -> Session LspId -- ^ The id of the request that was sent. -sendRequest method params = do +sendRequest' method params = do id <- curReqId <$> get modify $ \c -> c { curReqId = nextId id } @@ -228,8 +237,8 @@ instance ToJSON a => ToJSON (RequestMessage' a) where object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params] -sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session () -sendRequest' req = do +sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session () +sendRequestMessage req = do -- Update the request map reqMap <- requestMap <$> ask liftIO $ modifyMVar_ reqMap $ @@ -315,9 +324,9 @@ getDocUri file = do let fp = rootDir context file return $ filePathToUri fp -getDiagnostics :: Session [Diagnostic] -getDiagnostics = do - diagsNot <- notification :: Session PublishDiagnosticsNotification +waitForDiagnostics :: Session [Diagnostic] +waitForDiagnostics = do + diagsNot <- skipManyTill anyMessage notification :: Session PublishDiagnosticsNotification let (List diags) = diagsNot ^. params . LSP.diagnostics return diags @@ -330,7 +339,27 @@ noDiagnostics = do when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException -- | Returns the symbols in a document. -getDocumentSymbols :: TextDocumentIdentifier -> Session DocumentSymbolsResponse +getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation] getDocumentSymbols doc = do - sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc) - response \ No newline at end of file + ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc) + maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr + let (Just (List symbols)) = mRes + return symbols + +getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction] +getAllCodeActions doc = do + curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get + let ctx = CodeActionContext (List curDiags) Nothing + + foldM (go ctx) [] curDiags + + where + go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction] + go ctx acc diag = do + ResponseMessage _ rspLid mRes mErr <- sendRequest TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx) + + case mErr of + Just e -> throw (UnexpectedResponseError rspLid e) + Nothing -> + let Just (List cmdOrCAs) = mRes + in return (acc ++ cmdOrCAs) \ No newline at end of file diff --git a/src/Language/Haskell/LSP/Test/Exceptions.hs b/src/Language/Haskell/LSP/Test/Exceptions.hs index c130702..3f122f2 100644 --- a/src/Language/Haskell/LSP/Test/Exceptions.hs +++ b/src/Language/Haskell/LSP/Test/Exceptions.hs @@ -2,6 +2,7 @@ module Language.Haskell.LSP.Test.Exceptions where import Control.Exception import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B @@ -10,6 +11,7 @@ data SessionException = TimeoutException | ReplayOutOfOrderException FromServerMessage [FromServerMessage] | UnexpectedDiagnosticsException | IncorrectApplyEditRequestException String + | UnexpectedResponseError LspIdRsp ResponseError instance Exception SessionException @@ -27,6 +29,8 @@ instance Show SessionException where show UnexpectedDiagnosticsException = "Unexpectedly received diagnostics from the server." show (IncorrectApplyEditRequestException msgStr) = "ApplyEditRequest didn't contain document, instead received:\n" ++ msgStr + show (UnexpectedResponseError lid e) = "Received an exepected error in a response for id " ++ show lid ++ ":\n" + ++ show e anySessionException :: SessionException -> Bool anySessionException = const True \ No newline at end of file diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index b28047c..614495b 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -6,6 +6,7 @@ module Language.Haskell.LSP.Test.Parsing where import Control.Applicative import Control.Concurrent +import Control.Lens import Control.Monad.IO.Class import Control.Monad.Trans.Class import Data.Aeson @@ -13,7 +14,7 @@ import qualified Data.ByteString.Lazy.Char8 as B import Data.Conduit.Parser import Data.Maybe import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types hiding (error) +import Language.Haskell.LSP.Types as LSP hiding (error) import Language.Haskell.LSP.Test.Exceptions import Language.Haskell.LSP.Test.Messages import Language.Haskell.LSP.Test.Session @@ -68,6 +69,15 @@ response = named "Response" $ do x <- satisfy (isJust . parser) return $ castMsg x +responseForId :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => LspId -> ConduitParser FromServerMessage m (ResponseMessage a) +responseForId lid = named "Response for id" $ do + let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a) + x <- satisfy (maybe False (\z -> z ^. LSP.id == responseId lid) . parser) + return $ castMsg x + +anyMessage :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage +anyMessage = satisfy (const True) + -- | A stupid method for getting out the inner message. castMsg :: FromJSON a => FromServerMessage -> a castMsg = fromMaybe (error "Failed casting a message") . decode . encodeMsg diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs index 68e6b1b..250fb2a 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -95,7 +95,7 @@ sendMessages (nextMsg:remainingMsgs) reqSema rspSema = sendMessages remainingMsgs reqSema rspSema request msg@(RequestMessage _ id m _) = do - sendRequest' msg + sendRequestMessage msg liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response" rsp <- liftIO $ takeMVar rspSema diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index 0553160..641077c 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -92,6 +92,7 @@ data SessionState = SessionState { curReqId :: LspId , vfs :: VFS + , curDiagnostics :: Map.Map Uri [Diagnostic] } type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) @@ -162,7 +163,7 @@ runSessionWithHandles serverIn serverOut serverHandler config rootDir session = initRsp <- newEmptyMVar let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config - initState = SessionState (IdInt 0) mempty + initState = SessionState (IdInt 0) mempty mempty threadId <- forkIO $ void $ runSession meaninglessChan processor context initState (serverHandler serverOut) (result, _) <- runSession messageChan processor context initState session @@ -178,6 +179,13 @@ runSessionWithHandles serverIn serverOut serverHandler config rootDir session = processTextChanges :: FromServerMessage -> SessionProcessor () +processTextChanges (NotPublishDiagnostics n) = do + let List diags = n ^. params . diagnostics + doc = n ^. params . uri + lift $ State.modify (\s -> + let newDiags = Map.insert doc diags (curDiagnostics s) + in s { curDiagnostics = newDiags }) + processTextChanges (ReqApplyWorkspaceEdit r) = do allChangeParams <- case r ^. params . edit . documentChanges of diff --git a/stack.yaml b/stack.yaml index 92c3ba0..adf9f08 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,7 +6,7 @@ extra-deps: - github: Bubba/haskell-lsp-client commit: b7cf14eb48837a73032e867dab90db1708220c66 - github: Bubba/haskell-lsp - commit: 4c705c23cac58b4f6535474acc61d054230b6699 + commit: 47176f14738451b36b061b2314a2acb05329fde4 subdirs: - . - ./haskell-lsp-types diff --git a/test/Test.hs b/test/Test.hs index 79bb303..b3a54ed 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -7,7 +7,7 @@ import Test.Hspec import Data.Aeson import Data.Default import qualified Data.HashMap.Strict as HM -import Data.Maybe +import qualified Data.Text as T import Control.Concurrent import Control.Monad.IO.Class import Control.Lens hiding (List) @@ -21,24 +21,6 @@ import ParsingTests main = hspec $ do describe "manual session" $ do - it "passes a test" $ - runSession "hie --lsp" "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" - - skipMany loggingNotification - - noDiagnostics - - rspSymbols <- getDocumentSymbols doc - - liftIO $ do - let (List symbols) = fromJust (rspSymbols ^. result) - mainSymbol = head symbols - mainSymbol ^. name `shouldBe` "main" - mainSymbol ^. kind `shouldBe` SkFunction - mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4) - mainSymbol ^. containerName `shouldBe` Nothing - it "fails a test" $ -- TODO: Catch the exception in haskell-lsp-test and provide nicer output let session = runSession "hie --lsp" "test/data/renamePass" $ do @@ -81,7 +63,7 @@ main = hspec $ do selector _ = False sesh = do doc <- openDoc "Desktop/simple.hs" "haskell" - sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc) + sendRequest' TextDocumentDocumentSymbol (DocumentSymbolParams doc) skipMany anyNotification response :: Session RenameResponse -- the wrong type in runSession "hie --lsp" "test/data/renamePass" sesh @@ -102,10 +84,8 @@ main = hspec $ do noDiagnostics - rspSymbols <- getDocumentSymbols doc + (fooSymbol:_) <- getDocumentSymbols doc - let (List symbols) = fromJust (rspSymbols ^. result) - fooSymbol = head symbols liftIO $ do fooSymbol ^. name `shouldBe` "foo" fooSymbol ^. kind `shouldBe` SkFunction @@ -119,9 +99,7 @@ main = hspec $ do (Position 1 14) "Redundant bracket" reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) - sendRequest WorkspaceExecuteCommand reqParams - skipMany anyNotification - _ <- response :: Session ExecuteCommandResponse + sendRequest_ WorkspaceExecuteCommand reqParams editReq <- request :: Session ApplyWorkspaceEditRequest liftIO $ do @@ -144,14 +122,37 @@ main = hspec $ do (Position 1 14) "Redundant bracket" reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) - sendRequest WorkspaceExecuteCommand reqParams - skipMany anyNotification - _ <- response :: Session ExecuteCommandResponse - + sendRequest_ WorkspaceExecuteCommand reqParams contents <- getDocumentEdit doc liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42" noDiagnostics + describe "getAllCodeActions" $ + it "works" $ runSession "hie --lsp" "test/data/refactor" $ do + doc <- openDoc "Main.hs" "haskell" + _ <- waitForDiagnostics + actions <- getAllCodeActions doc + liftIO $ do + let [CommandOrCodeActionCommand action] = actions + action ^. title `shouldBe` "Apply hint:Redundant bracket" + action ^. command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne" + + describe "getDocumentSymbols" $ + it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + + skipMany loggingNotification + + noDiagnostics + + (mainSymbol:_) <- getDocumentSymbols doc + + liftIO $ do + mainSymbol ^. name `shouldBe` "main" + mainSymbol ^. kind `shouldBe` SkFunction + mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4) + mainSymbol ^. containerName `shouldBe` Nothing + parsingSpec data ApplyOneParams = AOP -- 2.30.2