X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=047e35b0ac715d765eeb4f1c02f11a63b015426e;hb=1f39d55cc3fb2e840a115c12d7da3935b9529361;hp=086a34c9257465d8ef284f66e5138486dbc91832;hpb=7d0ddb8022d9cccc68a99008dd55c1d39ddda3e7;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index 086a34c..047e35b 100644
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -15,7 +15,7 @@ module Language.Haskell.LSP.Test
   (
   -- * Sessions
     runSession
-  , runSessionWithHandler
+  , runSessionWithHandles
   , Session
   -- * Sending
   , sendRequest
@@ -54,6 +54,7 @@ module Language.Haskell.LSP.Test
   , (<|>)
   , satisfy
   -- * Utilities
+  , getInitializeResponse
   , openDoc
   , getDocItem
   , getDocUri
@@ -64,27 +65,33 @@ import Control.Applicative.Combinators
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Concurrent
-import Control.Lens hiding ((.=))
+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 System.Process
+import Data.Foldable
+import qualified Data.HashMap.Strict as HashMap
+import Data.List
 import Language.Haskell.LSP.Types
 import qualified  Language.Haskell.LSP.Types as LSP (error, id)
+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.Test.Parsing
+import Language.Haskell.LSP.Test.Session
+import Language.Haskell.LSP.Test.Server
 import System.IO
 import System.Directory
 import System.FilePath
-import Language.Haskell.LSP.Test.Decoding
-import Language.Haskell.LSP.Test.Parsing
 
 -- | Starts a new session.
 runSession :: String -- ^ The command to run the server.
            -> FilePath -- ^ The filepath to the root directory for the session.
            -> Session a -- ^ The session to run.
-           -> IO ()
+           -> IO a
 runSession serverExe rootDir session = do
   pid <- getProcessID
   absRootDir <- canonicalizePath rootDir
@@ -96,49 +103,24 @@ runSession serverExe rootDir session = do
                                           def
                                           (Just TraceOff)
 
-  runSessionWithHandler listenServer serverExe rootDir $ do
+  withServer serverExe $ \serverIn serverOut _ -> runSessionWithHandles serverIn serverOut listenServer rootDir $ do
 
     -- Wrap the session around initialize and shutdown calls
     sendRequest Initialize initializeParams
-    initRsp <- response :: Session InitializeResponse
-    liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error)
+    initRspMsg <- response :: Session InitializeResponse
+
+    liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)
+
+    initRspVar <- initRsp <$> ask
+    liftIO $ putMVar initRspVar initRspMsg
 
     sendNotification Initialized InitializedParams
 
     -- Run the actual test
-    session
+    result <- session
 
     sendNotification Exit ExitParams
 
--- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
--- It also does not automatically send initialize and exit messages.
-runSessionWithHandler :: (Handle -> Session ())
-                      -> String
-                      -> FilePath
-                      -> Session a
-                      -> IO a
-runSessionWithHandler serverHandler serverExe rootDir session = do
-  absRootDir <- canonicalizePath rootDir
-
-  let createProc = (shell serverExe) { std_in = CreatePipe, std_out = CreatePipe }
-  (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess createProc
-
-  hSetBuffering serverIn  NoBuffering
-  hSetBuffering serverOut NoBuffering
-
-  reqMap <- newMVar newRequestMap
-  messageChan <- newChan
-  meaninglessChan <- newChan
-
-  let context = SessionContext serverIn absRootDir messageChan reqMap
-      initState = SessionState (IdInt 9)
-
-  threadId <- forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
-  (result, _) <- runSession' messageChan context initState session
-
-  terminateProcess serverProc
-  killThread threadId
-
     return result
 
 -- | Listens to the server output, makes sure it matches the record and
@@ -150,10 +132,40 @@ listenServer serverOut = do
   context <- ask
   reqMap <- liftIO $ readMVar $ requestMap context
 
-  liftIO $ writeChan (messageChan context) $ decodeFromServerMsg reqMap msgBytes
+  let msg = decodeFromServerMsg reqMap msgBytes
+  processTextChanges msg
+  liftIO $ writeChan (messageChan context) msg
 
   listenServer serverOut
 
+processTextChanges :: FromServerMessage -> Session ()
+processTextChanges (ReqApplyWorkspaceEdit r) = do
+  List changeParams <- case r ^. params . edit . documentChanges of
+    Just cs -> mapM applyTextDocumentEdit cs
+    Nothing -> case r ^. params . edit . changes of
+      Just cs -> mapM (uncurry applyTextEdit) (List (HashMap.toList cs))
+      Nothing -> return (List [])
+
+  let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) changeParams
+      mergedParams = map mergeParams groupedParams
+
+  forM_ mergedParams (sendNotification TextDocumentDidChange)
+
+  where applyTextDocumentEdit (TextDocumentEdit docId (List edits)) = do
+          oldVFS <- vfs <$> get
+          let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
+              params = DidChangeTextDocumentParams docId (List changeEvents)
+          newVFS <- liftIO $ changeVFS oldVFS (fmClientDidChangeTextDocumentNotification params)
+          modify (\s -> s { vfs = newVFS })
+          return params
+
+        applyTextEdit uri edits = applyTextDocumentEdit (TextDocumentEdit (VersionedTextDocumentIdentifier uri 0) edits)
+
+        mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
+        mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
+                             in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
+processTextChanges _ = return ()
+
 -- | Sends a request to the server.
 --
 -- @
@@ -224,6 +236,12 @@ 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.
+getInitializeResponse :: Session InitializeResponse
+getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
+
 -- | Opens a text document and sends a notification to the client.
 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 openDoc file languageId = do