Rename exceptions to be less verbose
-- ** Code Actions
, getAllCodeActions
, executeCodeAction
-- ** Code Actions
, getAllCodeActions
, executeCodeAction
+ -- ** Completions
+ , getCompletions
-- ** Edits
, applyEdit
) where
-- ** Edits
, applyEdit
) where
req <- message :: Session ApplyWorkspaceEditRequest
unless (checkDocumentChanges req || checkChanges req) $
req <- message :: Session ApplyWorkspaceEditRequest
unless (checkDocumentChanges req || checkChanges req) $
- liftIO $ throw (IncorrectApplyEditRequestException (show req))
+ liftIO $ throw (IncorrectApplyEditRequest (show req))
documentContents doc
where
documentContents doc
where
noDiagnostics :: Session ()
noDiagnostics = do
diagsNot <- message :: Session PublishDiagnosticsNotification
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]
-- | Returns the symbols in a document.
getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
return (VersionedTextDocumentIdentifier uri ver)
-- | Applys an edit to the document and returns the updated document version.
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
verDoc <- getVersionedDoc doc
-- version may have changed
getVersionedDoc doc
-- 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
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as B
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
| 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
"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)
"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
++ msgStr
show (UnexpectedResponseError lid e) = "Received an exepected error in a response for id " ++ show lid ++ ":\n"
++ show e
then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx
else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs
++ [head $ dropWhile isNotification expectedMsgs]
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
in liftIO $ throwTo mainThreadId exc
where
type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)
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
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)
curId <- curTimeoutId <$> get
case msg of
ServerMessage sMsg -> yield sMsg
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.
-- | 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.
import System.Timeout
main = hspec $ do
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
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
skipMany loggingNotification
anyRequest
in session `shouldThrow` anyException
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
rsp <- initializeResponse
liftIO $ rsp ^. result `shouldNotBe` Nothing
- it "can register specific capabilities" $
+ it "runSessionWithConfig" $
runSessionWithConfig (def { capabilities = didChangeCaps })
"hie --lsp" "test/data/renamePass" $ return ()
runSessionWithConfig (def { capabilities = didChangeCaps })
"hie --lsp" "test/data/renamePass" $ return ()
getDocumentSymbols doc
-- should now timeout
skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest
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
it "throw on time out" $
let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" "test/data/renamePass" $ do
skipMany loggingNotification
describe "UnexpectedMessageException" $ do
it "throws when there's an unexpected message" $
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" $
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"
selector _ = False
sesh = do
doc <- openDoc "Desktop/simple.hs" "haskell"
in runSession "hie --lsp" "test/data/renamePass" sesh
`shouldThrow` selector
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" $
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
selector _ = False
in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector
contents <- documentContents doc
liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42"
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"
it "automatically consumes applyedit requests" $
runSession "hie --lsp" "test/data/refactor" $ do
doc <- openDoc "Main.hs" "haskell"
doc <- openDoc "Desktop/simple.hs" "haskell"
VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc
let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo"
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"
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"
contents <- documentContents doc
liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"
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 }
didChangeCaps :: ClientCapabilities
didChangeCaps = def { _workspace = Just workspaceCaps }