From: Luke Lau Date: Sat, 27 Feb 2021 17:17:51 +0000 (+0000) Subject: Merge pull request #89 from wz1000/lsp-equality X-Git-Url: https://git.lukelau.me/?p=lsp-test.git;a=commitdiff_plain;h=0132314e3f91ad3ba9e0405e53f5dca6f5d46ab1;hp=7ce2b4cb189b6276eed979661852029d68191c8f Merge pull request #89 from wz1000/lsp-equality update equality function --- 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/src/Language/LSP/Test/Parsing.hs b/src/Language/LSP/Test/Parsing.hs index b522116..247f969 100644 --- 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 55055cd..f3d6f8c 100644 --- 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 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