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 8da170c0d4fe6e984e2d21ffcd05dab6a79cfbc3..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


@@ -59,27 +62,41 @@ module Language.Haskell.LSP.Test
   , (<|>)
   , satisfy
   -- * Utilities
   , (<|>)
   , satisfy
   -- * Utilities

-  , getInitializeResponse
+  , initializeResponse
+  -- ** Documents

   , openDoc
   , openDoc

-  , getDocItem

   , documentContents
   , documentContents

+  , getDocumentEdit

   , getDocUri
   , getDocUri

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

   ) where
 
 import Control.Applicative
 import Control.Applicative.Combinators
   ) where
 
 import Control.Applicative
 import Control.Applicative.Combinators

-import Control.Monad.IO.Class

 import Control.Concurrent
 import Control.Concurrent

+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Exception

 import Control.Lens hiding ((.=), List)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Data.Aeson
 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 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 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


@@ -106,7 +123,7 @@ runSessionWithConfig :: SessionConfig -- ^ The capabilities the client should ha
                      -> Session a -- ^ The session to run.
                      -> IO a
 runSessionWithConfig config serverExe rootDir session = do
                      -> Session a -- ^ The session to run.
                      -> IO a
 runSessionWithConfig config serverExe rootDir session = do

-  pid <- getProcessID
+  pid <- getCurrentProcessID

   absRootDir <- canonicalizePath rootDir
 
   let initializeParams = InitializeParams (Just pid)
   absRootDir <- canonicalizePath rootDir
 
   let initializeParams = InitializeParams (Just pid)


@@ -115,13 +132,11 @@ runSessionWithConfig config serverExe rootDir session = do
                                           Nothing
                                           (capabilities config)
                                           (Just TraceOff)
                                           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
     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)
 


@@ -136,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


@@ -158,20 +172,49 @@ documentContents doc = do
   let file = vfs Map.! (doc ^. uri)
   return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
 
   let file = vfs Map.! (doc ^. uri)
   return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
 

--- | Sends a request to the server.
---
+-- | Parses an ApplyEditRequest, checks that it is for the passed document
+-- and returns the new content
+getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
+getDocumentEdit doc = do
+  req <- request :: Session ApplyWorkspaceEditRequest
+
+  unless (checkDocumentChanges req || checkChanges req) $
+    liftIO $ throw (IncorrectApplyEditRequestException (show req))
+
+  documentContents doc
+  where
+    checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
+    checkDocumentChanges req =
+      let changes = req ^. params . edit . documentChanges
+          maybeDocs = fmap (fmap (^. textDocument . uri)) changes
+      in case maybeDocs of
+        Just docs -> (doc ^. uri) `elem` docs
+        Nothing -> False
+    checkChanges :: ApplyWorkspaceEditRequest -> Bool
+    checkChanges req =
+      let mMap = req ^. params . edit . changes
+        in maybe False (HashMap.member (doc ^. uri)) mMap
+
+-- | 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 }
 


@@ -199,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 $


@@ -242,16 +285,11 @@ 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.

-getInitializeResponse :: Session InitializeResponse
-getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
+initializeResponse :: Session InitializeResponse
+initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)

 
 -- | Opens a text document and sends a notification to the client.
 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 
 -- | Opens a text document and sends a notification to the client.
 openDoc :: FilePath -> String -> Session TextDocumentIdentifier


@@ -259,7 +297,7 @@ openDoc file languageId = do
   item <- getDocItem file languageId
   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
   TextDocumentIdentifier <$> getDocUri file
   item <- getDocItem file languageId
   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
   TextDocumentIdentifier <$> getDocUri file

-
+  where

   -- | Reads in a text document as the first version.
   getDocItem :: FilePath -- ^ The path to the text document to read in.
             -> String -- ^ The language ID, e.g "haskell" for .hs files.
   -- | Reads in a text document as the first version.
   getDocItem :: FilePath -- ^ The path to the text document to read in.
             -> String -- ^ The language ID, e.g "haskell" for .hs files.


@@ -277,3 +315,58 @@ getDocUri file = do
   let fp = rootDir context </> file
   return $ filePathToUri fp
 
   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 . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
+
+-- | Returns the symbols in a document.
+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)