lsp-test 0.13.0.0 → 0.14.0.0
raw patch · 13 files changed
+642/−368 lines, 13 filesdep +extradep ~basedep ~lspdep ~lsp-typesnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies added: extra
Dependency ranges changed: base, lsp, lsp-types, parser-combinators, process
API changes (from Hackage documentation)
Files
- ChangeLog.md +6/−0
- README.md +7/−2
- bench/SimpleBench.hs +66/−0
- example/Test.hs +20/−0
- func-test/FuncTest.hs +130/−0
- lsp-test.cabal +49/−31
- src/Language/LSP/Test.hs +27/−6
- src/Language/LSP/Test/Files.hs +1/−1
- src/Language/LSP/Test/Parsing.hs +23/−21
- src/Language/LSP/Test/Session.hs +26/−19
- test/DummyServer.hs +188/−0
- test/Test.hs +99/−115
- test/dummy-server/Main.hs +0/−173
ChangeLog.md view
@@ -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)
README.md view
@@ -1,6 +1,11 @@-# lsp-test [](https://github.com/bubba/lsp-test/actions) [](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.
+ bench/SimpleBench.hs view
@@ -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+
+ example/Test.hs view
@@ -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+
+ func-test/FuncTest.hs view
@@ -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+
lsp-test.cabal view
@@ -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 <https://microsoft.github.io/language-server-protocol/ Language Server Protocol servers>. @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- <haskell-lsp https://hackage.haskell.org/package/haskell-lsp>.+ down to the wire. To see examples of it in action, check out <https://github.com/haskell/haskell-ide-engine haskell-ide-engine>, <https://github.com/haskell/haskell-language-server haskell-language-server> and <https://github.com/digital-asset/ghcide ghcide>.-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
src/Language/LSP/Test.hs view
@@ -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)
src/Language/LSP/Test/Files.hs view
@@ -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
src/Language/LSP/Test/Parsing.hs view
@@ -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
src/Language/LSP/Test/Session.hs view
@@ -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
+ test/DummyServer.hs view
@@ -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+ ]
test/Test.hs view
@@ -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
− test/dummy-server/Main.hs
@@ -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- ]