Remove superfluous Session handler

[opengl.git] / src / Language / Haskell / LSP / Test.hs

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index 1ce6871fb211f3a66e75f7ac95d65bbb979a4085..4cad784156477f23f4cefdb482de94764ac7d215 100644 (file)
--- 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
   , anySessionException
   -- * Sending
   , sendRequest

-  , sendNotification
+  , sendRequest_

   , sendRequest'
   , sendRequest'

+  , sendNotification
+  , sendRequestMessage

   , sendNotification'
   , sendResponse
   -- * Receving
   , sendNotification'
   , sendResponse
   -- * Receving


@@ -35,6 +37,7 @@ module Language.Haskell.LSP.Test
   , response
   , anyNotification
   , notification
   , response
   , anyNotification
   , notification

+  , anyMessage

   , loggingNotification
   , publishDiagnosticsNotification
   -- * Combinators
   , loggingNotification
   , publishDiagnosticsNotification
   -- * Combinators


@@ -60,13 +63,21 @@ module Language.Haskell.LSP.Test
   , satisfy
   -- * Utilities
   , initializeResponse
   , satisfy
   -- * Utilities
   , initializeResponse

+  -- ** Documents

   , openDoc
   , documentContents
   , getDocumentEdit
   , getDocUri
   , openDoc
   , documentContents
   , getDocumentEdit
   , getDocUri

-  , noDiagnostics
+  -- ** Symbols

   , getDocumentSymbols
   , getDocumentSymbols

-  , getDiagnostics
+  -- ** Diagnostics
+  , waitForDiagnostics
+  , noDiagnostics
+  -- ** Commands
+  , executeCommand
+  -- ** Code Actions
+  , getAllCodeActions
+  , executeCodeAction

   ) where
 
 import Control.Applicative
   ) 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.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 qualified Language.Haskell.LSP.Types as LSP
 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 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
 import Language.Haskell.LSP.VFS
 import Language.Haskell.LSP.Test.Compat
 import Language.Haskell.LSP.Test.Decoding


@@ -125,8 +136,7 @@ runSessionWithConfig config serverExe rootDir session = do
     runSessionWithHandles serverIn serverOut listenServer config rootDir $ do
 
       -- Wrap the session around initialize and shutdown calls
     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)
 
 
       liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
 


@@ -141,20 +151,19 @@ runSessionWithConfig config serverExe rootDir session = do
       sendNotification Exit ExitParams
 
       return result
       sendNotification Exit ExitParams
 
       return result

-
+  where

   -- | Listens to the server output, makes sure it matches the record and
   -- signals any semaphores
   -- | Listens to the server output, makes sure it matches the record and
   -- signals any semaphores

-listenServer :: Handle -> Session ()
-listenServer serverOut = do
-  msgBytes <- liftIO $ getNextMessage serverOut
+  listenServer :: Handle -> SessionContext -> IO ()
+  listenServer serverOut context = do
+    msgBytes <- getNextMessage serverOut

 
 

-  context <- ask
-  reqMap <- liftIO $ readMVar $ requestMap context
+    reqMap <- readMVar $ requestMap context

 
     let msg = decodeFromServerMsg reqMap msgBytes
 
     let msg = decodeFromServerMsg reqMap msgBytes

-  liftIO $ writeChan (messageChan context) msg
+    writeChan (messageChan context) msg

 
 

-  listenServer serverOut
+    listenServer serverOut context

 
 -- | The current text contents of a document.
 documentContents :: TextDocumentIdentifier -> Session T.Text
 
 -- | The current text contents of a document.
 documentContents :: TextDocumentIdentifier -> Session T.Text


@@ -186,20 +195,26 @@ getDocumentEdit doc = do
       let mMap = req ^. params . edit . changes
         in maybe False (HashMap.member (doc ^. uri)) mMap
 
       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.
   -> 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 }
 
   id <- curReqId <$> get
   modify $ \c -> c { curReqId = nextId id }
 


@@ -227,8 +242,8 @@ instance ToJSON a => ToJSON (RequestMessage' a) where
     object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]
 
 
     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 $
   -- Update the request map
   reqMap <- requestMap <$> ask
   liftIO $ modifyMVar_ reqMap $


@@ -270,11 +285,6 @@ sendNotification' = sendMessage
 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 sendResponse = 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.
 -- | 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.


@@ -305,9 +315,9 @@ getDocUri file = do
   let fp = rootDir context </> file
   return $ filePathToUri fp
 
   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
 
   let (List diags) = diagsNot ^. params . LSP.diagnostics
   return diags
 


@@ -320,7 +330,43 @@ noDiagnostics = do
   when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
 
 -- | Returns the symbols in a document.
   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
 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)
+
+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)