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
, conduit-parse
, aeson
, unordered-containers
+ , text
other-modules: ParsingTests
default-language: Haskell2010
, anySessionException
-- * Sending
, sendRequest
- , sendNotification
+ , sendRequest_
, sendRequest'
+ , sendNotification
+ , sendRequestMessage
, sendNotification'
, sendResponse
-- * Receving
, response
, anyNotification
, notification
+ , anyMessage
, loggingNotification
, publishDiagnosticsNotification
-- * Combinators
, getDocUri
, noDiagnostics
, getDocumentSymbols
- , getDiagnostics
+ , waitForDiagnostics
+ , getAllCodeActions
) where
import Control.Applicative
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)
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 }
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 $
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
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
import Control.Exception
import Language.Haskell.LSP.Messages
+import Language.Haskell.LSP.Types
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as B
| ReplayOutOfOrderException FromServerMessage [FromServerMessage]
| UnexpectedDiagnosticsException
| IncorrectApplyEditRequestException String
+ | UnexpectedResponseError LspIdRsp ResponseError
instance Exception SessionException
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
import Control.Applicative
import Control.Concurrent
+import Control.Lens
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Data.Aeson
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
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
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
{
curReqId :: LspId
, vfs :: VFS
+ , curDiagnostics :: Map.Map Uri [Diagnostic]
}
type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
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
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
- github: Bubba/haskell-lsp-client
commit: b7cf14eb48837a73032e867dab90db1708220c66
- github: Bubba/haskell-lsp
- commit: 4c705c23cac58b4f6535474acc61d054230b6699
+ commit: 47176f14738451b36b061b2314a2acb05329fde4
subdirs:
- .
- ./haskell-lsp-types
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)
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
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
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
(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
(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
projects / opengl.git / commitdiff