Merge pull request #89 from wz1000/lsp-equality

update equality function

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/src/Language/LSP/Test/Parsing.hs b/src/Language/LSP/Test/Parsing.hs
index b5221168dff1ba2bf6d2f55fecb96fa99c3b3935..247f969862f2ad25a42ad3dc10e6de4802509201 100644 (file)
--- a/src/Language/LSP/Test/Parsing.hs
+++ b/src/Language/LSP/Test/Parsing.hs
@@ -83,16 +83,21 @@ satisfyMaybeM pred = do
   
   skipTimeout <- overridingTimeout <$> get
   timeoutId <- getCurTimeoutId
-  unless skipTimeout $ do
+  mtid <-
+    if skipTimeout
+    then pure Nothing
+    else Just <$> do
       chan <- asks messageChan
       timeout <- asks (messageTimeout . config)
-    void $ liftIO $ forkIO $ do
+      liftIO $ forkIO $ do
         threadDelay (timeout * 1000000)
         writeChan chan (TimeoutMessage timeoutId)
 
   x <- Session await
 
-  unless skipTimeout (bumpTimeoutId timeoutId)
+  forM_ mtid $ \tid -> do
+    bumpTimeoutId timeoutId
+    liftIO $ killThread tid
 
   modify $ \s -> s { lastReceivedMessage = Just x }
 

diff --git a/src/Language/LSP/Test/Session.hs b/src/Language/LSP/Test/Session.hs
index 55055cdebfce545b65755a9c5b7f3c72f33feb3b..f3d6f8c28e83c7250bd093bde204e79964e08204 100644 (file)
--- a/src/Language/LSP/Test/Session.hs
+++ b/src/Language/LSP/Test/Session.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP               #-}
+{-# LANGUAGE BangPatterns      #-}
 {-# LANGUAGE GADTs             #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -56,7 +57,7 @@ import Data.Conduit.Parser as Parser
 import Data.Default
 import Data.Foldable
 import Data.List
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
@@ -79,6 +80,7 @@ import System.Process (ProcessHandle())
 import System.Process (waitForProcess)
 #endif
 import System.Timeout
+import Data.IORef
 
 -- | A session representing one instance of launching and connecting to a server.
 --
@@ -135,7 +137,7 @@ data SessionContext = SessionContext
   , rootDir :: FilePath
   , messageChan :: Chan SessionMessage -- ^ Where all messages come through
   -- Keep curTimeoutId in SessionContext, as its tied to messageChan
-  , curTimeoutId :: MVar Int -- ^ The current timeout we are waiting on
+  , curTimeoutId :: IORef Int -- ^ The current timeout we are waiting on
   , requestMap :: MVar RequestMap
   , initRsp :: MVar (ResponseMessage Initialize)
   , config :: SessionConfig
@@ -154,7 +156,7 @@ instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where
   ask = lift $ lift Reader.ask
 
 getCurTimeoutId :: (HasReader SessionContext m, MonadIO m) => m Int
-getCurTimeoutId = asks curTimeoutId >>= liftIO . readMVar
+getCurTimeoutId = asks curTimeoutId >>= liftIO . readIORef
 
 -- Pass this the timeoutid you *were* waiting on
 bumpTimeoutId :: (HasReader SessionContext m, MonadIO m) => Int -> m ()
@@ -162,21 +164,21 @@ bumpTimeoutId prev = do
   v <- asks curTimeoutId
   -- when updating the curtimeoutid, account for the fact that something else
   -- might have bumped the timeoutid in the meantime
-  liftIO $ modifyMVar_ v (\x -> pure (max x (prev + 1)))
+  liftIO $ atomicModifyIORef' v (\x -> (max x (prev + 1), ()))
 
 data SessionState = SessionState
   {
-    curReqId :: Int
-  , vfs :: VFS
-  , curDiagnostics :: Map.Map NormalizedUri [Diagnostic]
-  , overridingTimeout :: Bool
+    curReqId :: !Int
+  , vfs :: !VFS
+  , curDiagnostics :: !(Map.Map NormalizedUri [Diagnostic])
+  , overridingTimeout :: !Bool
   -- ^ The last received message from the server.
   -- Used for providing exception information
-  , lastReceivedMessage :: Maybe FromServerMessage
-  , curDynCaps :: Map.Map T.Text SomeRegistration
+  , lastReceivedMessage :: !(Maybe FromServerMessage)
+  , curDynCaps :: !(Map.Map T.Text SomeRegistration)
   -- ^ The capabilities that the server has dynamically registered with us so
   -- far
-  , curProgressSessions :: Set.Set ProgressToken
+  , curProgressSessions :: !(Set.Set ProgressToken)
   }
 
 class Monad m => HasState s m where
@@ -261,7 +263,7 @@ runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exi
 
   reqMap <- newMVar newRequestMap
   messageChan <- newChan
-  timeoutIdVar <- newMVar 0
+  timeoutIdVar <- newIORef 0
   initRsp <- newEmptyMVar
 
   mainThreadId <- myThreadId
@@ -441,10 +443,11 @@ withTimeout duration f = do
   chan <- asks messageChan
   timeoutId <- getCurTimeoutId
   modify $ \s -> s { overridingTimeout = True }
-  liftIO $ forkIO $ do
+  tid <- liftIO $ forkIO $ do
     threadDelay (duration * 1000000)
     writeChan chan (TimeoutMessage timeoutId)
   res <- f
+  liftIO $ killThread tid
   bumpTimeoutId timeoutId
   modify $ \s -> s { overridingTimeout = False }
   return res

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