X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=4cad784156477f23f4cefdb482de94764ac7d215;hb=fe5448266f5db772dd3f10be432cd56581bbcb40;hp=2a6db1fd459e711be61ebe67764d10543c2ef342;hpb=d8e460543b7cbc32550bed20d20ef4b13d6705a5;p=opengl.git

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index 2a6db1f..4cad784 100644
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -63,14 +63,21 @@ module Language.Haskell.LSP.Test
   , satisfy
   -- * Utilities
   , initializeResponse
+  -- ** Documents
   , openDoc
   , documentContents
   , getDocumentEdit
   , getDocUri
-  , noDiagnostics
+  -- ** Symbols
   , getDocumentSymbols
+  -- ** Diagnostics
   , waitForDiagnostics
+  , noDiagnostics
+  -- ** Commands
+  , executeCommand
+  -- ** Code Actions
   , getAllCodeActions
+  , executeCodeAction
   ) where
 
 import Control.Applicative
@@ -83,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 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
@@ -97,7 +104,6 @@ import Language.Haskell.LSP.Test.Exceptions
 import Language.Haskell.LSP.Test.Parsing
 import Language.Haskell.LSP.Test.Session
 import Language.Haskell.LSP.Test.Server
-import System.Console.ANSI
 import System.IO
 import System.Directory
 import System.FilePath
@@ -145,20 +151,19 @@ runSessionWithConfig config serverExe rootDir session = do
       sendNotification Exit ExitParams
 
       return result
-
+  where
   -- | 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
-  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
@@ -280,20 +285,6 @@ sendNotification' = sendMessage
 sendResponse :: ToJSON a => ResponseMessage a -> Session ()
 sendResponse = sendMessage
 
-sendMessage :: ToJSON a => a -> Session ()
-sendMessage msg = do
-  h <- serverIn <$> ask
-  let encoded = encode msg
-  liftIO $ do
-
-    setSGR [SetColor Foreground Vivid Cyan]
-    putStrLn $ "--> " ++ B.unpack encoded
-    setSGR [Reset]
-
-    B.hPut h (addHeader encoded)
-
-
-
 -- | 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.
@@ -363,3 +354,19 @@ getAllCodeActions doc = do
         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)