From 22df37c703e39fa5ebeb130be5785b3a9713c520 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 27 Jun 2018 02:28:34 +0100 Subject: [PATCH] Add documentEdit and friends helper functions --- example/Main.hs | 9 +--- src/Language/Haskell/LSP/Test.hs | 54 ++++++++++++++++++--- src/Language/Haskell/LSP/Test/Exceptions.hs | 5 ++ src/Language/Haskell/LSP/Test/Replay.hs | 4 +- src/Language/Haskell/LSP/Test/Session.hs | 4 +- stack.yaml | 5 +- test/Test.hs | 37 ++++++++------ test/data/renamePass/session.log | 2 +- 8 files changed, 85 insertions(+), 35 deletions(-) diff --git a/example/Main.hs b/example/Main.hs index 29795fa..4891c6c 100644 --- a/example/Main.hs +++ b/example/Main.hs @@ -1,17 +1,12 @@ import Language.Haskell.LSP.Test import Language.Haskell.LSP.TH.DataTypesJSON -import Data.Proxy import Control.Monad.IO.Class main = runSession "hie --lsp" "test/recordings/renamePass" $ do + docItem <- openDoc "Desktop/simple.hs" "haskell" - docItem <- getDocItem "Desktop/simple.hs" "haskell" - docId <- TextDocumentIdentifier <$> getDocUri "Desktop/simple.hs" - - sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem) - - sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams docId) + sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams docItem) skipMany loggingNotification diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 3331c09..8e5f21f 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -59,23 +59,29 @@ module Language.Haskell.LSP.Test , (<|>) , satisfy -- * Utilities - , getInitializeResponse + , initializeResponse , openDoc - , getDocItem , documentContents + , documentEdit , getDocUri + , noDiagnostics + , documentSymbols + , ) where import Control.Applicative import Control.Applicative.Combinators -import Control.Monad.IO.Class import Control.Concurrent +import Control.Monad +import Control.Monad.IO.Class +import Control.Exception import Control.Lens hiding ((.=), List) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B import Data.Default +import qualified Data.HashMap.Strict as HashMap import qualified Data.Map as Map import Data.Maybe import Language.Haskell.LSP.Types hiding (id, capabilities) @@ -158,6 +164,29 @@ documentContents doc = do let file = vfs Map.! (doc ^. uri) return $ Rope.toText $ Language.Haskell.LSP.VFS._text file +-- | Parses an ApplyEditRequest, checks that it is for the passed document +-- and returns the new content +documentEdit :: TextDocumentIdentifier -> Session T.Text +documentEdit doc = do + req <- request :: Session ApplyWorkspaceEditRequest + + unless (checkDocumentChanges req || checkChanges req) $ + liftIO $ throw (IncorrectApplyEditRequestException (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. -- -- @ @@ -250,8 +279,8 @@ sendMessage msg = do -- | 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. -getInitializeResponse :: Session InitializeResponse -getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar) +initializeResponse :: Session InitializeResponse +initializeResponse = initRsp <$> ask >>= (liftIO . readMVar) -- | Opens a text document and sends a notification to the client. openDoc :: FilePath -> String -> Session TextDocumentIdentifier @@ -259,7 +288,7 @@ openDoc file languageId = do item <- getDocItem file languageId sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item) TextDocumentIdentifier <$> getDocUri file - + where -- | Reads in a text document as the first version. getDocItem :: FilePath -- ^ The path to the text document to read in. -> String -- ^ The language ID, e.g "haskell" for .hs files. @@ -277,3 +306,16 @@ getDocUri file = do let fp = rootDir context file return $ filePathToUri fp +-- | Expects a 'PublishDiagnosticsNotification' and throws an +-- 'UnexpectedDiagnosticsException' if there are any diagnostics +-- returned. +noDiagnostics :: Session () +noDiagnostics = do + diagsNot <- notification :: Session PublishDiagnosticsNotification + when (diagsNot ^. params . diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException + +-- | Returns the symbols in a document. +documentSymbols :: TextDocumentIdentifier -> Session DocumentSymbolsResponse +documentSymbols doc = do + sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc) + response \ 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 e9c65f9..25db584 100644 --- a/src/Language/Haskell/LSP/Test/Exceptions.hs +++ b/src/Language/Haskell/LSP/Test/Exceptions.hs @@ -6,6 +6,8 @@ import Language.Haskell.LSP.Messages data SessionException = TimeoutException | UnexpectedMessageException String FromServerMessage | ReplayOutOfOrderException FromServerMessage [FromServerMessage] + | UnexpectedDiagnosticsException + | IncorrectApplyEditRequestException String instance Exception SessionException @@ -19,6 +21,9 @@ instance Show SessionException where "Replay is out of order:\n" ++ "Received from server:" ++ show received ++ "\n" ++ "Expected one of: " ++ concatMap show expected + show UnexpectedDiagnosticsException = "Unexpectedly received diagnostics from the server." + show (IncorrectApplyEditRequestException msgStr) = "ApplyEditRequest didn't contain document, instead received:\n" + ++ msgStr anySessionException :: SessionException -> Bool anySessionException = const True \ No newline at end of file diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs index ad26858..88bc092 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -136,9 +136,9 @@ listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut else if inRightOrder msg expectedMsgs then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut - else let expectedMsgs = takeWhile (not . isNotification) expectedMsgs + else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs ++ [head $ dropWhile isNotification expectedMsgs] - exc = ReplayOutOfOrderException msg expectedMsgs + exc = ReplayOutOfOrderException msg remainingMsgs in liftIO $ throwTo mainThreadId exc where diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index 9782014..6599cbd 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -60,8 +60,8 @@ type Session = ParserStateReader FromServerMessage SessionState SessionContext I -- | Stuff you can configure for a 'Session'. data SessionConfig = SessionConfig { - capabilities :: ClientCapabilities, -- ^ Specific capabilities the client should advertise. - timeout :: Int -- ^ Maximum time to wait for a request in seconds. + capabilities :: ClientCapabilities -- ^ Specific capabilities the client should advertise. Default is yes to everything. + , timeout :: Int -- ^ Maximum time to wait for a request in seconds. Defaults to 60. } instance Default SessionConfig where diff --git a/stack.yaml b/stack.yaml index e77a024..f02f337 100644 --- a/stack.yaml +++ b/stack.yaml @@ -3,11 +3,10 @@ packages: - . extra-deps: - # - haskell-lsp - github: Bubba/haskell-lsp-client commit: b7cf14eb48837a73032e867dab90db1708220c66 - - github: Bubba/haskell-lsp - commit: 3e046bf095568099dae606e1c20a92f1dc60b7b9 + - github: alanz/haskell-lsp + commit: 5f60fb1cbe09e7026201577ad76fa95116008131 subdirs: - . - ./haskell-lsp-types diff --git a/test/Test.hs b/test/Test.hs index 3c53aec..c6ef7e2 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} + import Test.Hspec import Data.Aeson import Data.Default @@ -26,7 +27,7 @@ main = hspec $ do skipMany loggingNotification - checkNoDiagnostics + noDiagnostics rspSymbols <- documentSymbols doc @@ -46,7 +47,7 @@ main = hspec $ do anyRequest in session `shouldThrow` anyException it "can get initialize response" $ runSession "hie --lsp" "test/data/renamePass" $ do - rsp <- getInitializeResponse + rsp <- initializeResponse liftIO $ rsp ^. result `shouldNotBe` Nothing it "can register specific capabilities" $ do @@ -99,7 +100,7 @@ main = hspec $ do runSession "javascript-typescript-stdio" "test/data/javascriptPass" $ do doc <- openDoc "test.js" "javascript" - checkNoDiagnostics + noDiagnostics rspSymbols <- documentSymbols doc @@ -109,7 +110,7 @@ main = hspec $ do fooSymbol ^. name `shouldBe` "foo" fooSymbol ^. kind `shouldBe` SkFunction - describe "text document state" $ + describe "text document VFS" $ it "sends back didChange notifications" $ runSession "hie --lsp" "test/data/refactor" $ do doc <- openDoc "Main.hs" "haskell" @@ -129,11 +130,28 @@ main = hspec $ do u `shouldBe` doc ^. uri es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"] - checkNoDiagnostics + noDiagnostics contents <- documentContents doc liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42" + describe "documentEdit" $ + it "automatically consumes applyedit requests" $ + runSession "hie --lsp" "test/data/refactor" $ do + doc <- openDoc "Main.hs" "haskell" + + let args = toJSON $ AOP (doc ^. uri) + (Position 1 14) + "Redundant bracket" + reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) + sendRequest WorkspaceExecuteCommand reqParams + skipMany anyNotification + _ <- response :: Session ExecuteCommandResponse + + contents <- documentEdit doc + liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42" + noDiagnostics + parsingSpec data ApplyOneParams = AOP @@ -142,12 +160,3 @@ data ApplyOneParams = AOP , hintTitle :: String } deriving (Generic, ToJSON) -checkNoDiagnostics :: Session () -checkNoDiagnostics = do - diagsNot <- notification :: Session PublishDiagnosticsNotification - liftIO $ diagsNot ^. params . diagnostics `shouldBe` List [] - -documentSymbols :: TextDocumentIdentifier -> Session DocumentSymbolsResponse -documentSymbols doc = do - sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc) - response diff --git a/test/data/renamePass/session.log b/test/data/renamePass/session.log index 36b6c2a..4cf5766 100644 --- a/test/data/renamePass/session.log +++ b/test/data/renamePass/session.log @@ -1,5 +1,5 @@ {"tag":"FromClient","contents":["2018-06-03T04:08:38.856591Z",{"tag":"ReqInitialize","contents":{"jsonrpc":"2.0","params":{"rootUri":"file:///Users/luke","processId":7558,"rootPath":"/Users/luke","capabilities":{"textDocument":{"completion":{"completionItem":{"snippetSupport":false}}}},"trace":"off"},"method":"initialize","id":9}}]} -{"tag":"FromServer","contents":["2018-06-03T04:08:38.873087Z",{"tag":"RspInitialize","contents":{"result":{"capabilities":{"textDocumentSync":{"openClose":true,"change":2,"willSave":false,"willSaveWaitUntil":false,"save":{"includeText":false}},"documentRangeFormattingProvider":true,"documentHighlightProvider":true,"executeCommandProvider":{"commands":["57b3244d-e5fe-47fe-9ca8-f4b15f444541:applyrefact:applyOne","57b3244d-e5fe-47fe-9ca8-f4b15f444541:hare:demote"]},"renameProvider":true,"definitionProvider":true,"hoverProvider":true,"codeActionProvider":true,"completionProvider":{"triggerCharacters":["."],"resolveProvider":true},"documentSymbolProvider":true,"documentFormattingProvider":true,"referencesProvider":true}},"jsonrpc":"2.0","id":9}}]} +{"tag":"FromServer","contents":["2018-06-03T04:08:38.873087Z",{"tag":"RspInitialize","contents":{"result":{"capabilities":{"textDocumentSync":{"openClose":true,"change":2,"willSave":false,"willSaveWaitUntil":false,"save":{"includeText":false}},"documentRangeFormattingProvider":true,"documentHighlightProvider":true,"executeCommandProvider":{"commands":["1234:applyrefact:applyOne","1234:hare:demote","16026:hie:applyWorkspaceEdit","16026:hsimport:import","16026:package:add"]},"renameProvider":true,"definitionProvider":true,"hoverProvider":true,"codeActionProvider":true,"completionProvider":{"triggerCharacters":["."],"resolveProvider":true},"documentSymbolProvider":true,"documentFormattingProvider":true,"referencesProvider":true}},"jsonrpc":"2.0","id":9}}]} {"tag":"FromClient","contents":["2018-06-03T04:08:39.325465Z",{"tag":"NotInitialized","contents":{"jsonrpc":"2.0","params":{},"method":"initialized"}}]} {"tag":"FromClient","contents":["2018-06-03T04:08:39.325807Z",{"tag":"NotDidChangeConfiguration","contents":{"jsonrpc":"2.0","params":{"settings":{}},"method":"workspace/didChangeConfiguration"}}]} {"tag":"FromClient","contents":["2018-06-03T04:08:39.326177Z",{"tag":"NotDidOpenTextDocument","contents":{"jsonrpc":"2.0","params":{"textDocument":{"languageId":"haskell","text":"module Main where\n\nmain :: IO ()\nmain = do\n let initialList = []\n interactWithUser initialList\n\ntype Item = String\ntype Items = [Item]\n\ndata Command = Quit\n | DisplayItems\n | AddItem String\n | RemoveItem Int\n | Help\n\ntype Error = String\n\nparseCommand :: String -> Either Error Command\nparseCommand line = case words line of\n [\"quit\"] -> Right Quit\n [\"items\"] -> Right DisplayItems\n \"add\" : item -> Right $ AddItem $ unwords item\n \"remove\" : i -> Right $ RemoveItem $ read $ unwords i\n [\"help\"] -> Right Help\n _ -> Left \"Unknown command\"\n\naddItem :: Item -> Items -> Items\naddItem = (:)\n\ndisplayItems :: Items -> String\ndisplayItems = unlines . map (\"- \" ++)\n\nremoveItem :: Int -> Items -> Either Error Items\nremoveItem i items\n | i < 0 || i >= length items = Left \"Out of range\"\n | otherwise = Right result\n where (front, back) = splitAt (i + 1) items\n result = init front ++ back\n\ninteractWithUser :: Items -> IO ()\ninteractWithUser items = do\n line <- getLine\n case parseCommand line of\n Right DisplayItems -> do\n putStrLn $ displayItems items\n interactWithUser items\n\n Right (AddItem item) -> do\n let newItems = addItem item items\n putStrLn \"Added\"\n interactWithUser newItems\n\n Right (RemoveItem i) ->\n case removeItem i items of\n Right newItems -> do\n putStrLn $ \"Removed \" ++ items !! i\n interactWithUser newItems\n Left err -> do\n putStrLn err\n interactWithUser items\n\n\n Right Quit -> return ()\n\n Right Help -> do\n putStrLn \"Commands:\"\n putStrLn \"help\"\n putStrLn \"items\"\n putStrLn \"add\"\n putStrLn \"quit\"\n interactWithUser items\n\n Left err -> do\n putStrLn $ \"Error: \" ++ err\n interactWithUser items\n","uri":"file:///Users/luke/Desktop/simple.hs","version":0}},"method":"textDocument/didOpen"}}]} -- 2.30.2