diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for lsp-test +## 0.11.0.0 -- 2020-05-14 + +* Replace `openDoc'` with `createDoc` which now sends + `workspace/didChangeWatchedFiles` notifications if the server has registered + for it +* Add `getRegisteredCapabilities` + ## 0.10.3.0 -- 2020-05-04 * Build with new haskell-lsp-0.22 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# lsp-test [![Actions Status](https://github.com/bubba/lsp-test/workflows/Haskell%20CI/badge.svg)](https://github.com/bubba/lsp-test/actions) [![Hackage](https://img.shields.io/hackage/v/lsp-test.svg)](https://hackage.haskell.org/package/lsp-test-0.1.0.0) +# lsp-test [![Actions Status](https://github.com/bubba/lsp-test/workflows/Haskell%20CI/badge.svg)](https://github.com/bubba/lsp-test/actions) [![Hackage](https://img.shields.io/hackage/v/lsp-test.svg)](https://hackage.haskell.org/package/lsp-test) lsp-test is a functional testing framework for Language Server Protocol servers. ```haskell @@ -35,17 +35,19 @@ ``` Try out the example tests in the `example` directory with `cabal test`. -For more examples check the [Wiki](https://github.com/bubba/lsp-test/wiki/Introduction) +For more examples check the [Wiki](https://github.com/bubba/lsp-test/wiki/Introduction). -## Developing -The tests are integration tests, so make sure you have the following language servers installed and on your PATH: -### [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine) -- Check out a relatively recent version of the repo, or see `.travis.yml` to get the exact commit used for CI. -- `stack install` -### [javascript-typescript-langserver](https://github.com/sourcegraph/javascript-typescript-langserver) -`npm i -g javascript-typescript-langserver` +Whilst writing your tests you may want to debug them to see what's going wrong. +You can set the `logMessages` and `logStdErr` options in `SessionConfig` to see what the server is up to. +There are also corresponding environment variables so you can turn them on from the command line: +``` +LSP_TEST_LOG_MESSAGES=1 cabal test +``` -Then run the tests with `cabal test` or `stack test`. +## Developing +The tests for lsp-test use a dummy server found in `test/dummy-server/`. +Run the tests with `cabal test` or `stack test`. +Tip: If you want to filter the tests, use `cabal run test:tests -- -m "foo"` ## Troubleshooting Seeing funny stuff when running lsp-test via stack? If your server is built upon Haskell tooling, [keep in mind that stack sets some environment variables related to GHC, and you may want to unset them.](https://github.com/alanz/haskell-ide-engine/blob/bfb16324d396da71000ef81d51acbebbdaa854ab/test/utils/TestUtils.hs#L290-L298) diff --git a/lsp-test.cabal b/lsp-test.cabal --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -1,5 +1,5 @@ name: lsp-test -version: 0.10.3.0 +version: 0.11.0.0 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against @@ -7,14 +7,16 @@ @Language.Haskell.LSP.Test@ launches your server as a subprocess and allows you to simulate a session down to the wire, and @Language.Haskell.LSP.Test@ can replay captured sessions from . - It's currently used for testing in . + To see examples of it in action, check out , + and + . homepage: https://github.com/bubba/lsp-test#readme license: BSD3 license-file: LICENSE author: Luke Lau maintainer: luke_lau@icloud.com bug-reports: https://github.com/bubba/lsp-test/issues -copyright: 2019 Luke Lau +copyright: 2020 Luke Lau category: Testing build-type: Simple cabal-version: 2.0 @@ -26,6 +28,11 @@ type: git location: https://github.com/bubba/lsp-test/ +Flag DummyServer + Description: Build the dummy server executable used in testing + Default: False + Manual: True + library hs-source-dirs: src exposed-modules: Language.Haskell.LSP.Test @@ -48,6 +55,7 @@ , Diff , directory , filepath + , Glob ^>= 0.10 , lens , mtl , parser-combinators >= 1.2 @@ -69,6 +77,22 @@ Language.Haskell.LSP.Test.Session ghc-options: -W +executable dummy-server + main-is: Main.hs + hs-source-dirs: test/dummy-server + ghc-options: -W + build-depends: base >= 4.10 && < 5 + , haskell-lsp + , data-default + , aeson + , unordered-containers + , directory + , filepath + default-language: Haskell2010 + scope: private + if !flag(DummyServer) + buildable: False + test-suite tests type: exitcode-stdio-1.0 main-is: Test.hs @@ -83,4 +107,7 @@ , aeson , unordered-containers , text + , directory + , filepath default-language: Haskell2010 + build-tool-depends: lsp-test:dummy-server diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -41,8 +41,8 @@ -- ** Initialization , initializeResponse -- ** Documents + , createDoc , openDoc - , openDoc' , closeDoc , changeDoc , documentContents @@ -82,6 +82,8 @@ , applyEdit -- ** Code lenses , getCodeLenses + -- ** Capabilities + , getRegisteredCapabilities ) where import Control.Applicative.Combinators @@ -90,12 +92,13 @@ import Control.Monad.IO.Class import Control.Exception import Control.Lens hiding ((.=), List) +import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Aeson import Data.Default import qualified Data.HashMap.Strict as HashMap -import qualified Data.Map as Map +import Data.List import Data.Maybe import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens hiding @@ -114,6 +117,7 @@ import System.IO import System.Directory import System.FilePath +import qualified System.FilePath.Glob as Glob -- | Starts a new session. -- @@ -345,7 +349,61 @@ initializeResponse :: Session InitializeResponse initializeResponse = initRsp <$> ask >>= (liftIO . readMVar) --- | Opens a text document and sends a notification to the client. +-- | /Creates/ a new text document. This is different from 'openDoc' +-- as it sends a workspace/didChangeWatchedFiles notification letting the server +-- know that a file was created within the workspace, __provided that the server +-- has registered for it__, and the file matches any patterns the server +-- registered for. +-- It /does not/ actually create a file on disk, but is useful for convincing +-- the server that one does exist. +-- +-- @since 11.0.0.0 +createDoc :: FilePath -- ^ The path to the document to open, __relative to the root directory__. + -> String -- ^ The text document's language identifier, e.g. @"haskell"@. + -> T.Text -- ^ The content of the text document to create. + -> Session TextDocumentIdentifier -- ^ The identifier of the document just created. +createDoc file languageId contents = do + dynCaps <- curDynCaps <$> get + rootDir <- asks rootDir + caps <- asks sessionCapabilities + absFile <- liftIO $ canonicalizePath (rootDir file) + let regs = filter (\r -> r ^. method == WorkspaceDidChangeWatchedFiles) $ + Map.elems dynCaps + watchHits :: FileSystemWatcher -> Bool + watchHits (FileSystemWatcher pattern kind) = + -- If WatchKind is exlcuded, defaults to all true as per spec + fileMatches pattern && createHits (fromMaybe (WatchKind True True True) kind) + + fileMatches pattern = Glob.match (Glob.compile pattern) relOrAbs + -- If the pattern is absolute then match against the absolute fp + where relOrAbs + | isAbsolute pattern = absFile + | otherwise = file + + createHits (WatchKind create _ _) = create + + regHits :: Registration -> Bool + regHits reg = isJust $ do + opts <- reg ^. registerOptions + fileWatchOpts <- case fromJSON opts :: Result DidChangeWatchedFilesRegistrationOptions of + Success x -> Just x + Error _ -> Nothing + if foldl' (\acc w -> acc || watchHits w) False (fileWatchOpts ^. watchers) + then Just () + else Nothing + + clientCapsSupports = + caps ^? workspace . _Just . didChangeWatchedFiles . _Just . dynamicRegistration . _Just + == Just True + shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs + + when shouldSend $ + sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + List [ FileEvent (filePathToUri file) FcCreated ] + openDoc' file languageId contents + +-- | Opens a text document that /exists on disk/, and sends a +-- textDocument/didOpen notification to the server. openDoc :: FilePath -> String -> Session TextDocumentIdentifier openDoc file languageId = do context <- ask @@ -354,6 +412,7 @@ openDoc' file languageId contents -- | This is a variant of `openDoc` that takes the file content as an argument. +-- Use this is the file exists /outside/ of the current workspace. openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier openDoc' file languageId contents = do context <- ask @@ -363,13 +422,13 @@ sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item) pure $ TextDocumentIdentifier uri --- | Closes a text document and sends a notification to the client. +-- | Closes a text document and sends a textDocument/didOpen notification to the server. closeDoc :: TextDocumentIdentifier -> Session () closeDoc docId = do let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri)) sendNotification TextDocumentDidClose params --- | Changes a text document and sends a notification to the client +-- | Changes a text document and sends a textDocument/didOpen notification to the server. changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session () changeDoc docId changes = do verDoc <- getVersionedDoc docId @@ -611,3 +670,10 @@ rsp <- request TextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse case getResponseResult rsp of List res -> pure res + +-- | Returns a list of capabilities that the server has requested to /dynamically/ +-- register during the 'Session'. +-- +-- @since 0.11.0.0 +getRegisteredCapabilities :: Session [Registration] +getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -75,7 +75,7 @@ satisfyMaybe pred = do skipTimeout <- overridingTimeout <$> get - timeoutId <- curTimeoutId <$> get + timeoutId <- getCurTimeoutId unless skipTimeout $ do chan <- asks messageChan timeout <- asks (messageTimeout . config) @@ -85,8 +85,7 @@ x <- Session await - unless skipTimeout $ - modify $ \s -> s { curTimeoutId = timeoutId + 1 } + unless skipTimeout (bumpTimeoutId timeoutId) modify $ \s -> s { lastReceivedMessage = Just x } diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -23,6 +23,8 @@ , sendMessage , updateState , withTimeout + , getCurTimeoutId + , bumpTimeoutId , logMsg , LogMsgType(..) ) @@ -61,6 +63,7 @@ import Language.Haskell.LSP.Types.Capabilities import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens +import qualified Language.Haskell.LSP.Types.Lens as LSP import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Test.Compat import Language.Haskell.LSP.Test.Decoding @@ -121,7 +124,9 @@ { serverIn :: Handle , rootDir :: FilePath - , messageChan :: Chan SessionMessage + , 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 , requestMap :: MVar RequestMap , initRsp :: MVar InitializeResponse , config :: SessionConfig @@ -139,16 +144,29 @@ 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 + +-- Pass this the timeoutid you *were* waiting on +bumpTimeoutId :: (HasReader SessionContext m, MonadIO m) => Int -> m () +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))) + data SessionState = SessionState { curReqId :: LspId , vfs :: VFS , curDiagnostics :: Map.Map NormalizedUri [Diagnostic] - , curTimeoutId :: Int , overridingTimeout :: Bool -- ^ The last received message from the server. -- Used for providing exception information , lastReceivedMessage :: Maybe FromServerMessage + , curDynCaps :: Map.Map T.Text Registration + -- ^ The capabilities that the server has dynamically registered with us so + -- far } class Monad m => HasState s m where @@ -166,15 +184,19 @@ get = Session (lift State.get) put = Session . lift . State.put -instance Monad m => HasState s (ConduitM a b (StateT s m)) +instance Monad m => HasState s (StateT s m) where + get = State.get + put = State.put + +instance (Monad m, (HasState s m)) => HasState s (ConduitM a b m) where - get = lift State.get - put = lift . State.put + get = lift get + put = lift . put -instance Monad m => HasState s (ConduitParser a (StateT s m)) +instance (Monad m, (HasState s m)) => HasState s (ConduitParser a m) where - get = lift State.get - put = lift . State.put + get = lift get + put = lift . put runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState) runSession context state (Session session) = runReaderT (runStateT conduit state) context @@ -200,7 +222,7 @@ watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) () watchdog = Conduit.awaitForever $ \msg -> do - curId <- curTimeoutId <$> get + curId <- getCurTimeoutId case msg of ServerMessage sMsg -> yield sMsg TimeoutMessage tId -> when (curId == tId) $ lastReceivedMessage <$> get >>= throw . Timeout @@ -229,25 +251,28 @@ reqMap <- newMVar newRequestMap messageChan <- newChan + timeoutIdVar <- newMVar 0 initRsp <- newEmptyMVar mainThreadId <- myThreadId - let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps - initState vfs = SessionState (IdInt 0) vfs - mempty 0 False Nothing + let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps + initState vfs = SessionState (IdInt 0) vfs mempty False Nothing mempty runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses - errorHandler = throwTo mainThreadId :: SessionException -> IO() + errorHandler = throwTo mainThreadId :: SessionException -> IO () serverListenerLauncher = forkIO $ catch (serverHandler serverOut context) errorHandler server = (Just serverIn, Just serverOut, Nothing, serverProc) - serverAndListenerFinalizer tid = - finally (timeout (messageTimeout config * 1000000) + serverAndListenerFinalizer tid = do + finally (timeout (messageTimeout config * 1^6) (runSession' exitServer)) - (cleanupProcess server >> killThread tid) + -- Make sure to kill the listener first, before closing + -- handles etc via cleanupProcess + (killThread tid >> cleanupProcess server) - (result, _) <- bracket serverListenerLauncher serverAndListenerFinalizer + (result, _) <- bracket serverListenerLauncher + serverAndListenerFinalizer (const $ runSession' session) return result @@ -258,12 +283,25 @@ updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m) => FromServerMessage -> m () + +-- Keep track of dynamic capability registration +updateState (ReqRegisterCapability req) = do + let List newRegs = (\r -> (r ^. LSP.id, r)) <$> req ^. params . registrations + modify $ \s -> + s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) } + +updateState (ReqUnregisterCapability req) = do + let List unRegs = (^. LSP.id) <$> req ^. params . unregistrations + modify $ \s -> + let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs + in s { curDynCaps = newCurDynCaps } + updateState (NotPublishDiagnostics n) = do let List diags = n ^. params . diagnostics doc = n ^. params . uri - modify (\s -> + modify $ \s -> let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s) - in s { curDiagnostics = newDiags }) + in s { curDiagnostics = newDiags } updateState (ReqApplyWorkspaceEdit r) = do @@ -336,21 +374,20 @@ logMsg LogClient msg liftIO $ B.hPut h (addHeader $ encode msg) --- | Execute a block f that will throw a 'Timeout' exception +-- | Execute a block f that will throw a 'Language.Haskell.LSP.Test.Exception.Timeout' exception -- after duration seconds. This will override the global timeout -- for waiting for messages to arrive defined in 'SessionConfig'. withTimeout :: Int -> Session a -> Session a withTimeout duration f = do chan <- asks messageChan - timeoutId <- curTimeoutId <$> get + timeoutId <- getCurTimeoutId modify $ \s -> s { overridingTimeout = True } liftIO $ forkIO $ do threadDelay (duration * 1000000) writeChan chan (TimeoutMessage timeoutId) res <- f - modify $ \s -> s { curTimeoutId = timeoutId + 1, - overridingTimeout = False - } + bumpTimeoutId timeoutId + modify $ \s -> s { overridingTimeout = False } return res data LogMsgType = LogServer | LogClient @@ -375,5 +412,3 @@ | otherwise = Cyan showPretty = B.unpack . encodePretty - - diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -15,37 +15,38 @@ import Control.Monad.IO.Class import Control.Monad import Control.Lens hiding (List) -import GHC.Generics import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Test -import Language.Haskell.LSP.Test.Replay import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Types.Lens as LSP hiding +import Language.Haskell.LSP.Types.Lens hiding (capabilities, message, rename, applyEdit) +import qualified Language.Haskell.LSP.Types.Lens as LSP import Language.Haskell.LSP.Types.Capabilities as LSP +import System.Directory +import System.FilePath import System.Timeout {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-} -main = hspec $ do + +main = findServer >>= \serverExe -> hspec $ do describe "Session" $ do - it "fails a test" $ - let session = runSession "hie" fullCaps "test/data/renamePass" $ do + it "fails a test" $ do + let session = runSession serverExe fullCaps "test/data/renamePass" $ do openDoc "Desktop/simple.hs" "haskell" - skipMany loggingNotification anyRequest in session `shouldThrow` anySessionException - it "initializeResponse" $ runSession "hie" fullCaps "test/data/renamePass" $ do + it "initializeResponse" $ runSession serverExe fullCaps "test/data/renamePass" $ do rsp <- initializeResponse - liftIO $ rsp ^. result `shouldSatisfy` isLeft + liftIO $ rsp ^. result `shouldSatisfy` isRight it "runSessionWithConfig" $ - runSession "hie" didChangeCaps "test/data/renamePass" $ return () + runSession serverExe didChangeCaps "test/data/renamePass" $ return () describe "withTimeout" $ do it "times out" $ - let sesh = runSession "hie" fullCaps "test/data/renamePass" $ do + let sesh = runSession serverExe fullCaps "test/data/renamePass" $ do openDoc "Desktop/simple.hs" "haskell" -- won't receive a request - will timeout -- incoming logging requests shouldn't increase the @@ -56,15 +57,13 @@ in timeout 6000000 sesh `shouldThrow` anySessionException it "doesn't time out" $ - let sesh = runSession "hie" fullCaps "test/data/renamePass" $ do + let sesh = runSession serverExe fullCaps "test/data/renamePass" $ do openDoc "Desktop/simple.hs" "haskell" withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification in void $ timeout 6000000 sesh - it "further timeout messages are ignored" $ runSession "hie" fullCaps "test/data/renamePass" $ do + it "further timeout messages are ignored" $ runSession serverExe fullCaps "test/data/renamePass" $ do doc <- openDoc "Desktop/simple.hs" "haskell" - -- warm up the cache - getDocumentSymbols doc -- shouldn't timeout withTimeout 3 $ getDocumentSymbols doc -- longer than the original timeout @@ -75,7 +74,7 @@ it "overrides global message timeout" $ let sesh = - runSessionWithConfig (def { messageTimeout = 5 }) "hie" fullCaps "test/data/renamePass" $ do + runSessionWithConfig (def { messageTimeout = 5 }) serverExe fullCaps "test/data/renamePass" $ do doc <- openDoc "Desktop/simple.hs" "haskell" -- shouldn't time out in here since we are overriding it withTimeout 10 $ liftIO $ threadDelay 7000000 @@ -85,7 +84,7 @@ it "unoverrides global message timeout" $ let sesh = - runSessionWithConfig (def { messageTimeout = 5 }) "hie" fullCaps "test/data/renamePass" $ do + runSessionWithConfig (def { messageTimeout = 5 }) serverExe fullCaps "test/data/renamePass" $ do doc <- openDoc "Desktop/simple.hs" "haskell" -- shouldn't time out in here since we are overriding it withTimeout 10 $ liftIO $ threadDelay 7000000 @@ -99,15 +98,15 @@ describe "SessionException" $ do it "throw on time out" $ - let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie" fullCaps "test/data/renamePass" $ do + let sesh = runSessionWithConfig (def {messageTimeout = 10}) serverExe fullCaps "test/data/renamePass" $ do skipMany loggingNotification _ <- message :: Session ApplyWorkspaceEditRequest return () in sesh `shouldThrow` anySessionException - it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie" fullCaps "test/data/renamePass" $ do + it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) serverExe fullCaps "test/data/renamePass" $ do loggingNotification - liftIO $ threadDelay $ 10 * 1000000 + liftIO $ threadDelay $ 6 * 1000000 _ <- openDoc "Desktop/simple.hs" "haskell" return () @@ -115,7 +114,7 @@ it "throws when there's an unexpected message" $ let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True selector _ = False - in runSession "hie" fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector + in runSession serverExe fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector it "provides the correct types that were expected and received" $ let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True selector _ = False @@ -124,40 +123,38 @@ sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) skipMany anyNotification message :: Session RenameResponse -- the wrong type - in runSession "hie" fullCaps "test/data/renamePass" sesh + in runSession serverExe fullCaps "test/data/renamePass" sesh `shouldThrow` selector - describe "replaySession" $ - -- This is too fickle at the moment - -- it "passes a test" $ - -- replaySession "hie" "test/data/renamePass" - it "fails a test" $ - let selector (ReplayOutOfOrder _ _) = True - selector _ = False - in replaySession "hie" "test/data/renameFail" `shouldThrow` selector + -- This is too fickle at the moment + -- describe "replaySession" $ + -- it "passes a test" $ + -- replaySession serverExe "test/data/renamePass" + -- it "fails a test" $ + -- let selector (ReplayOutOfOrder _ _) = True + -- selector _ = False + -- in replaySession serverExe "test/data/renameFail" `shouldThrow` selector - describe "manual javascript session" $ - it "passes a test" $ - runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do - doc <- openDoc "test.js" "javascript" + -- describe "manual javascript session" $ + -- it "passes a test" $ + -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do + -- doc <- openDoc "test.js" "javascript" - noDiagnostics + -- noDiagnostics - Right (fooSymbol:_) <- getDocumentSymbols doc + -- Right (fooSymbol:_) <- getDocumentSymbols doc - liftIO $ do - fooSymbol ^. name `shouldBe` "foo" - fooSymbol ^. kind `shouldBe` SkFunction + -- liftIO $ do + -- fooSymbol ^. name `shouldBe` "foo" + -- fooSymbol ^. kind `shouldBe` SkFunction describe "text document VFS" $ it "sends back didChange notifications" $ - runSession "hie" def "test/data/refactor" $ do + runSession serverExe def "test/data/refactor" $ do doc <- openDoc "Main.hs" "haskell" - let args = toJSON $ AOP (doc ^. uri) - (Position 1 14) - "Redundant bracket" - reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) Nothing + let args = toJSON (doc ^. uri) + reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing request_ WorkspaceExecuteCommand reqParams editReq <- message :: Session ApplyWorkspaceEditRequest @@ -165,169 +162,154 @@ let (Just cs) = editReq ^. params . edit . changes [(u, List es)] = HM.toList cs u `shouldBe` doc ^. uri - es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"] - - noDiagnostics - + es `shouldBe` [TextEdit (Range (Position 0 0) (Position 0 5)) "howdy"] contents <- documentContents doc - liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n" + liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n" describe "getDocumentEdit" $ it "automatically consumes applyedit requests" $ - runSession "hie" fullCaps "test/data/refactor" $ do + runSession serverExe fullCaps "test/data/refactor" $ do doc <- openDoc "Main.hs" "haskell" - let args = toJSON $ AOP (doc ^. uri) - (Position 1 14) - "Redundant bracket" - reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) Nothing + let args = toJSON (doc ^. uri) + reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing request_ WorkspaceExecuteCommand reqParams contents <- getDocumentEdit doc - liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n" - noDiagnostics + liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n" describe "getCodeActions" $ - it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do + it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do doc <- openDoc "Main.hs" "haskell" waitForDiagnostics [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18)) - liftIO $ action ^. title `shouldBe` "Apply hint:Redundant bracket" + liftIO $ action ^. title `shouldBe` "Delete this" describe "getAllCodeActions" $ - it "works" $ runSession "hie" fullCaps "test/data/refactor" $ do + it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do doc <- openDoc "Main.hs" "haskell" _ <- waitForDiagnostics actions <- getAllCodeActions doc liftIO $ do let [CACodeAction action] = actions - action ^. title `shouldBe` "Apply hint:Redundant bracket" - action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne" + action ^. title `shouldBe` "Delete this" + action ^. command . _Just . command `shouldBe` "deleteThis" describe "getDocumentSymbols" $ - it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do + it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do doc <- openDoc "Desktop/simple.hs" "haskell" skipMany loggingNotification - noDiagnostics - Left (mainSymbol:_) <- getDocumentSymbols doc liftIO $ do - mainSymbol ^. name `shouldBe` "main" - mainSymbol ^. kind `shouldBe` SkFunction - mainSymbol ^. range `shouldBe` Range (Position 3 0) (Position 5 30) + mainSymbol ^. name `shouldBe` "foo" + mainSymbol ^. kind `shouldBe` SkObject + mainSymbol ^. range `shouldBe` mkRange 0 0 3 6 describe "applyEdit" $ do - it "increments the version" $ runSession "hie" docChangesCaps "test/data/renamePass" $ do + it "increments the version" $ runSession serverExe docChangesCaps "test/data/renamePass" $ do doc <- openDoc "Desktop/simple.hs" "haskell" VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo" VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit liftIO $ newVersion `shouldBe` oldVersion + 1 - it "changes the document contents" $ runSession "hie" fullCaps "test/data/renamePass" $ do + it "changes the document contents" $ runSession serverExe fullCaps "test/data/renamePass" $ do doc <- openDoc "Desktop/simple.hs" "haskell" let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo" applyEdit doc edit contents <- documentContents doc liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule" - describe "getCompletions" $ - it "works" $ runSession "hie" def "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" + -- describe "getCompletions" $ + -- it "works" $ runSession serverExe def "test/data/renamePass" $ do + -- doc <- openDoc "Desktop/simple.hs" "haskell" - -- wait for module to be loaded - skipMany loggingNotification - noDiagnostics - noDiagnostics + -- -- wait for module to be loaded + -- skipMany loggingNotification + -- noDiagnostics + -- noDiagnostics - comps <- getCompletions doc (Position 5 5) - let item = head (filter (\x -> x ^. label == "interactWithUser") comps) - liftIO $ do - item ^. label `shouldBe` "interactWithUser" - item ^. kind `shouldBe` Just CiFunction - item ^. detail `shouldBe` Just "Items -> IO ()\nMain" + -- comps <- getCompletions doc (Position 5 5) + -- let item = head (filter (\x -> x ^. label == "interactWithUser") comps) + -- liftIO $ do + -- item ^. label `shouldBe` "interactWithUser" + -- item ^. kind `shouldBe` Just CiFunction + -- item ^. detail `shouldBe` Just "Items -> IO ()\nMain" - describe "getReferences" $ - it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" - let pos = Position 40 3 -- interactWithUser - uri = doc ^. LSP.uri - refs <- getReferences doc pos True - liftIO $ refs `shouldContain` map (Location uri) [ - mkRange 41 0 41 16 - , mkRange 75 6 75 22 - , mkRange 71 6 71 22 - ] + -- describe "getReferences" $ + -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do + -- doc <- openDoc "Desktop/simple.hs" "haskell" + -- let pos = Position 40 3 -- interactWithUser + -- uri = doc ^. LSP.uri + -- refs <- getReferences doc pos True + -- liftIO $ refs `shouldContain` map (Location uri) [ + -- mkRange 41 0 41 16 + -- , mkRange 75 6 75 22 + -- , mkRange 71 6 71 22 + -- ] - describe "getDefinitions" $ - it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" - let pos = Position 49 25 -- addItem - defs <- getDefinitions doc pos - liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)] + -- describe "getDefinitions" $ + -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do + -- doc <- openDoc "Desktop/simple.hs" "haskell" + -- let pos = Position 49 25 -- addItem + -- defs <- getDefinitions doc pos + -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)] - describe "getTypeDefinitions" $ - it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" - let pos = Position 20 23 -- Quit value - defs <- getTypeDefinitions doc pos - liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition + -- describe "getTypeDefinitions" $ + -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do + -- doc <- openDoc "Desktop/simple.hs" "haskell" + -- let pos = Position 20 23 -- Quit value + -- defs <- getTypeDefinitions doc pos + -- liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 10 0 14 19)] -- Type definition describe "waitForDiagnosticsSource" $ - it "works" $ runSession "hie" fullCaps "test/data" $ do + it "works" $ runSession serverExe fullCaps "test/data" $ do openDoc "Error.hs" "haskell" - [diag] <- waitForDiagnosticsSource "bios" + [diag] <- waitForDiagnosticsSource "dummy-server" liftIO $ do - diag ^. severity `shouldBe` Just DsError - diag ^. source `shouldBe` Just "bios" - - describe "rename" $ do - it "works" $ pendingWith "HaRe not in hie-bios yet" - it "works on javascript" $ - runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do - doc <- openDoc "test.js" "javascript" - rename doc (Position 2 11) "bar" - documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack + diag ^. severity `shouldBe` Just DsWarning + diag ^. source `shouldBe` Just "dummy-server" - -- runSession "hie" fullCaps "test/data" $ do - -- doc <- openDoc "Rename.hs" "haskell" - -- rename doc (Position 1 0) "bar" - -- documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n" + -- describe "rename" $ do + -- it "works" $ pendingWith "HaRe not in hie-bios yet" + -- it "works on javascript" $ + -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do + -- doc <- openDoc "test.js" "javascript" + -- rename doc (Position 2 11) "bar" + -- documentContents doc >>= liftIO . (`shouldContain` "function bar()") . T.unpack describe "getHover" $ - it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do + it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do doc <- openDoc "Desktop/simple.hs" "haskell" - -- hover returns nothing until module is loaded - skipManyTill loggingNotification $ count 2 noDiagnostics - hover <- getHover doc (Position 45 9) -- putStrLn + hover <- getHover doc (Position 45 9) liftIO $ hover `shouldSatisfy` isJust - describe "getHighlights" $ - it "works" $ runSession "hie" fullCaps "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" - skipManyTill loggingNotification $ count 2 noDiagnostics - highlights <- getHighlights doc (Position 27 4) -- addItem - liftIO $ length highlights `shouldBe` 4 + -- describe "getHighlights" $ + -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do + -- doc <- openDoc "Desktop/simple.hs" "haskell" + -- skipManyTill loggingNotification $ count 2 noDiagnostics + -- highlights <- getHighlights doc (Position 27 4) -- addItem + -- liftIO $ length highlights `shouldBe` 4 - describe "formatDoc" $ - it "works" $ runSession "hie" fullCaps "test/data" $ do - doc <- openDoc "Format.hs" "haskell" - oldContents <- documentContents doc - formatDoc doc (FormattingOptions 4 True) - documentContents doc >>= liftIO . (`shouldNotBe` oldContents) + -- describe "formatDoc" $ + -- it "works" $ runSession serverExe fullCaps "test/data" $ do + -- doc <- openDoc "Format.hs" "haskell" + -- oldContents <- documentContents doc + -- formatDoc doc (FormattingOptions 4 True) + -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents) - describe "formatRange" $ - it "works" $ runSession "hie" fullCaps "test/data" $ do - doc <- openDoc "Format.hs" "haskell" - oldContents <- documentContents doc - formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10)) - documentContents doc >>= liftIO . (`shouldNotBe` oldContents) + -- describe "formatRange" $ + -- it "works" $ runSession serverExe fullCaps "test/data" $ do + -- doc <- openDoc "Format.hs" "haskell" + -- oldContents <- documentContents doc + -- formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10)) + -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents) describe "closeDoc" $ it "works" $ let sesh = - runSession "hie" fullCaps "test/data" $ do + runSession serverExe fullCaps "test/data" $ do doc <- openDoc "Format.hs" "haskell" closeDoc doc -- need to evaluate to throw @@ -335,7 +317,7 @@ in sesh `shouldThrow` anyException describe "satisfy" $ - it "works" $ runSession "hie" fullCaps "test/data" $ do + it "works" $ runSession serverExe fullCaps "test/data" $ do openDoc "Format.hs" "haskell" let pred (NotLogMessage _) = True pred _ = False @@ -343,10 +325,60 @@ describe "ignoreLogNotifications" $ it "works" $ - runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) "hie" fullCaps "test/data" $ do + runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) serverExe fullCaps "test/data" $ do openDoc "Format.hs" "haskell" void publishDiagnosticsNotification + describe "dynamic capabilities" $ do + it "keeps track" $ runSession serverExe fullCaps "test/data" $ do + loggingNotification -- initialized log message + + createDoc ".register" "haskell" "" + message :: Session RegisterCapabilityRequest + + doc <- createDoc "Foo.watch" "haskell" "" + NotLogMessage msg <- loggingNotification + liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles" + + caps <- getRegisteredCapabilities + liftIO $ caps `shouldBe` + [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $ + DidChangeWatchedFilesRegistrationOptions $ List + [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ] + ] + + -- now unregister it by sending a specific createDoc + createDoc ".unregister" "haskell" "" + message :: Session UnregisterCapabilityRequest + + createDoc "Bar.watch" "haskell" "" + void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing + count 0 $ loggingNotification + void $ anyResponse + + it "handles absolute patterns" $ runSession serverExe fullCaps "" $ do + curDir <- liftIO $ getCurrentDirectory + + loggingNotification -- initialized log message + + createDoc ".register.abs" "haskell" "" + message :: Session RegisterCapabilityRequest + + doc <- createDoc (curDir "Foo.watch") "haskell" "" + NotLogMessage msg <- loggingNotification + liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles" + + -- now unregister it by sending a specific createDoc + createDoc ".unregister.abs" "haskell" "" + message :: Session UnregisterCapabilityRequest + + createDoc (curDir "Bar.watch") "haskell" "" + void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing + count 0 $ loggingNotification + void $ anyResponse + + +mkRange :: Int -> Int -> Int -> Int -> Range mkRange sl sc el ec = Range (Position sl sc) (Position el ec) didChangeCaps :: ClientCapabilities @@ -361,8 +393,24 @@ workspaceCaps = def { _workspaceEdit = Just editCaps } editCaps = WorkspaceEditClientCapabilities (Just True) -data ApplyOneParams = AOP - { file :: Uri - , start_pos :: Position - , hintTitle :: String - } deriving (Generic, ToJSON) + +findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath) +findExeRecursive exe dir = do + me <- listToMaybe <$> findExecutablesInDirectories [dir] exe + case me of + Just e -> return (Just e) + Nothing -> do + subdirs <- (fmap (dir )) <$> listDirectory dir >>= filterM doesDirectoryExist + foldM (\acc subdir -> case acc of + Just y -> pure $ Just y + Nothing -> findExeRecursive exe subdir) + Nothing + subdirs + +-- | So we can find the dummy-server with cabal run +-- since it doesnt put build tools on the path (only cabal test) +findServer = do + let serverName = "dummy-server" + e <- findExecutable serverName + e' <- findExeRecursive serverName "dist-newstyle" + pure $ fromJust $ e <|> e' diff --git a/test/dummy-server/Main.hs b/test/dummy-server/Main.hs new file mode 100644 --- /dev/null +++ b/test/dummy-server/Main.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE OverloadedStrings #-} +import Data.Aeson +import Data.Default +import Data.List (isSuffixOf) +import qualified Data.HashMap.Strict as HM +import Language.Haskell.LSP.Core +import Language.Haskell.LSP.Control +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import Control.Concurrent +import Control.Monad +import System.Directory +import System.FilePath + +main = do + lfvar <- newEmptyMVar + let initCbs = InitializeCallbacks + { onInitialConfiguration = const $ Right () + , onConfigurationChange = const $ Right () + , onStartup = \lf -> do + putMVar lfvar lf + + return Nothing + } + options = def + { executeCommandCommands = Just ["doAnEdit"] + } + run initCbs (handlers lfvar) options Nothing + +handlers :: MVar (LspFuncs ()) -> Handlers +handlers lfvar = def + { initializedHandler = pure $ \_ -> send $ NotLogMessage $ fmServerLogMessageNotification MtLog "initialized" + , hoverHandler = pure $ \req -> send $ + RspHover $ makeResponseMessage req (Just (Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing)) + , documentSymbolHandler = pure $ \req -> send $ + RspDocumentSymbols $ makeResponseMessage req $ DSDocumentSymbols $ + List [ DocumentSymbol "foo" + Nothing + SkObject + Nothing + (mkRange 0 0 3 6) + (mkRange 0 0 3 6) + Nothing + ] + , didOpenTextDocumentNotificationHandler = pure $ \noti -> do + let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti + TextDocumentItem uri _ _ _ = doc + Just fp = uriToFilePath uri + diag = Diagnostic (mkRange 0 0 0 1) + (Just DsWarning) + (Just (NumberValue 42)) + (Just "dummy-server") + "Here's a warning" + Nothing + Nothing + when (".hs" `isSuffixOf` fp) $ void $ forkIO $ do + threadDelay (2 * 10^6) + send $ NotPublishDiagnostics $ + fmServerPublishDiagnosticsNotification $ PublishDiagnosticsParams uri $ List [diag] + + -- also act as a registerer for workspace/didChangeWatchedFiles + when (".register" `isSuffixOf` fp) $ do + reqId <- readMVar lfvar >>= getNextReqId + send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $ + RegistrationParams $ List $ + [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $ + DidChangeWatchedFilesRegistrationOptions $ List + [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ] + ] + when (".register.abs" `isSuffixOf` fp) $ do + curDir <- getCurrentDirectory + reqId <- readMVar lfvar >>= getNextReqId + send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $ + RegistrationParams $ List $ + [ Registration "1" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $ + DidChangeWatchedFilesRegistrationOptions $ List + [ FileSystemWatcher (curDir "*.watch") (Just (WatchKind True True True)) ] + ] + + -- also act as an unregisterer for workspace/didChangeWatchedFiles + when (".unregister" `isSuffixOf` fp) $ do + reqId <- readMVar lfvar >>= getNextReqId + send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $ + UnregistrationParams $ List [ Unregistration "0" "workspace/didChangeWatchedFiles" ] + when (".unregister.abs" `isSuffixOf` fp) $ do + reqId <- readMVar lfvar >>= getNextReqId + send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $ + UnregistrationParams $ List [ Unregistration "1" "workspace/didChangeWatchedFiles" ] + , executeCommandHandler = pure $ \req -> do + send $ RspExecuteCommand $ makeResponseMessage req Null + reqId <- readMVar lfvar >>= getNextReqId + let RequestMessage _ _ _ (ExecuteCommandParams "doAnEdit" (Just (List [val])) _) = req + Success docUri = fromJSON val + edit = List [TextEdit (mkRange 0 0 0 5) "howdy"] + send $ ReqApplyWorkspaceEdit $ fmServerApplyWorkspaceEditRequest reqId $ + ApplyWorkspaceEditParams $ WorkspaceEdit (Just (HM.singleton docUri edit)) + Nothing + , codeActionHandler = pure $ \req -> do + let RequestMessage _ _ _ params = req + CodeActionParams _ _ cactx _ = params + CodeActionContext diags _ = cactx + caresults = fmap diag2caresult diags + diag2caresult d = CACodeAction $ + CodeAction "Delete this" + Nothing + (Just (List [d])) + Nothing + (Just (Command "" "deleteThis" Nothing)) + send $ RspCodeAction $ makeResponseMessage req caresults + , didChangeWatchedFilesNotificationHandler = pure $ \_ -> + send $ NotLogMessage $ fmServerLogMessageNotification MtLog "got workspace/didChangeWatchedFiles" + } + where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg + +mkRange sl sc el ec = Range (Position sl sc) (Position el ec)