From: Luke Lau <luke_lau@icloud.com>
Date: Sat, 27 Feb 2021 17:16:22 +0000 (+0000)
Subject: Merge pull request #88 from wz1000/timeout-kill
X-Git-Url: https://git.lukelau.me/?p=lsp-test.git;a=commitdiff_plain;h=9caa331490b8415b7d7f1269989865797ac030bd;hp=6042c31e8b18eefb81b98a8ebb3e1e6f4a004907

Merge pull request #88 from wz1000/timeout-kill

Kill timeout thread to prevent TimeoutMessages from clogging up the queue
---

diff --git a/cabal.project b/cabal.project
index e125a7d..1c37eee 100644
--- a/cabal.project
+++ b/cabal.project
@@ -4,13 +4,3 @@ flags: +DummyServer
 test-show-details: direct
 haddock-quickjump: True
 
-source-repository-package
-    type: git
-    location: https://github.com/alanz/lsp.git
-    tag: b258a6921aeb188b64589f2d12727bbb9e66a93a
-    subdir: lsp-types
-
-source-repository-package
-    type: git
-    location: https://github.com/alanz/lsp.git
-    tag: b258a6921aeb188b64589f2d12727bbb9e66a93a
diff --git a/src/Language/LSP/Test.hs b/src/Language/LSP/Test.hs
index 6c5c4a6..ae24530 100644
--- a/src/Language/LSP/Test.hs
+++ b/src/Language/LSP/Test.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE TypeInType #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 
 {-|
 Module      : Language.LSP.Test
@@ -501,7 +502,7 @@ getDocumentSymbols doc = do
 -- | Returns the code actions in the specified range.
 getCodeActions :: TextDocumentIdentifier -> Range -> Session [Command |? CodeAction]
 getCodeActions doc range = do
-  ctx <- getCodeActionContext doc
+  ctx <- getCodeActionContextInRange doc range
   rsp <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc range ctx)
 
   case rsp ^. result of
@@ -526,6 +527,26 @@ getAllCodeActions doc = do
         Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e)
         Right (List cmdOrCAs) -> pure (acc ++ cmdOrCAs)
 
+getCodeActionContextInRange :: TextDocumentIdentifier -> Range -> Session CodeActionContext
+getCodeActionContextInRange doc caRange = do
+  curDiags <- getCurrentDiagnostics doc
+  let diags = [ d | d@Diagnostic{_range=range} <- curDiags
+                  , overlappingRange caRange range
+              ]
+  return $ CodeActionContext (List diags) Nothing
+  where
+    overlappingRange :: Range -> Range -> Bool
+    overlappingRange (Range s e) range =
+         positionInRange s range
+      || positionInRange e range
+
+    positionInRange :: Position -> Range -> Bool
+    positionInRange (Position pl po) (Range (Position sl so) (Position el eo)) =
+         pl >  sl && pl <  el
+      || pl == sl && pl == el && po >= so && po <= eo
+      || pl == sl && po >= so
+      || pl == el && po <= eo
+
 getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext
 getCodeActionContext doc = do
   curDiags <- getCurrentDiagnostics doc
diff --git a/test/Test.hs b/test/Test.hs
index b87d2f6..344bbd5 100644
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -118,7 +118,7 @@ main = findServer >>= \serverExe -> hspec $ do
               selector _ = False
             in runSession serverExe fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector
         it "provides the correct types that were expected and received" $
-          let selector (UnexpectedMessage "STextDocumentRename" (FromServerRsp STextDocumentDocumentSymbol _)) = True
+          let selector (UnexpectedMessage "Response for: STextDocumentRename" (FromServerRsp STextDocumentDocumentSymbol _)) = True
               selector _ = False
               sesh = do
                 doc <- openDoc "Desktop/simple.hs" "haskell"
@@ -161,8 +161,10 @@ main = findServer >>= \serverExe -> hspec $ do
     it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do
       doc <- openDoc "Main.hs" "haskell"
       waitForDiagnostics
-      [InR action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
+      [InR action] <- getCodeActions doc (Range (Position 0 0) (Position 0 2))
+      actions <- getCodeActions doc (Range (Position 1 14) (Position 1 18))
       liftIO $ action ^. title `shouldBe` "Delete this"
+      liftIO $ actions `shouldSatisfy` null
 
   describe "getAllCodeActions" $
     it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do