X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=b406e7bd4e87a5a068d59b44e7b27678b100a64e;hb=3b8d5fe55d1e542587817341a797345270ca7a96;hp=8e5f21f445e5ae1a4ce8f1f42f2b7909324e57c6;hpb=22df37c703e39fa5ebeb130be5785b3a9713c520;p=opengl.git

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index 8e5f21f..b406e7b 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
@@ -60,13 +63,21 @@ module Language.Haskell.LSP.Test
   , satisfy
   -- * Utilities
   , initializeResponse
+  -- ** Documents
   , openDoc
   , documentContents
-  , documentEdit
+  , getDocumentEdit
   , getDocUri
+  -- ** Symbols
+  , getDocumentSymbols
+  -- ** Diagnostics
+  , waitForDiagnostics
   , noDiagnostics
-  , documentSymbols
-  ,
+  -- ** Commands
+  , executeCommand
+  -- ** Code Actions
+  , getAllCodeActions
+  , executeCodeAction
   ) where
 
 import Control.Applicative
@@ -79,13 +90,13 @@ 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)
+import Language.Haskell.LSP.Types hiding (id, capabilities, error)
 import qualified Language.Haskell.LSP.Types as LSP
+import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.VFS
 import Language.Haskell.LSP.Test.Compat
 import Language.Haskell.LSP.Test.Decoding
@@ -121,13 +132,11 @@ runSessionWithConfig config serverExe rootDir session = do
                                           Nothing
                                           (capabilities config)
                                           (Just TraceOff)
-
-  withServer serverExe $ \serverIn serverOut _ ->
+  withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
     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)
 
@@ -166,8 +175,8 @@ documentContents doc = do
 
 -- | Parses an ApplyEditRequest, checks that it is for the passed document
 -- and returns the new content
-documentEdit :: TextDocumentIdentifier -> Session T.Text
-documentEdit doc = do
+getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
+getDocumentEdit doc = do
   req <- request :: Session ApplyWorkspaceEditRequest
 
   unless (checkDocumentChanges req || checkChanges req) $
@@ -187,20 +196,26 @@ documentEdit 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 +243,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 $
@@ -271,11 +286,6 @@ sendNotification' = sendMessage
 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 sendResponse = sendMessage
 
-sendMessage :: ToJSON a => a -> Session ()
-sendMessage msg = do
-  h <- serverIn <$> ask
-  liftIO $ B.hPut h $ addHeader (encode msg)
-
 -- | 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.
@@ -306,16 +316,58 @@ getDocUri file = do
   let fp = rootDir context </> file
   return $ filePathToUri fp
 
+waitForDiagnostics :: Session [Diagnostic]
+waitForDiagnostics = do
+  diagsNot <- skipManyTill anyMessage notification :: Session PublishDiagnosticsNotification
+  let (List diags) = diagsNot ^. params . LSP.diagnostics
+  return diags
+
 -- | 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
+  when (diagsNot ^. params . LSP.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
+getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation]
+getDocumentSymbols doc = do
+  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)
+
+executeCommand :: Command -> Session ()
+executeCommand cmd = do
+  let args = decode $ encode $ fromJust $ cmd ^. arguments
+      execParams = ExecuteCommandParams (cmd ^. command) args
+  sendRequest_ WorkspaceExecuteCommand execParams
+
+executeCodeAction :: CodeAction -> Session ()
+executeCodeAction action = do
+  maybe (return ()) handleEdit $ action ^. edit
+  maybe (return ()) executeCommand $ action ^. command
+
+  where handleEdit :: WorkspaceEdit -> Session ()
+        handleEdit e =
+          let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
+            in processMessage (ReqApplyWorkspaceEdit req)
\ No newline at end of file