diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for lsp-test +## 0.13.0.0 -- 2021-03-26 + +* Update for lsp-types-1.2 (@wz1000) +* Limit diagnostics by range in getCodeActions (@aufarg) +* Kill timeout thread to avoid building up thousands of old TimeoutMessages (@wz1000) + ## 0.13.0.0 -- 2021-02-14 * Add support for lsp-types-1.1 (@wz1000) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,11 @@ -# 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 + lsp-test is a functional testing framework for Language Server Protocol servers. +It is part of the [lsp](https://github.com/haskell/lsp) family of +packages, along with [lsp](https://hackage.haskell.org/package/lsp) +and [lsp-types](https://hackage.haskell.org/package/lsp-types) + ```haskell import Language.LSP.Test main = runSession "hie" fullCaps "proj/dir" $ do @@ -35,7 +40,7 @@ ``` 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), or see this [introductory blog post](https://lukelau.me/haskell/posts/lsp-test/). +For more examples see this [introductory blog post](https://lukelau.me/haskell/posts/lsp-test/). 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. diff --git a/bench/SimpleBench.hs b/bench/SimpleBench.hs new file mode 100644 --- /dev/null +++ b/bench/SimpleBench.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs, OverloadedStrings #-} +module Main where + +import Language.LSP.Server +import qualified Language.LSP.Test as Test +import Language.LSP.Types +import Control.Monad.IO.Class +import Control.Monad +import System.Process +import System.Environment +import System.Time.Extra +import Control.Concurrent +import Data.IORef + +handlers :: Handlers (LspM ()) +handlers = mconcat + [ requestHandler STextDocumentHover $ \req responder -> do + let RequestMessage _ _ _ (HoverParams _doc pos _workDone) = req + Position _l _c' = pos + rsp = Hover ms (Just range) + ms = HoverContents $ markedUpContent "lsp-demo-simple-server" "Hello world" + range = Range pos pos + responder (Right $ Just rsp) + , requestHandler STextDocumentDefinition $ \req responder -> do + let RequestMessage _ _ _ (DefinitionParams (TextDocumentIdentifier doc) pos _ _) = req + responder (Right $ InL $ Location doc $ Range pos pos) + ] + +server :: ServerDefinition () +server = ServerDefinition + { onConfigurationChange = const $ const $ Right () + , defaultConfig = () + , doInitialize = \env _req -> pure $ Right env + , staticHandlers = handlers + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = defaultOptions + } + +main :: IO () +main = do + (hinRead, hinWrite) <- createPipe + (houtRead, houtWrite) <- createPipe + + n <- read . head <$> getArgs + + forkIO $ void $ runServerWithHandles hinRead houtWrite server + liftIO $ putStrLn $ "Starting " <> show n <> " rounds" + + i <- newIORef 0 + + Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do + start <- liftIO offsetTime + replicateM_ n $ do + n <- liftIO $ readIORef i + liftIO $ when (n `mod` 1000 == 0) $ putStrLn $ show n + ResponseMessage{_result=Right (Just _)} <- Test.request STextDocumentHover $ + HoverParams (TextDocumentIdentifier $ Uri "test") (Position 1 100) Nothing + ResponseMessage{_result=Right (InL _)} <- Test.request STextDocumentDefinition $ + DefinitionParams (TextDocumentIdentifier $ Uri "test") (Position 1000 100) Nothing Nothing + + liftIO $ modifyIORef' i (+1) + pure () + end <- liftIO start + liftIO $ putStrLn $ "Completed " <> show n <> " rounds in " <> showDuration end + diff --git a/example/Test.hs b/example/Test.hs new file mode 100644 --- /dev/null +++ b/example/Test.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} +import Control.Applicative.Combinators +import Control.Monad.IO.Class +import Language.LSP.Test +import Language.LSP.Types + +main = runSession "lsp-demo-reactor-server" fullCaps "test/data/" $ do + doc <- openDoc "Rename.hs" "haskell" + + -- Use your favourite favourite combinators. + skipManyTill loggingNotification (count 1 publishDiagnosticsNotification) + + -- Send requests and notifications and receive responses + rsp <- request STextDocumentDocumentSymbol $ + DocumentSymbolParams Nothing Nothing doc + liftIO $ print rsp + + -- Or use one of the helper functions + getDocumentSymbols doc >>= liftIO . print + diff --git a/func-test/FuncTest.hs b/func-test/FuncTest.hs new file mode 100644 --- /dev/null +++ b/func-test/FuncTest.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs, OverloadedStrings #-} +module Main where + +import Language.LSP.Server +import qualified Language.LSP.Test as Test +import Language.LSP.Types +import Language.LSP.Types.Lens hiding (options) +import Control.Monad.IO.Class +import System.IO +import Control.Monad +import System.Process +import Control.Applicative.Combinators +import Control.Lens hiding (List, Iso) +import Test.Hspec +import Data.Maybe +import UnliftIO +import UnliftIO.Concurrent +import Control.Exception +import System.Exit + +main :: IO () +main = hspec $ do + describe "progress reporting" $ + it "sends end notification if thread is killed" $ do + (hinRead, hinWrite) <- createPipe + (houtRead, houtWrite) <- createPipe + + killVar <- newEmptyMVar + + let definition = ServerDefinition + { onConfigurationChange = const $ const $ Right () + , defaultConfig = () + , doInitialize = \env _req -> pure $ Right env + , staticHandlers = handlers killVar + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = defaultOptions + } + + handlers :: MVar () -> Handlers (LspM ()) + handlers killVar = + notificationHandler SInitialized $ \noti -> do + tid <- withRunInIO $ \runInIO -> + forkIO $ runInIO $ + withProgress "Doing something" NotCancellable $ \updater -> + liftIO $ threadDelay (1 * 1000000) + liftIO $ void $ forkIO $ do + takeMVar killVar + killThread tid + + forkIO $ void $ runServerWithHandles hinRead houtWrite definition + + Test.runSessionWithHandles hinWrite houtRead Test.defaultConfig Test.fullCaps "." $ do + -- First make sure that we get a $/progress begin notification + skipManyTill Test.anyMessage $ do + x <- Test.message SProgress + let isBegin (Begin _) = True + isBegin _ = False + guard $ isBegin $ x ^. params . value + + -- Then kill the thread + liftIO $ putMVar killVar () + + -- Then make sure we still get a $/progress end notification + skipManyTill Test.anyMessage $ do + x <- Test.message SProgress + let isEnd (End _) = True + isEnd _ = False + guard $ isEnd $ x ^. params . value + + describe "workspace folders" $ + it "keeps track of open workspace folders" $ do + (hinRead, hinWrite) <- createPipe + (houtRead, houtWrite) <- createPipe + + countVar <- newMVar 0 + + let wf0 = WorkspaceFolder "one" "Starter workspace" + wf1 = WorkspaceFolder "/foo/bar" "My workspace" + wf2 = WorkspaceFolder "/foo/baz" "My other workspace" + + definition = ServerDefinition + { onConfigurationChange = const $ const $ Right () + , defaultConfig = () + , doInitialize = \env _req -> pure $ Right env + , staticHandlers = handlers + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = defaultOptions + } + + handlers :: Handlers (LspM ()) + handlers = mconcat + [ notificationHandler SInitialized $ \noti -> do + wfs <- fromJust <$> getWorkspaceFolders + liftIO $ wfs `shouldContain` [wf0] + , notificationHandler SWorkspaceDidChangeWorkspaceFolders $ \noti -> do + i <- liftIO $ modifyMVar countVar (\i -> pure (i + 1, i)) + wfs <- fromJust <$> getWorkspaceFolders + liftIO $ case i of + 0 -> do + wfs `shouldContain` [wf1] + wfs `shouldContain` [wf0] + 1 -> do + wfs `shouldNotContain` [wf1] + wfs `shouldContain` [wf0] + wfs `shouldContain` [wf2] + _ -> error "Shouldn't be here" + ] + + + server <- async $ void $ runServerWithHandles hinRead houtWrite definition + + let config = Test.defaultConfig + { Test.initialWorkspaceFolders = Just [wf0] + } + + changeFolders add rmv = + let addedFolders = List add + removedFolders = List rmv + ev = WorkspaceFoldersChangeEvent addedFolders removedFolders + ps = DidChangeWorkspaceFoldersParams ev + in Test.sendNotification SWorkspaceDidChangeWorkspaceFolders ps + + Test.runSessionWithHandles hinWrite houtRead config Test.fullCaps "." $ do + changeFolders [wf1] [] + changeFolders [wf2] [wf1] + + Left e <- waitCatch server + fromException e `shouldBe` Just ExitSuccess + diff --git a/lsp-test.cabal b/lsp-test.cabal --- a/lsp-test.cabal +++ b/lsp-test.cabal @@ -1,21 +1,20 @@ name: lsp-test -version: 0.13.0.0 +version: 0.14.0.0 synopsis: Functional test framework for LSP servers. description: A test framework for writing tests against . @Language.LSP.Test@ launches your server as a subprocess and allows you to simulate a session - down to the wire, and @Language.LSP.Test@ can replay captured sessions from - . + down to the wire. To see examples of it in action, check out , and . -homepage: https://github.com/bubba/lsp-test#readme +homepage: https://github.com/haskell/lsp/blob/master/lsp-test/README.md license: BSD3 license-file: LICENSE author: Luke Lau maintainer: luke_lau@icloud.com -bug-reports: https://github.com/bubba/lsp-test/issues +bug-reports: https://github.com/haskell/lsp/issues copyright: 2021 Luke Lau category: Testing build-type: Simple @@ -26,12 +25,7 @@ source-repository head type: git - location: https://github.com/bubba/lsp-test/ - -Flag DummyServer - Description: Build the dummy server executable used in testing - Default: False - Manual: True + location: https://github.com/haskell/lsp library hs-source-dirs: src @@ -41,7 +35,7 @@ , parser-combinators:Control.Applicative.Combinators default-language: Haskell2010 build-depends: base >= 4.10 && < 5 - , lsp-types == 1.1.* + , lsp-types == 1.2.* , aeson , time , aeson-pretty @@ -77,32 +71,16 @@ Language.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.11 && < 5 - , lsp == 1.1.* - , aeson - , unordered-containers - , directory - , filepath - , unliftio - , mtl - default-language: Haskell2010 - scope: private - if !flag(DummyServer) - buildable: False - test-suite tests type: exitcode-stdio-1.0 main-is: Test.hs + other-modules: DummyServer hs-source-dirs: test ghc-options: -W build-depends: base >= 4.10 && < 5 , hspec , lens - , lsp-types == 1.1.* + , lsp == 1.2.* , lsp-test , data-default , aeson @@ -110,5 +88,45 @@ , text , directory , filepath + , unliftio + , process + , mtl + , aeson default-language: Haskell2010 - build-tool-depends: lsp-test:dummy-server + +test-suite func-test + main-is: FuncTest.hs + hs-source-dirs: func-test + type: exitcode-stdio-1.0 + build-depends: base <4.15 + , lsp-test + , lsp + , data-default + , process + , lens + , unliftio + , hspec + , async + default-language: Haskell2010 + +test-suite example + main-is: Test.hs + hs-source-dirs: example + type: exitcode-stdio-1.0 + default-language: Haskell2010 + build-depends: base + , lsp-test + , parser-combinators + build-tool-depends: lsp:lsp-demo-reactor-server + +benchmark simple-bench + main-is: SimpleBench.hs + hs-source-dirs: bench + type: exitcode-stdio-1.0 + build-depends: base <4.15 + , lsp-test + , lsp + , process + , extra + default-language: Haskell2010 + ghc-options: -Wall -O2 -eventlog -rtsopts diff --git a/src/Language/LSP/Test.hs b/src/Language/LSP/Test.hs --- 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 @@ -- | 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 @@ 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 @@ -583,16 +604,16 @@ let supportsDocChanges = fromMaybe False $ do let mWorkspace = caps ^. LSP.workspace C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace - C.WorkspaceEditClientCapabilities mDocChanges _ _ <- mEdit + C.WorkspaceEditClientCapabilities mDocChanges _ _ _ _ <- mEdit mDocChanges let wEdit = if supportsDocChanges then - let docEdit = TextDocumentEdit verDoc (List [edit]) - in WorkspaceEdit Nothing (Just (List [InL docEdit])) + let docEdit = TextDocumentEdit verDoc (List [InL edit]) + in WorkspaceEdit Nothing (Just (List [InL docEdit])) Nothing else let changes = HashMap.singleton (doc ^. uri) (List [edit]) - in WorkspaceEdit (Just changes) Nothing + in WorkspaceEdit (Just changes) Nothing Nothing let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) updateState (FromServerMess SWorkspaceApplyEdit req) @@ -707,7 +728,7 @@ applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session () applyTextEdits doc edits = - let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing + let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing Nothing -- Send a dummy message to updateState so it can do bookkeeping req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit) in updateState (FromServerMess SWorkspaceApplyEdit req) diff --git a/src/Language/LSP/Test/Files.hs b/src/Language/LSP/Test/Files.hs --- a/src/Language/LSP/Test/Files.hs +++ b/src/Language/LSP/Test/Files.hs @@ -84,7 +84,7 @@ newDocChanges = fmap (fmap swapDocumentChangeUri) $ e ^. documentChanges newChanges = fmap (swapKeys f) $ e ^. changes - in WorkspaceEdit newChanges newDocChanges + in WorkspaceEdit newChanges newDocChanges Nothing swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b swapKeys f = HM.foldlWithKey' (\acc k v -> HM.insert (f k) v acc) HM.empty diff --git a/src/Language/LSP/Test/Parsing.hs b/src/Language/LSP/Test/Parsing.hs --- a/src/Language/LSP/Test/Parsing.hs +++ b/src/Language/LSP/Test/Parsing.hs @@ -83,16 +83,21 @@ skipTimeout <- overridingTimeout <$> get timeoutId <- getCurTimeoutId - unless skipTimeout $ do - chan <- asks messageChan - timeout <- asks (messageTimeout . config) - void $ liftIO $ forkIO $ do - threadDelay (timeout * 1000000) - writeChan chan (TimeoutMessage timeoutId) + mtid <- + if skipTimeout + then pure Nothing + else Just <$> do + chan <- asks messageChan + timeout <- asks (messageTimeout . config) + 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 } @@ -109,11 +114,15 @@ -- | Matches a request or a notification coming from the server. +-- Doesn't match Custom Messages message :: SServerMethod m -> Session (ServerMessage m) +message (SCustomMethod _) = error "message can't be used with CustomMethod, use customRequest or customNotification instead" message m1 = named (T.pack $ "Request for: " <> show m1) $ satisfyMaybe $ \case FromServerMess m2 msg -> do - HRefl <- mEqServer m1 m2 - pure msg + res <- mEqServer m1 m2 + case res of + Right HRefl -> pure msg + Left _f -> Nothing _ -> Nothing customRequest :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Request)) @@ -163,7 +172,7 @@ response :: SMethod (m :: Method FromClient Request) -> Session (ResponseMessage m) response m1 = named (T.pack $ "Response for: " <> show m1) $ satisfyMaybe $ \case FromServerRsp m2 msg -> do - HRefl <- mEqClient m1 m2 + HRefl <- runEq mEqClient m1 m2 pure msg _ -> Nothing @@ -173,17 +182,10 @@ satisfyMaybe $ \msg -> do case msg of FromServerMess _ _ -> Nothing - FromServerRsp m' rspMsg@(ResponseMessage _ lid' _) -> - case mEqClient m m' of - Just HRefl -> do - guard (lid' == Just lid) - pure rspMsg - Nothing - | SCustomMethod tm <- m - , SCustomMethod tm' <- m' - , tm == tm' - , lid' == Just lid -> pure rspMsg - _ -> empty + FromServerRsp m' rspMsg@(ResponseMessage _ lid' _) -> do + HRefl <- runEq mEqClient m m' + guard (Just lid == lid') + pure rspMsg -- | Matches any type of message. anyMessage :: Session FromServerMessage diff --git a/src/Language/LSP/Test/Session.hs b/src/Language/LSP/Test/Session.hs --- 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 #-} @@ -7,6 +8,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} module Language.LSP.Test.Session ( Session(..) @@ -37,7 +39,7 @@ import Control.Applicative import Control.Concurrent hiding (yield) import Control.Exception -import Control.Lens hiding (List) +import Control.Lens hiding (List, Empty) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Except @@ -56,7 +58,7 @@ 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 +81,7 @@ 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 +138,7 @@ , 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 +157,7 @@ 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 +165,21 @@ 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 +264,7 @@ reqMap <- newMVar newRequestMap messageChan <- newChan - timeoutIdVar <- newMVar 0 + timeoutIdVar <- newIORef 0 initRsp <- newEmptyMVar mainThreadId <- myThreadId @@ -302,7 +305,7 @@ where respond :: (MonadIO m, HasReader SessionContext m) => FromServerMessage -> m () respond (FromServerMess SWindowWorkDoneProgressCreate req) = - sendMessage $ ResponseMessage "2.0" (Just $ req ^. LSP.id) (Right ()) + sendMessage $ ResponseMessage "2.0" (Just $ req ^. LSP.id) (Right Empty) respond (FromServerMess SWorkspaceApplyEdit r) = do sendMessage $ ResponseMessage "2.0" (Just $ r ^. LSP.id) (Right $ ApplyWorkspaceEditResponseBody True Nothing) respond _ = pure () @@ -398,10 +401,13 @@ return $ s { vfs = newVFS } getParamsFromTextDocumentEdit :: TextDocumentEdit -> DidChangeTextDocumentParams - getParamsFromTextDocumentEdit (TextDocumentEdit docId (List edits)) = - let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits - in DidChangeTextDocumentParams docId (List changeEvents) + getParamsFromTextDocumentEdit (TextDocumentEdit docId (List edits)) = + DidChangeTextDocumentParams docId (List $ map editToChangeEvent edits) + editToChangeEvent :: TextEdit |? AnnotatedTextEdit -> TextDocumentContentChangeEvent + editToChangeEvent (InR e) = TextDocumentContentChangeEvent (Just $ e ^. range) Nothing (e ^. newText) + editToChangeEvent (InL e) = TextDocumentContentChangeEvent (Just $ e ^. range) Nothing (e ^. newText) + getParamsFromDocumentChange :: DocumentChange -> Maybe DidChangeTextDocumentParams getParamsFromDocumentChange (InL textDocumentEdit) = Just $ getParamsFromTextDocumentEdit textDocumentEdit getParamsFromDocumentChange _ = Nothing @@ -417,7 +423,7 @@ textDocumentEdits uri edits = do vers <- textDocumentVersions uri - pure $ map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip vers edits + pure $ map (\(v, e) -> TextDocumentEdit v (List [InL e])) $ zip vers edits getChangeParams uri (List edits) = do map <$> pure getParamsFromTextDocumentEdit <*> textDocumentEdits uri (reverse edits) @@ -441,10 +447,11 @@ 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/DummyServer.hs b/test/DummyServer.hs new file mode 100644 --- /dev/null +++ b/test/DummyServer.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE OverloadedStrings #-} +module DummyServer where + +import Control.Monad +import Control.Monad.Reader +import Data.Aeson hiding (defaultOptions) +import qualified Data.HashMap.Strict as HM +import Data.List (isSuffixOf) +import Data.String +import UnliftIO.Concurrent +import Language.LSP.Server +import System.IO +import UnliftIO +import System.Directory +import System.FilePath +import System.Process +import Language.LSP.Types + +withDummyServer :: ((Handle, Handle) -> IO ()) -> IO () +withDummyServer f = do + (hinRead, hinWrite) <- createPipe + (houtRead, houtWrite) <- createPipe + + handlerEnv <- HandlerEnv <$> newEmptyMVar <*> newEmptyMVar + let definition = ServerDefinition + { doInitialize = \env _req -> pure $ Right env + , defaultConfig = () + , onConfigurationChange = const $ pure $ Right () + , staticHandlers = handlers + , interpretHandler = \env -> + Iso (\m -> runLspT env (runReaderT m handlerEnv)) liftIO + , options = defaultOptions {executeCommandCommands = Just ["doAnEdit"]} + } + + bracket + (forkIO $ void $ runServerWithHandles hinRead houtWrite definition) + killThread + (const $ f (hinWrite, houtRead)) + + +data HandlerEnv = HandlerEnv + { relRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles) + , absRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles) + } + +handlers :: Handlers (ReaderT HandlerEnv (LspM ())) +handlers = + mconcat + [ notificationHandler SInitialized $ + \_noti -> + sendNotification SWindowLogMessage $ + LogMessageParams MtLog "initialized" + , requestHandler STextDocumentHover $ + \_req responder -> + responder $ + Right $ + Just $ + Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing + , requestHandler STextDocumentDocumentSymbol $ + \_req responder -> + responder $ + Right $ + InL $ + List + [ DocumentSymbol + "foo" + Nothing + SkObject + Nothing + Nothing + (mkRange 0 0 3 6) + (mkRange 0 0 3 6) + Nothing + ] + , notificationHandler STextDocumentDidOpen $ + \noti -> do + let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti + TextDocumentItem uri _ _ _ = doc + Just fp = uriToFilePath uri + diag = + Diagnostic + (mkRange 0 0 0 1) + (Just DsWarning) + (Just (InL 42)) + (Just "dummy-server") + "Here's a warning" + Nothing + Nothing + withRunInIO $ + \runInIO -> do + when (".hs" `isSuffixOf` fp) $ + void $ + forkIO $ + do + threadDelay (2 * 10 ^ 6) + runInIO $ + sendNotification STextDocumentPublishDiagnostics $ + PublishDiagnosticsParams uri Nothing (List [diag]) + -- also act as a registerer for workspace/didChangeWatchedFiles + when (".register" `isSuffixOf` fp) $ + do + let regOpts = + DidChangeWatchedFilesRegistrationOptions $ + List + [ FileSystemWatcher + "*.watch" + (Just (WatchKind True True True)) + ] + Just token <- runInIO $ + registerCapability SWorkspaceDidChangeWatchedFiles regOpts $ + \_noti -> + sendNotification SWindowLogMessage $ + LogMessageParams MtLog "got workspace/didChangeWatchedFiles" + runInIO $ asks relRegToken >>= \v -> putMVar v token + when (".register.abs" `isSuffixOf` fp) $ + do + curDir <- getCurrentDirectory + let regOpts = + DidChangeWatchedFilesRegistrationOptions $ + List + [ FileSystemWatcher + (fromString $ curDir "*.watch") + (Just (WatchKind True True True)) + ] + Just token <- runInIO $ + registerCapability SWorkspaceDidChangeWatchedFiles regOpts $ + \_noti -> + sendNotification SWindowLogMessage $ + LogMessageParams MtLog "got workspace/didChangeWatchedFiles" + runInIO $ asks absRegToken >>= \v -> putMVar v token + -- also act as an unregisterer for workspace/didChangeWatchedFiles + when (".unregister" `isSuffixOf` fp) $ + do + Just token <- runInIO $ asks relRegToken >>= tryReadMVar + runInIO $ unregisterCapability token + when (".unregister.abs" `isSuffixOf` fp) $ + do + Just token <- runInIO $ asks absRegToken >>= tryReadMVar + runInIO $ unregisterCapability token + , requestHandler SWorkspaceExecuteCommand $ \req resp -> do + let RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just (List [val]))) = req + Success docUri = fromJSON val + edit = List [TextEdit (mkRange 0 0 0 5) "howdy"] + params = + ApplyWorkspaceEditParams (Just "Howdy edit") $ + WorkspaceEdit (Just (HM.singleton docUri edit)) Nothing Nothing + resp $ Right Null + void $ sendRequest SWorkspaceApplyEdit params (const (pure ())) + , requestHandler STextDocumentCodeAction $ \req resp -> do + let RequestMessage _ _ _ params = req + CodeActionParams _ _ _ _ cactx = params + CodeActionContext diags _ = cactx + codeActions = fmap diag2ca diags + diag2ca d = + CodeAction + "Delete this" + Nothing + (Just (List [d])) + Nothing + Nothing + Nothing + (Just (Command "" "deleteThis" Nothing)) + Nothing + resp $ Right $ InR <$> codeActions + , requestHandler STextDocumentCompletion $ \_req resp -> do + let res = CompletionList True (List [item]) + item = + CompletionItem + "foo" + (Just CiConstant) + (Just (List [])) + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + resp $ Right $ InR res + ] diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -5,6 +5,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} +import DummyServer import Test.Hspec import Data.Aeson import Data.Default @@ -12,11 +13,12 @@ import Data.Either import Data.Maybe import qualified Data.Text as T +import Data.Type.Equality import Control.Applicative.Combinators import Control.Concurrent import Control.Monad.IO.Class import Control.Monad -import Control.Lens hiding (List) +import Control.Lens hiding (List, Iso) import Language.LSP.Test import Language.LSP.Types import Language.LSP.Types.Lens hiding @@ -26,30 +28,30 @@ import System.Directory import System.FilePath import System.Timeout -import Data.Type.Equality + {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} {-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-} -main = findServer >>= \serverExe -> hspec $ do +main = hspec $ around withDummyServer $ do describe "Session" $ do - it "fails a test" $ do - let session = runSession serverExe fullCaps "test/data/renamePass" $ do - openDoc "Desktop/simple.hs" "haskell" + it "fails a test" $ \(hin, hout) -> + let session = runSessionWithHandles hin hout def fullCaps "." $ do + openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" anyRequest in session `shouldThrow` anySessionException - it "initializeResponse" $ runSession serverExe fullCaps "test/data/renamePass" $ do + it "initializeResponse" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do rsp <- initializeResponse liftIO $ rsp ^. result `shouldSatisfy` isRight - it "runSessionWithConfig" $ - runSession serverExe didChangeCaps "test/data/renamePass" $ return () + it "runSessionWithConfig" $ \(hin, hout) -> + runSessionWithHandles hin hout def didChangeCaps "." $ return () describe "withTimeout" $ do - it "times out" $ - let sesh = runSession serverExe fullCaps "test/data/renamePass" $ do - openDoc "Desktop/simple.hs" "haskell" + it "times out" $ \(hin, hout) -> + let sesh = runSessionWithHandles hin hout def fullCaps "." $ do + openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" -- won't receive a request - will timeout -- incoming logging requests shouldn't increase the -- timeout @@ -58,36 +60,37 @@ -- to open the document in timeout 6000000 sesh `shouldThrow` anySessionException - it "doesn't time out" $ - let sesh = runSession serverExe fullCaps "test/data/renamePass" $ do - openDoc "Desktop/simple.hs" "haskell" + it "doesn't time out" $ \(hin, hout) -> + let sesh = runSessionWithHandles hin hout def fullCaps "." $ do + openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification in void $ timeout 6000000 sesh - it "further timeout messages are ignored" $ runSession serverExe fullCaps "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" - -- shouldn't timeout - withTimeout 3 $ getDocumentSymbols doc - -- longer than the original timeout - liftIO $ threadDelay (5 * 10^6) - -- shouldn't throw an exception - getDocumentSymbols doc - return () + it "further timeout messages are ignored" $ \(hin, hout) -> + runSessionWithHandles hin hout def fullCaps "." $ do + doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" + -- shouldn't timeout + withTimeout 3 $ getDocumentSymbols doc + -- longer than the original timeout + liftIO $ threadDelay (5 * 10^6) + -- shouldn't throw an exception + getDocumentSymbols doc + return () - it "overrides global message timeout" $ + it "overrides global message timeout" $ \(hin, hout) -> let sesh = - runSessionWithConfig (def { messageTimeout = 5 }) serverExe fullCaps "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" + runSessionWithHandles hin hout (def { messageTimeout = 5 }) fullCaps "." $ do + doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" -- shouldn't time out in here since we are overriding it withTimeout 10 $ liftIO $ threadDelay 7000000 getDocumentSymbols doc return True in sesh `shouldReturn` True - it "unoverrides global message timeout" $ + it "unoverrides global message timeout" $ \(hin, hout) -> let sesh = - runSessionWithConfig (def { messageTimeout = 5 }) serverExe fullCaps "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" + runSessionWithHandles hin hout (def { messageTimeout = 5 }) fullCaps "." $ do + doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" -- shouldn't time out in here since we are overriding it withTimeout 10 $ liftIO $ threadDelay 7000000 getDocumentSymbols doc @@ -99,39 +102,40 @@ describe "SessionException" $ do - it "throw on time out" $ - let sesh = runSessionWithConfig (def {messageTimeout = 10}) serverExe fullCaps "test/data/renamePass" $ do + it "throw on time out" $ \(hin, hout) -> + let sesh = runSessionWithHandles hin hout (def {messageTimeout = 10}) fullCaps "." $ do skipMany loggingNotification _ <- message SWorkspaceApplyEdit return () in sesh `shouldThrow` anySessionException - it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) serverExe fullCaps "test/data/renamePass" $ do - loggingNotification - liftIO $ threadDelay $ 6 * 1000000 - _ <- openDoc "Desktop/simple.hs" "haskell" - return () + it "don't throw when no time out" $ \(hin, hout) -> + runSessionWithHandles hin hout (def {messageTimeout = 5}) fullCaps "." $ do + loggingNotification + liftIO $ threadDelay $ 6 * 1000000 + _ <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" + return () describe "UnexpectedMessageException" $ do - it "throws when there's an unexpected message" $ + it "throws when there's an unexpected message" $ \(hin, hout) -> let selector (UnexpectedMessage "Publish diagnostics notification" (FromServerMess SWindowLogMessage _)) = True 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 + in runSessionWithHandles hin hout def fullCaps "." publishDiagnosticsNotification `shouldThrow` selector + it "provides the correct types that were expected and received" $ \(hin, hout) -> + let selector (UnexpectedMessage "Response for: STextDocumentRename" (FromServerRsp STextDocumentDocumentSymbol _)) = True selector _ = False sesh = do - doc <- openDoc "Desktop/simple.hs" "haskell" + doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" sendRequest STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc) skipMany anyNotification response STextDocumentRename -- the wrong type - in runSession serverExe fullCaps "test/data/renamePass" sesh + in runSessionWithHandles hin hout def fullCaps "." sesh `shouldThrow` selector describe "text document VFS" $ - it "sends back didChange notifications" $ - runSession serverExe def "test/data/refactor" $ do - doc <- openDoc "Main.hs" "haskell" + it "sends back didChange notifications" $ \(hin, hout) -> + runSessionWithHandles hin hout def fullCaps "." $ do + doc <- openDoc "test/data/refactor/Main.hs" "haskell" let args = toJSON (doc ^. uri) reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args])) @@ -147,9 +151,9 @@ liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n" describe "getDocumentEdit" $ - it "automatically consumes applyedit requests" $ - runSession serverExe fullCaps "test/data/refactor" $ do - doc <- openDoc "Main.hs" "haskell" + it "automatically consumes applyedit requests" $ \(hin, hout) -> + runSessionWithHandles hin hout def fullCaps "." $ do + doc <- openDoc "test/data/refactor/Main.hs" "haskell" let args = toJSON (doc ^. uri) reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args])) @@ -158,15 +162,17 @@ liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n" describe "getCodeActions" $ - it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do - doc <- openDoc "Main.hs" "haskell" + it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + doc <- openDoc "test/data/refactor/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 - doc <- openDoc "Main.hs" "haskell" + it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + doc <- openDoc "test/data/refactor/Main.hs" "haskell" _ <- waitForDiagnostics actions <- getAllCodeActions doc liftIO $ do @@ -175,8 +181,8 @@ action ^. command . _Just . command `shouldBe` "deleteThis" describe "getDocumentSymbols" $ - it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" + it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" skipMany loggingNotification @@ -188,30 +194,30 @@ mainSymbol ^. range `shouldBe` mkRange 0 0 3 6 describe "applyEdit" $ do - it "increments the version" $ runSession serverExe docChangesCaps "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" + it "increments the version" $ \(hin, hout) -> runSessionWithHandles hin hout def docChangesCaps "." $ do + doc <- openDoc "test/data/renamePass/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 serverExe fullCaps "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" + it "changes the document contents" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + doc <- openDoc "test/data/renamePass/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 serverExe def "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" + it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" comps <- getCompletions doc (Position 5 5) let item = head comps liftIO $ item ^. label `shouldBe` "foo" -- describe "getReferences" $ - -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do - -- doc <- openDoc "Desktop/simple.hs" "haskell" + -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + -- doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" -- let pos = Position 40 3 -- interactWithUser -- uri = doc ^. LSP.uri -- refs <- getReferences doc pos True @@ -222,88 +228,88 @@ -- ] -- describe "getDefinitions" $ - -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do - -- doc <- openDoc "Desktop/simple.hs" "haskell" + -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + -- doc <- openDoc "test/data/renamePass/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 serverExe fullCaps "test/data/renamePass" $ do - -- doc <- openDoc "Desktop/simple.hs" "haskell" + -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + -- doc <- openDoc "test/data/renamePass/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 serverExe fullCaps "test/data" $ do - openDoc "Error.hs" "haskell" + it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + openDoc "test/data/Error.hs" "haskell" [diag] <- waitForDiagnosticsSource "dummy-server" liftIO $ do diag ^. severity `shouldBe` Just DsWarning diag ^. source `shouldBe` Just "dummy-server" -- describe "rename" $ do - -- it "works" $ pendingWith "HaRe not in hie-bios yet" + -- it "works" $ \(hin, hout) -> pendingWith "HaRe not in hie-bios yet" -- it "works on javascript" $ - -- runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do + -- runSessionWithHandles hin hout "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 serverExe fullCaps "test/data/renamePass" $ do - doc <- openDoc "Desktop/simple.hs" "haskell" + it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + doc <- openDoc "test/data/renamePass/Desktop/simple.hs" "haskell" hover <- getHover doc (Position 45 9) liftIO $ hover `shouldSatisfy` isJust -- describe "getHighlights" $ - -- it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do - -- doc <- openDoc "Desktop/simple.hs" "haskell" + -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + -- doc <- openDoc "test/data/renamePass/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 serverExe fullCaps "test/data" $ do - -- doc <- openDoc "Format.hs" "haskell" + -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + -- doc <- openDoc "test/data/Format.hs" "haskell" -- oldContents <- documentContents doc -- formatDoc doc (FormattingOptions 4 True) -- documentContents doc >>= liftIO . (`shouldNotBe` oldContents) -- describe "formatRange" $ - -- it "works" $ runSession serverExe fullCaps "test/data" $ do - -- doc <- openDoc "Format.hs" "haskell" + -- it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + -- doc <- openDoc "test/data/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" $ + it "works" $ \(hin, hout) -> let sesh = - runSession serverExe fullCaps "test/data" $ do - doc <- openDoc "Format.hs" "haskell" + runSessionWithHandles hin hout def fullCaps "." $ do + doc <- openDoc "test/data/Format.hs" "haskell" closeDoc doc -- need to evaluate to throw documentContents doc >>= liftIO . print in sesh `shouldThrow` anyException describe "satisfy" $ - it "works" $ runSession serverExe fullCaps "test/data" $ do - openDoc "Format.hs" "haskell" + it "works" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do + openDoc "test/data/Format.hs" "haskell" let pred (FromServerMess SWindowLogMessage _) = True pred _ = False void $ satisfy pred describe "ignoreLogNotifications" $ - it "works" $ - runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) serverExe fullCaps "test/data" $ do - openDoc "Format.hs" "haskell" + it "works" $ \(hin, hout) -> + runSessionWithHandles hin hout (def { ignoreLogNotifications = True }) fullCaps "." $ do + openDoc "test/data/Format.hs" "haskell" void publishDiagnosticsNotification describe "dynamic capabilities" $ do - it "keeps track" $ runSession serverExe fullCaps "test/data" $ do + it "keeps track" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "." $ do loggingNotification -- initialized log message createDoc ".register" "haskell" "" @@ -316,10 +322,10 @@ [SomeRegistration (Registration _ regMethod regOpts)] <- getRegisteredCapabilities liftIO $ do case regMethod `mEqClient` SWorkspaceDidChangeWatchedFiles of - Just HRefl -> + Just (Right HRefl) -> regOpts `shouldBe` (DidChangeWatchedFilesRegistrationOptions $ List [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ]) - Nothing -> expectationFailure "Registration wasn't on workspace/didChangeWatchedFiles" + _ -> expectationFailure "Registration wasn't on workspace/didChangeWatchedFiles" -- now unregister it by sending a specific createDoc createDoc ".unregister" "haskell" "" @@ -330,7 +336,7 @@ count 0 $ loggingNotification void $ anyResponse - it "handles absolute patterns" $ runSession serverExe fullCaps "" $ do + it "handles absolute patterns" $ \(hin, hout) -> runSessionWithHandles hin hout def fullCaps "" $ do curDir <- liftIO $ getCurrentDirectory loggingNotification -- initialized log message @@ -362,26 +368,4 @@ docChangesCaps = def { _workspace = Just workspaceCaps } where workspaceCaps = def { _workspaceEdit = Just editCaps } - editCaps = WorkspaceEditClientCapabilities (Just True) Nothing Nothing - - -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' + editCaps = WorkspaceEditClientCapabilities (Just True) Nothing Nothing Nothing Nothing diff --git a/test/dummy-server/Main.hs b/test/dummy-server/Main.hs deleted file mode 100644 --- a/test/dummy-server/Main.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE OverloadedStrings #-} - -import Control.Monad -import Control.Monad.Reader -import Data.Aeson hiding (defaultOptions) -import qualified Data.HashMap.Strict as HM -import Data.List (isSuffixOf) -import Data.String -import Language.LSP.Server -import Language.LSP.Types -import System.Directory -import System.FilePath -import UnliftIO -import UnliftIO.Concurrent - -main = do - handlerEnv <- HandlerEnv <$> newEmptyMVar <*> newEmptyMVar - runServer $ ServerDefinition - { doInitialize = \env _req -> pure $ Right env, - onConfigurationChange = const $ pure $ Right (), - staticHandlers = handlers, - interpretHandler = \env -> - Iso - (\m -> runLspT env (runReaderT m handlerEnv)) - liftIO, - options = defaultOptions {executeCommandCommands = Just ["doAnEdit"]} - } - -data HandlerEnv = HandlerEnv - { relRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles), - absRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles) - } - -handlers :: Handlers (ReaderT HandlerEnv (LspM ())) -handlers = - mconcat - [ notificationHandler SInitialized $ - \_noti -> - sendNotification SWindowLogMessage $ - LogMessageParams MtLog "initialized" - , requestHandler STextDocumentHover $ - \_req responder -> - responder $ - Right $ - Just $ - Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing - , requestHandler STextDocumentDocumentSymbol $ - \_req responder -> - responder $ - Right $ - InL $ - List - [ DocumentSymbol - "foo" - Nothing - SkObject - Nothing - (mkRange 0 0 3 6) - (mkRange 0 0 3 6) - Nothing - ] - , notificationHandler STextDocumentDidOpen $ - \noti -> do - let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti - TextDocumentItem uri _ _ _ = doc - Just fp = uriToFilePath uri - diag = - Diagnostic - (mkRange 0 0 0 1) - (Just DsWarning) - (Just (InL 42)) - (Just "dummy-server") - "Here's a warning" - Nothing - Nothing - withRunInIO $ - \runInIO -> do - when (".hs" `isSuffixOf` fp) $ - void $ - forkIO $ - do - threadDelay (2 * 10 ^ 6) - runInIO $ - sendNotification STextDocumentPublishDiagnostics $ - PublishDiagnosticsParams uri Nothing (List [diag]) - -- also act as a registerer for workspace/didChangeWatchedFiles - when (".register" `isSuffixOf` fp) $ - do - let regOpts = - DidChangeWatchedFilesRegistrationOptions $ - List - [ FileSystemWatcher - "*.watch" - (Just (WatchKind True True True)) - ] - Just token <- runInIO $ - registerCapability SWorkspaceDidChangeWatchedFiles regOpts $ - \_noti -> - sendNotification SWindowLogMessage $ - LogMessageParams MtLog "got workspace/didChangeWatchedFiles" - runInIO $ asks relRegToken >>= \v -> putMVar v token - when (".register.abs" `isSuffixOf` fp) $ - do - curDir <- getCurrentDirectory - let regOpts = - DidChangeWatchedFilesRegistrationOptions $ - List - [ FileSystemWatcher - (fromString $ curDir "*.watch") - (Just (WatchKind True True True)) - ] - Just token <- runInIO $ - registerCapability SWorkspaceDidChangeWatchedFiles regOpts $ - \_noti -> - sendNotification SWindowLogMessage $ - LogMessageParams MtLog "got workspace/didChangeWatchedFiles" - runInIO $ asks absRegToken >>= \v -> putMVar v token - -- also act as an unregisterer for workspace/didChangeWatchedFiles - when (".unregister" `isSuffixOf` fp) $ - do - Just token <- runInIO $ asks relRegToken >>= tryReadMVar - runInIO $ unregisterCapability token - when (".unregister.abs" `isSuffixOf` fp) $ - do - Just token <- runInIO $ asks absRegToken >>= tryReadMVar - runInIO $ unregisterCapability token - , requestHandler SWorkspaceExecuteCommand $ \req resp -> do - let RequestMessage _ _ _ (ExecuteCommandParams Nothing "doAnEdit" (Just (List [val]))) = req - Success docUri = fromJSON val - edit = List [TextEdit (mkRange 0 0 0 5) "howdy"] - params = - ApplyWorkspaceEditParams (Just "Howdy edit") $ - WorkspaceEdit (Just (HM.singleton docUri edit)) Nothing - resp $ Right Null - void $ sendRequest SWorkspaceApplyEdit params (const (pure ())) - , requestHandler STextDocumentCodeAction $ \req resp -> do - let RequestMessage _ _ _ params = req - CodeActionParams _ _ _ _ cactx = params - CodeActionContext diags _ = cactx - codeActions = fmap diag2ca diags - diag2ca d = - CodeAction - "Delete this" - Nothing - (Just (List [d])) - Nothing - Nothing - Nothing - (Just (Command "" "deleteThis" Nothing)) - resp $ Right $ InR <$> codeActions - , requestHandler STextDocumentCompletion $ \_req resp -> do - let res = CompletionList True (List [item]) - item = - CompletionItem - "foo" - (Just CiConstant) - (Just (List [])) - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - Nothing - resp $ Right $ InR res - ]