X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest.hs;h=bc04845f8d9774e4f5cd00c48e8cbe74153e1417;hb=3c7aa3a876b2142ceae3b649fbb5bd80e95aff77;hp=3b40842dd7ff169c69e3b1bbb3e2210a4d0eaaf0;hpb=12f6e7e7c1d2603712de134477a470bfa72ecf4b;p=lsp-test.git

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index 3b40842..bc04845 100644
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -41,7 +41,9 @@ module Language.Haskell.LSP.Test
   , initializeResponse
   -- ** Documents
   , openDoc
+  , openDoc'
   , closeDoc
+  , changeDoc
   , documentContents
   , getDocumentEdit
   , getDocUri
@@ -90,6 +92,7 @@ import qualified Data.Text.IO as T
 import Data.Aeson
 import Data.Default
 import qualified Data.HashMap.Strict as HashMap
+import Data.IORef
 import qualified Data.Map as Map
 import Data.Maybe
 import Language.Haskell.LSP.Types
@@ -108,7 +111,7 @@ import Language.Haskell.LSP.Test.Server
 import System.IO
 import System.Directory
 import System.FilePath
-import qualified Yi.Rope as Rope
+import qualified Data.Rope.UTF16 as Rope
 
 -- | Starts a new session.
 --
@@ -133,6 +136,8 @@ runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session
                      -> Session a -- ^ The session to run.
                      -> IO a
 runSessionWithConfig config serverExe caps rootDir session = do
+  -- We use this IORef to make exception non-fatal when the server is supposed to shutdown.
+  exitOk <- newIORef False
   pid <- getCurrentProcessID
   absRootDir <- canonicalizePath rootDir
 
@@ -144,7 +149,7 @@ runSessionWithConfig config serverExe caps rootDir session = do
                                           (Just TraceOff)
                                           Nothing
   withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->
-    runSessionWithHandles serverIn serverOut listenServer config caps rootDir $ do
+    runSessionWithHandles serverIn serverOut (\h c -> catchWhenTrue exitOk $ listenServer h c) config caps rootDir $ do
 
       -- Wrap the session around initialize and shutdown calls
       initRspMsg <- request Initialize initializeParams :: Session InitializeResponse
@@ -163,12 +168,22 @@ runSessionWithConfig config serverExe caps rootDir session = do
       -- Run the actual test
       result <- session
 
+      liftIO $ atomicWriteIORef exitOk True
       sendNotification Exit ExitParams
 
       return result
   where
+  catchWhenTrue :: IORef Bool -> IO () -> IO ()
+  catchWhenTrue exitOk a =
+      a `catch` (\e -> do
+          x <- readIORef exitOk
+          unless x $ throw (e :: SomeException))
+
   -- | Listens to the server output, makes sure it matches the record and
   -- signals any semaphores
+  -- Note that on Windows, we cannot kill a thread stuck in getNextMessage.
+  -- So we have to wait for the exit notification to kill the process first
+  -- and then getNextMessage will fail.
   listenServer :: Handle -> SessionContext -> IO ()
   listenServer serverOut context = do
     msgBytes <- getNextMessage serverOut
@@ -283,6 +298,15 @@ sendNotification TextDocumentDidClose params = do
   modify (\s -> s { vfs = newVFS })
   sendMessage n
 
+sendNotification TextDocumentDidChange params = do
+    let params' = fromJust $ decode $ encode params
+        n :: DidChangeTextDocumentNotification
+        n = NotificationMessage "2.0" TextDocumentDidChange params'
+    oldVFS <- vfs <$> get
+    newVFS <- liftIO $ changeFromClientVFS oldVFS n
+    modify (\s -> s { vfs = newVFS })
+    sendMessage n
+
 sendNotification method params = sendMessage (NotificationMessage "2.0" method params)
 
 -- | Sends a response to the server.
@@ -298,19 +322,20 @@ initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
 -- | Opens a text document and sends a notification to the client.
 openDoc :: FilePath -> String -> Session TextDocumentIdentifier
 openDoc file languageId = do
-  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.
-            -> Session TextDocumentItem
-  getDocItem file languageId = do
   context <- ask
   let fp = rootDir context </> file
   contents <- liftIO $ T.readFile fp
-    return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents
+  openDoc' file languageId contents
+
+-- | This is a variant of `openDoc` that takes the file content as an argument.
+openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
+openDoc' file languageId contents = do
+  context <- ask
+  let fp = rootDir context </> file
+      uri = filePathToUri fp
+      item = TextDocumentItem uri (T.pack languageId) 0 contents
+  sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
+  pure $ TextDocumentIdentifier uri
 
 -- | Closes a text document and sends a notification to the client.
 closeDoc :: TextDocumentIdentifier -> Session ()
@@ -318,10 +343,12 @@ closeDoc docId = do
   let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))
   sendNotification TextDocumentDidClose params
 
-  oldVfs <- vfs <$> get
-  let notif = NotificationMessage "" TextDocumentDidClose params
-  newVfs <- liftIO $ closeVFS oldVfs notif
-  modify $ \s -> s { vfs = newVfs }
+-- | Changes a text document and sends a notification to the client
+changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()
+changeDoc docId changes = do
+  verDoc <- getVersionedDoc docId
+  let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)
+  sendNotification TextDocumentDidChange params
 
 -- | Gets the Uri for the file corrected to the session directory.
 getDocUri :: FilePath -> Session Uri
@@ -351,7 +378,7 @@ waitForDiagnosticsSource src = do
     matches d = d ^. source == Just (T.pack src)
 
 -- | Expects a 'PublishDiagnosticsNotification' and throws an
--- 'UnexpectedDiagnosticsException' if there are any diagnostics
+-- 'UnexpectedDiagnostics' exception if there are any diagnostics
 -- returned.
 noDiagnostics :: Session ()
 noDiagnostics = do
@@ -436,7 +463,7 @@ getVersionedDoc (TextDocumentIdentifier uri) = do
   fs <- vfs <$> get
   let ver =
         case fs Map.!? uri of
-          Just (VirtualFile v _) -> Just v
+          Just (VirtualFile v _ _) -> Just v
           _ -> Nothing
   return (VersionedTextDocumentIdentifier uri ver)
 
@@ -449,7 +476,7 @@ applyEdit doc edit = do
   caps <- asks sessionCapabilities
 
   let supportsDocChanges = fromMaybe False $ do
-        let C.ClientCapabilities mWorkspace _ _ = caps
+        let mWorkspace = C._workspace caps
         C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace
         C.WorkspaceEditClientCapabilities mDocChanges <- mEdit
         mDocChanges