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 e125a7de096fe2039bedab64f6c040c8d2b803ce..1c37eee0e5087f345e385dc117c2080619309426 100644 (file)
--- 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 6c5c4a6674681b0a077352f9274864737eb1bad5..ae2453065be6051420e6c73e218208cd0c120a4a 100644 (file)
--- 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 b87d2f617220745e0a6a996ffd869d205c5a8440..344bbd587c2390b460e9212b715203fccfb2dd21 100644 (file)
--- 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