From e2ae28cd825653b0cb8b982d113497e9ac795059 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 11 Jul 2018 00:47:49 +0100 Subject: [PATCH] Add getCompletions helper function Rename exceptions to be less verbose --- src/Language/Haskell/LSP/Test.hs | 21 ++++++++++--- src/Language/Haskell/LSP/Test/Exceptions.hs | 20 ++++++------- src/Language/Haskell/LSP/Test/Replay.hs | 2 +- src/Language/Haskell/LSP/Test/Session.hs | 8 ++--- test/Test.hs | 33 +++++++++++++-------- 5 files changed, 52 insertions(+), 32 deletions(-) diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 4b0226c..427b617 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -77,6 +77,8 @@ module Language.Haskell.LSP.Test -- ** Code Actions , getAllCodeActions , executeCodeAction + -- ** Completions + , getCompletions -- ** Edits , applyEdit ) where @@ -181,7 +183,7 @@ getDocumentEdit doc = do req <- message :: Session ApplyWorkspaceEditRequest unless (checkDocumentChanges req || checkChanges req) $ - liftIO $ throw (IncorrectApplyEditRequestException (show req)) + liftIO $ throw (IncorrectApplyEditRequest (show req)) documentContents doc where @@ -330,7 +332,7 @@ waitForDiagnostics = do noDiagnostics :: Session () noDiagnostics = do diagsNot <- message :: Session PublishDiagnosticsNotification - when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException + when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics -- | Returns the symbols in a document. getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation] @@ -394,8 +396,8 @@ getVersionedDoc (TextDocumentIdentifier uri) = do return (VersionedTextDocumentIdentifier uri ver) -- | Applys an edit to the document and returns the updated document version. -applyEdit :: TextEdit -> TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier -applyEdit edit doc = do +applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier +applyEdit doc edit = do verDoc <- getVersionedDoc doc @@ -421,3 +423,14 @@ applyEdit edit doc = do -- 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 <- sendRequest TextDocumentCompletion (TextDocumentPositionParams doc pos) + + let exc = throw $ UnexpectedResponseError (rsp ^. LSP.id) + (fromJust $ rsp ^. LSP.error) + res = fromMaybe exc (rsp ^. result) + case res of + Completions (List items) -> return items + CompletionList (CompletionListType _ (List items)) -> return items diff --git a/src/Language/Haskell/LSP/Test/Exceptions.hs b/src/Language/Haskell/LSP/Test/Exceptions.hs index c8ca4f9..b337f0b 100644 --- a/src/Language/Haskell/LSP/Test/Exceptions.hs +++ b/src/Language/Haskell/LSP/Test/Exceptions.hs @@ -6,29 +6,29 @@ import Language.Haskell.LSP.Types import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B -data SessionException = TimeoutException - | UnexpectedMessageException String FromServerMessage - | ReplayOutOfOrderException FromServerMessage [FromServerMessage] - | UnexpectedDiagnosticsException - | IncorrectApplyEditRequestException String +data SessionException = Timeout + | UnexpectedMessage String FromServerMessage + | ReplayOutOfOrder FromServerMessage [FromServerMessage] + | UnexpectedDiagnostics + | IncorrectApplyEditRequest String | UnexpectedResponseError LspIdRsp ResponseError deriving Eq instance Exception SessionException instance Show SessionException where - show TimeoutException = "Timed out waiting to receive a message from the server." - show (UnexpectedMessageException expected lastMsg) = + show Timeout = "Timed out waiting to receive a message from the server." + show (UnexpectedMessage expected lastMsg) = "Received an unexpected message from the server:\n" ++ "Was parsing: " ++ expected ++ "\n" ++ "Last message received: " ++ show lastMsg - show (ReplayOutOfOrderException received expected) = + show (ReplayOutOfOrder received expected) = "Replay is out of order:\n" ++ -- Print json so its a bit easier to update the session logs "Received from server:\n" ++ B.unpack (encode received) ++ "\n" ++ "Expected one of:\n" ++ unlines (map (B.unpack . encode) expected) - show UnexpectedDiagnosticsException = "Unexpectedly received diagnostics from the server." - show (IncorrectApplyEditRequestException msgStr) = "ApplyEditRequest didn't contain document, instead received:\n" + show UnexpectedDiagnostics = "Unexpectedly received diagnostics from the server." + show (IncorrectApplyEditRequest 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 diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs index b224be6..979b789 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -145,7 +145,7 @@ listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs ++ [head $ dropWhile isNotification expectedMsgs] - exc = ReplayOutOfOrderException msg remainingMsgs + exc = ReplayOutOfOrder 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 a64e7ad..8990c43 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -136,16 +136,14 @@ instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m)) 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 = - -- source <- sourceList <$> getChanContents (messageChan context) - runReaderT (runStateT conduit state) context +runSession context state session = runReaderT (runStateT conduit state) context where conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler) handler (Unexpected "ConduitParser.empty") = do lastMsg <- fromJust . lastReceivedMessage <$> get name <- getParserName - liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg) + liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg) handler e = throw e @@ -160,7 +158,7 @@ runSession context state session = curId <- curTimeoutId <$> get case msg of ServerMessage sMsg -> yield sMsg - TimeoutMessage tId -> when (curId == tId) $ throw TimeoutException + TimeoutMessage tId -> when (curId == tId) $ throw Timeout -- | 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. diff --git a/test/Test.hs b/test/Test.hs index 3ff5ea4..845f6e4 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -21,7 +21,7 @@ import Language.Haskell.LSP.Types hiding (message, capabilities) import System.Timeout main = hspec $ do - describe "manual session" $ do + describe "Session" $ do 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 @@ -29,11 +29,11 @@ main = hspec $ do skipMany loggingNotification anyRequest in session `shouldThrow` anyException - it "can get initialize response" $ runSession "hie --lsp" "test/data/renamePass" $ do + it "initializeResponse" $ runSession "hie --lsp" "test/data/renamePass" $ do rsp <- initializeResponse liftIO $ rsp ^. result `shouldNotBe` Nothing - it "can register specific capabilities" $ + it "runSessionWithConfig" $ runSessionWithConfig (def { capabilities = didChangeCaps }) "hie --lsp" "test/data/renamePass" $ return () @@ -82,10 +82,10 @@ main = hspec $ do getDocumentSymbols doc -- should now timeout skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest - in sesh `shouldThrow` (== TimeoutException) + in sesh `shouldThrow` (== Timeout) - describe "exceptions" $ do + describe "SessionException" $ do it "throw on time out" $ let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" "test/data/renamePass" $ do skipMany loggingNotification @@ -101,11 +101,11 @@ main = hspec $ do describe "UnexpectedMessageException" $ do it "throws when there's an unexpected message" $ - let selector (UnexpectedMessageException "Publish diagnostics notification" (NotLogMessage _)) = True + let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True selector _ = False in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector it "provides the correct types that were expected and received" $ - let selector (UnexpectedMessageException "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True + let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True selector _ = False sesh = do doc <- openDoc "Desktop/simple.hs" "haskell" @@ -115,11 +115,11 @@ main = hspec $ do in runSession "hie --lsp" "test/data/renamePass" sesh `shouldThrow` selector - describe "replay session" $ do + describe "replaySession" $ do it "passes a test" $ replaySession "hie --lsp" "test/data/renamePass" it "fails a test" $ - let selector (ReplayOutOfOrderException _ _) = True + let selector (ReplayOutOfOrder _ _) = True selector _ = False in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector @@ -159,7 +159,7 @@ main = hspec $ do contents <- documentContents doc liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42" - describe "documentEdit" $ + describe "getDocumentEdit" $ it "automatically consumes applyedit requests" $ runSession "hie --lsp" "test/data/refactor" $ do doc <- openDoc "Main.hs" "haskell" @@ -204,15 +204,24 @@ main = hspec $ do doc <- openDoc "Desktop/simple.hs" "haskell" VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo" - VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit edit doc + VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit liftIO $ newVersion `shouldBe` oldVersion + 1 it "changes the document contents" $ runSession "hie --lsp" "test/data/renamePass" $ do doc <- openDoc "Desktop/simple.hs" "haskell" let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo" - applyEdit edit doc + applyEdit doc edit contents <- documentContents doc liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule" + describe "getCompletions" $ + it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + [item] <- getCompletions doc (Position 5 5) + liftIO $ do + item ^. label `shouldBe` "interactWithUser" + item ^. kind `shouldBe` Just CiFunction + item ^. detail `shouldBe` Just "Items -> IO ()\nMain" + didChangeCaps :: ClientCapabilities didChangeCaps = def { _workspace = Just workspaceCaps } -- 2.30.2