lsp-test 0.12.0.0 → 0.13.0.0

raw patch · 23 files changed

+2055/−2325 lines, 23 filesdep +lspdep +lsp-typesdep +somedep −haskell-lspdep ~basedep ~mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: lsp, lsp-types, some, time, unliftio

Dependencies removed: haskell-lsp

Dependency ranges changed: base, mtl

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−2
• README.md +1/−1
• lsp-test.cabal +23/−22
• src/Language/Haskell/LSP/Test.hs +0/−689
• src/Language/Haskell/LSP/Test/Compat.hs +0/−115
• src/Language/Haskell/LSP/Test/Decoding.hs +0/−157
• src/Language/Haskell/LSP/Test/Exceptions.hs +0/−60
• src/Language/Haskell/LSP/Test/Files.hs +0/−96
• src/Language/Haskell/LSP/Test/Messages.hs +0/−154
• src/Language/Haskell/LSP/Test/Parsing.hs +0/−153
• src/Language/Haskell/LSP/Test/Replay.hs +0/−237
• src/Language/Haskell/LSP/Test/Server.hs +0/−22
• src/Language/Haskell/LSP/Test/Session.hs +0/−441
• src/Language/LSP/Test.hs +727/−0
• src/Language/LSP/Test/Compat.hs +120/−0
• src/Language/LSP/Test/Decoding.hs +104/−0
• src/Language/LSP/Test/Exceptions.hs +59/−0
• src/Language/LSP/Test/Files.hs +105/−0
• src/Language/LSP/Test/Parsing.hs +207/−0
• src/Language/LSP/Test/Server.hs +22/−0
• src/Language/LSP/Test/Session.hs +473/−0
• test/Test.hs +42/−63
• test/dummy-server/Main.hs +164/−113

@@ -1,8 +1,14 @@ # Revision history for lsp-test -## 0.12.0.0 -- 2021-01-25+## 0.13.0.0 -- 2021-02-14 -* Add `getIncompleteProgressSessions` to track in ongoing progress sessions (@wz1000)+* Add support for lsp-types-1.1 (@wz1000)+* Automatically respond to `workspace/applyEdit` and+  `window/workDoneProgress/create` messages (@wz1000)++## 0.12.0.0 -- 2021-01-25+* Add `getIncompleteProgressSessions` to track ongoing progress sessions+  (@wz1000)  ## 0.11.0.0 -- 2020-05-14 

@@ -2,7 +2,7 @@ lsp-test is a functional testing framework for Language Server Protocol servers.  ```haskell-import Language.Haskell.LSP.Test+import Language.LSP.Test main = runSession "hie" fullCaps "proj/dir" $ do   doc <- openDoc "Foo.hs" "haskell"   skipMany anyNotification

@@ -1,11 +1,11 @@ name:                lsp-test-version:             0.12.0.0+version:             0.13.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.Haskell.LSP.Test@ launches your server as a subprocess and allows you to simulate a session-  down to the wire, and @Language.Haskell.LSP.Test@ can replay captured sessions from+  @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>.   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@@ -22,7 +22,7 @@ cabal-version:       2.0 extra-source-files:  README.md                    , ChangeLog.md-tested-with:         GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1+tested-with:         GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1, GHC == 8.10.2  source-repository head   type:     git@@ -35,15 +35,15 @@  library   hs-source-dirs:      src-  exposed-modules:     Language.Haskell.LSP.Test-                     , Language.Haskell.LSP.Test.Replay-  reexported-modules:  haskell-lsp:Language.Haskell.LSP.Types-                     , haskell-lsp:Language.Haskell.LSP.Types.Capabilities+  exposed-modules:     Language.LSP.Test+  reexported-modules:  lsp-types:Language.LSP.Types+                     , lsp-types:Language.LSP.Types.Capabilities                      , parser-combinators:Control.Applicative.Combinators   default-language:    Haskell2010   build-depends:       base >= 4.10 && < 5-                     , haskell-lsp >= 0.22 && < 0.24+                     , lsp-types == 1.1.*                      , aeson+                     , time                      , aeson-pretty                      , ansi-terminal                      , async@@ -63,31 +63,32 @@                      , text                      , transformers                      , unordered-containers+                     , some   if os(windows)     build-depends:     Win32   else     build-depends:     unix-  other-modules:       Language.Haskell.LSP.Test.Compat-                       Language.Haskell.LSP.Test.Decoding-                       Language.Haskell.LSP.Test.Exceptions-                       Language.Haskell.LSP.Test.Files-                       Language.Haskell.LSP.Test.Messages-                       Language.Haskell.LSP.Test.Parsing-                       Language.Haskell.LSP.Test.Server-                       Language.Haskell.LSP.Test.Session+  other-modules:       Language.LSP.Test.Compat+                       Language.LSP.Test.Decoding+                       Language.LSP.Test.Exceptions+                       Language.LSP.Test.Files+                       Language.LSP.Test.Parsing+                       Language.LSP.Test.Server+                       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.10 && < 5-                     , haskell-lsp >= 0.23 && < 0.24-                     , data-default+  build-depends:       base >= 4.11 && < 5+                     , lsp == 1.1.*                      , aeson                      , unordered-containers                      , directory                      , filepath+                     , unliftio+                     , mtl   default-language:    Haskell2010   scope:               private   if !flag(DummyServer)@@ -101,7 +102,7 @@   build-depends:       base >= 4.10 && < 5                      , hspec                      , lens-                     , haskell-lsp >= 0.22 && < 0.24+                     , lsp-types == 1.1.*                      , lsp-test                      , data-default                      , aeson@@ -110,4 +111,4 @@                      , directory                      , filepath   default-language:    Haskell2010-  build-tool-depends: lsp-test:dummy-server+  build-tool-depends:  lsp-test:dummy-server

@@ -1,689 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ExistentialQuantification #-}--{-|-Module      : Language.Haskell.LSP.Test-Description : A functional testing framework for LSP servers.-Maintainer  : luke_lau@icloud.com-Stability   : experimental-Portability : non-portable--Provides the framework to start functionally testing-<https://github.com/Microsoft/language-server-protocol Language Server Protocol servers>.-You should import "Language.Haskell.LSP.Types" alongside this.--}-module Language.Haskell.LSP.Test-  (-  -- * Sessions-    Session-  , runSession-  -- ** Config-  , runSessionWithConfig-  , SessionConfig(..)-  , defaultConfig-  , C.fullCaps-  -- ** Exceptions-  , module Language.Haskell.LSP.Test.Exceptions-  , withTimeout-  -- * Sending-  , request-  , request_-  , sendRequest-  , sendNotification-  , sendResponse-  -- * Receving-  , module Language.Haskell.LSP.Test.Parsing-  -- * Utilities-  -- | Quick helper functions for common tasks.--  -- ** Initialization-  , initializeResponse-  -- ** Documents-  , createDoc-  , openDoc-  , closeDoc-  , changeDoc-  , documentContents-  , getDocumentEdit-  , getDocUri-  , getVersionedDoc-  -- ** Symbols-  , getDocumentSymbols-  -- ** Diagnostics-  , waitForDiagnostics-  , waitForDiagnosticsSource-  , noDiagnostics-  , getCurrentDiagnostics-  , getIncompleteProgressSessions-  -- ** Commands-  , executeCommand-  -- ** Code Actions-  , getCodeActions-  , getAllCodeActions-  , executeCodeAction-  -- ** Completions-  , getCompletions-  -- ** References-  , getReferences-  -- ** Definitions-  , getDefinitions-  , getTypeDefinitions-  -- ** Renaming-  , rename-  -- ** Hover-  , getHover-  -- ** Highlights-  , getHighlights-  -- ** Formatting-  , formatDoc-  , formatRange-  -- ** Edits-  , applyEdit-  -- ** Code lenses-  , getCodeLenses-  -- ** Capabilities-  , getRegisteredCapabilities-  ) where--import Control.Applicative.Combinators-import Control.Concurrent-import Control.Monad-import Control.Monad.IO.Class-import Control.Exception-import Control.Lens hiding ((.=), List)-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-import Data.Aeson-import Data.Default-import qualified Data.HashMap.Strict as HashMap-import Data.List-import Data.Maybe-import Language.Haskell.LSP.Types-import Language.Haskell.LSP.Types.Lens hiding-  (id, capabilities, message, executeCommand, applyEdit, rename)-import qualified Language.Haskell.LSP.Types.Lens as LSP-import qualified Language.Haskell.LSP.Types.Capabilities as C-import Language.Haskell.LSP.Messages-import Language.Haskell.LSP.VFS-import Language.Haskell.LSP.Test.Compat-import Language.Haskell.LSP.Test.Decoding-import Language.Haskell.LSP.Test.Exceptions-import Language.Haskell.LSP.Test.Parsing-import Language.Haskell.LSP.Test.Session-import Language.Haskell.LSP.Test.Server-import System.Environment-import System.IO-import System.Directory-import System.FilePath-import qualified System.FilePath.Glob as Glob---- | Starts a new session.------ > runSession "hie" fullCaps "path/to/root/dir" $ do--- >   doc <- openDoc "Desktop/simple.hs" "haskell"--- >   diags <- waitForDiagnostics--- >   let pos = Position 12 5--- >       params = TextDocumentPositionParams doc--- >   hover <- request TextDocumentHover params-runSession :: String -- ^ The command to run the server.-           -> C.ClientCapabilities -- ^ The capabilities that the client should declare.-           -> FilePath -- ^ The filepath to the root directory for the session.-           -> Session a -- ^ The session to run.-           -> IO a-runSession = runSessionWithConfig def---- | Starts a new sesion with a custom configuration.-runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.-                     -> String -- ^ The command to run the server.-                     -> C.ClientCapabilities -- ^ The capabilities that the client should declare.-                     -> FilePath -- ^ The filepath to the root directory for the session.-                     -> Session a -- ^ The session to run.-                     -> IO a-runSessionWithConfig config' serverExe caps rootDir session = do-  pid <- getCurrentProcessID-  absRootDir <- canonicalizePath rootDir--  config <- envOverrideConfig config'--  let initializeParams = InitializeParams (Just pid)-                                          (Just $ T.pack absRootDir)-                                          (Just $ filePathToUri absRootDir)-                                          Nothing-                                          caps-                                          (Just TraceOff)-                                          Nothing-  withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc ->-    runSessionWithHandles serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do-      -- Wrap the session around initialize and shutdown calls-      -- initRspMsg <- sendRequest Initialize initializeParams :: Session InitializeResponse-      initReqId <- sendRequest Initialize initializeParams--      -- Because messages can be sent in between the request and response,-      -- collect them and then...-      (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId initReqId)--      case initRspMsg ^. LSP.result of-        Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error)-        Right _ -> pure ()--      initRspVar <- initRsp <$> ask-      liftIO $ putMVar initRspVar initRspMsg-      sendNotification Initialized InitializedParams--      case lspConfig config of-        Just cfg -> sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)-        Nothing -> return ()--      -- ... relay them back to the user Session so they can match on them!-      -- As long as they are allowed.-      forM_ inBetween checkLegalBetweenMessage-      msgChan <- asks messageChan-      liftIO $ writeList2Chan msgChan (ServerMessage <$> inBetween)--      -- Run the actual test-      session-  where-  -- | Asks the server to shutdown and exit politely-  exitServer :: Session ()-  exitServer = request_ Shutdown (Nothing :: Maybe Value) >> sendNotification Exit ExitParams--  -- | Listens to the server output until the shutdown ack,-  -- makes sure it matches the record and signals any semaphores-  listenServer :: Handle -> SessionContext -> IO ()-  listenServer serverOut context = do-    msgBytes <- getNextMessage serverOut--    reqMap <- readMVar $ requestMap context--    let msg = decodeFromServerMsg reqMap msgBytes-    writeChan (messageChan context) (ServerMessage msg)--    case msg of-      (RspShutdown _) -> return ()-      _               -> listenServer serverOut context--  -- | Is this message allowed to be sent by the server between the intialize-  -- request and response?-  -- https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#initialize-  checkLegalBetweenMessage :: FromServerMessage -> Session ()-  checkLegalBetweenMessage (NotShowMessage _) = pure ()-  checkLegalBetweenMessage (NotLogMessage _) = pure ()-  checkLegalBetweenMessage (NotTelemetry _) = pure ()-  checkLegalBetweenMessage (ReqShowMessage _) = pure ()-  checkLegalBetweenMessage msg = throw (IllegalInitSequenceMessage msg)--  -- | Check environment variables to override the config-  envOverrideConfig :: SessionConfig -> IO SessionConfig-  envOverrideConfig cfg = do-    logMessages' <- fromMaybe (logMessages cfg) <$> checkEnv "LSP_TEST_LOG_MESSAGES"-    logStdErr' <- fromMaybe (logStdErr cfg) <$> checkEnv "LSP_TEST_LOG_STDERR"-    return $ cfg { logMessages = logMessages', logStdErr = logStdErr' }-    where checkEnv :: String -> IO (Maybe Bool)-          checkEnv s = fmap convertVal <$> lookupEnv s-          convertVal "0" = False-          convertVal _ = True---- | The current text contents of a document.-documentContents :: TextDocumentIdentifier -> Session T.Text-documentContents doc = do-  vfs <- vfs <$> get-  let file = vfsMap vfs Map.! toNormalizedUri (doc ^. uri)-  return (virtualFileText file)---- | Parses an ApplyEditRequest, checks that it is for the passed document--- and returns the new content-getDocumentEdit :: TextDocumentIdentifier -> Session T.Text-getDocumentEdit doc = do-  req <- message :: Session ApplyWorkspaceEditRequest--  unless (checkDocumentChanges req || checkChanges req) $-    liftIO $ throw (IncorrectApplyEditRequest (show req))--  documentContents doc-  where-    checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool-    checkDocumentChanges req =-      let changes = req ^. params . edit . documentChanges-          maybeDocs = fmap (fmap (^. textDocument . uri)) changes-      in case maybeDocs of-        Just docs -> (doc ^. uri) `elem` docs-        Nothing -> False-    checkChanges :: ApplyWorkspaceEditRequest -> Bool-    checkChanges req =-      let mMap = req ^. params . edit . changes-        in maybe False (HashMap.member (doc ^. uri)) mMap---- | Sends a request to the server and waits for its response.--- Will skip any messages in between the request and the response--- @--- rsp <- request TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse--- @--- Note: will skip any messages in between the request and the response.-request :: (ToJSON params, FromJSON a) => ClientMethod -> params -> Session (ResponseMessage a)-request m = sendRequest m >=> skipManyTill anyMessage . responseForId---- | The same as 'sendRequest', but discard the response.-request_ :: ToJSON params => ClientMethod -> params -> Session ()-request_ p = void . (request p :: ToJSON params => params -> Session (ResponseMessage Value))---- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.-sendRequest-  :: ToJSON params-  => ClientMethod -- ^ The request method.-  -> params -- ^ The request parameters.-  -> Session LspId -- ^ The id of the request that was sent.-sendRequest method params = do-  id <- curReqId <$> get-  modify $ \c -> c { curReqId = nextId id }--  let req = RequestMessage' "2.0" id method params--  -- Update the request map-  reqMap <- requestMap <$> ask-  liftIO $ modifyMVar_ reqMap $-    \r -> return $ updateRequestMap r id method--  sendMessage req--  return id--  where nextId (IdInt i) = IdInt (i + 1)-        nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1---- | A custom type for request message that doesn't--- need a response type, allows us to infer the request--- message type without using proxies.-data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a--instance ToJSON a => ToJSON (RequestMessage' a) where-  toJSON (RequestMessage' rpc id method params) =-    object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params]----- | Sends a notification to the server.-sendNotification :: ToJSON a-                 => ClientMethod -- ^ The notification method.-                 -> a -- ^ The notification parameters.-                 -> Session ()---- Open a virtual file if we send a did open text document notification-sendNotification TextDocumentDidOpen params = do-  let params' = fromJust $ decode $ encode params-      n :: DidOpenTextDocumentNotification-      n = NotificationMessage "2.0" TextDocumentDidOpen params'-  oldVFS <- vfs <$> get-  let (newVFS,_) = openVFS oldVFS n-  modify (\s -> s { vfs = newVFS })-  sendMessage n---- Close a virtual file if we send a close text document notification-sendNotification TextDocumentDidClose params = do-  let params' = fromJust $ decode $ encode params-      n :: DidCloseTextDocumentNotification-      n = NotificationMessage "2.0" TextDocumentDidClose params'-  oldVFS <- vfs <$> get-  let (newVFS,_) = closeVFS oldVFS n-  modify (\s -> s { vfs = newVFS })-  sendMessage n--sendNotification TextDocumentDidChange params = do-    let params' = fromJust $ decode $ encode params-        n :: DidChangeTextDocumentNotification-        n = NotificationMessage "2.0" TextDocumentDidChange params'-    oldVFS <- vfs <$> get-    let (newVFS,_) = changeFromClientVFS oldVFS n-    modify (\s -> s { vfs = newVFS })-    sendMessage n--sendNotification method params = sendMessage (NotificationMessage "2.0" method params)---- | Sends a response to the server.-sendResponse :: ToJSON a => ResponseMessage a -> Session ()-sendResponse = sendMessage---- | Returns the initialize response that was received from the server.--- The initialize requests and responses are not included the session,--- so if you need to test it use this.-initializeResponse :: Session InitializeResponse-initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)---- | /Creates/ a new text document. This is different from 'openDoc'--- as it sends a workspace/didChangeWatchedFiles notification letting the server--- know that a file was created within the workspace, __provided that the server--- has registered for it__, and the file matches any patterns the server--- registered for.--- It /does not/ actually create a file on disk, but is useful for convincing--- the server that one does exist.------ @since 11.0.0.0-createDoc :: FilePath -- ^ The path to the document to open, __relative to the root directory__.-          -> String -- ^ The text document's language identifier, e.g. @"haskell"@.-          -> T.Text -- ^ The content of the text document to create.-          -> Session TextDocumentIdentifier -- ^ The identifier of the document just created.-createDoc file languageId contents = do-  dynCaps <- curDynCaps <$> get-  rootDir <- asks rootDir-  caps <- asks sessionCapabilities-  absFile <- liftIO $ canonicalizePath (rootDir </> file)-  let regs = filter (\r -> r ^. method == WorkspaceDidChangeWatchedFiles) $-              Map.elems dynCaps-      watchHits :: FileSystemWatcher -> Bool-      watchHits (FileSystemWatcher pattern kind) =-        -- If WatchKind is exlcuded, defaults to all true as per spec-        fileMatches pattern && createHits (fromMaybe (WatchKind True True True) kind)--      fileMatches pattern = Glob.match (Glob.compile pattern) relOrAbs-        -- If the pattern is absolute then match against the absolute fp-        where relOrAbs-                | isAbsolute pattern = absFile-                | otherwise = file--      createHits (WatchKind create _ _) = create--      regHits :: Registration -> Bool-      regHits reg = isJust $ do-        opts <- reg ^. registerOptions-        fileWatchOpts <- case fromJSON opts :: Result DidChangeWatchedFilesRegistrationOptions of-          Success x -> Just x-          Error _ -> Nothing-        if foldl' (\acc w -> acc || watchHits w) False (fileWatchOpts ^. watchers)-          then Just ()-          else Nothing--      clientCapsSupports =-          caps ^? workspace . _Just . didChangeWatchedFiles . _Just . dynamicRegistration . _Just-            == Just True-      shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs--  when shouldSend $-    sendNotification WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $-      List [ FileEvent (filePathToUri (rootDir </> file)) FcCreated ]-  openDoc' file languageId contents---- | Opens a text document that /exists on disk/, and sends a--- textDocument/didOpen notification to the server.-openDoc :: FilePath -> String -> Session TextDocumentIdentifier-openDoc file languageId = do-  context <- ask-  let fp = rootDir context </> file-  contents <- liftIO $ T.readFile fp-  openDoc' file languageId contents---- | This is a variant of `openDoc` that takes the file content as an argument.--- Use this is the file exists /outside/ of the current workspace.-openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier-openDoc' file languageId contents = do-  context <- ask-  let fp = rootDir context </> file-      uri = filePathToUri fp-      item = TextDocumentItem uri (T.pack languageId) 0 contents-  sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)-  pure $ TextDocumentIdentifier uri---- | Closes a text document and sends a textDocument/didOpen notification to the server.-closeDoc :: TextDocumentIdentifier -> Session ()-closeDoc docId = do-  let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))-  sendNotification TextDocumentDidClose params---- | Changes a text document and sends a textDocument/didOpen notification to the server.-changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()-changeDoc docId changes = do-  verDoc <- getVersionedDoc docId-  let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)-  sendNotification TextDocumentDidChange params---- | Gets the Uri for the file corrected to the session directory.-getDocUri :: FilePath -> Session Uri-getDocUri file = do-  context <- ask-  let fp = rootDir context </> file-  return $ filePathToUri fp---- | Waits for diagnostics to be published and returns them.-waitForDiagnostics :: Session [Diagnostic]-waitForDiagnostics = do-  diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification-  let (List diags) = diagsNot ^. params . LSP.diagnostics-  return diags---- | The same as 'waitForDiagnostics', but will only match a specific--- 'Language.Haskell.LSP.Types._source'.-waitForDiagnosticsSource :: String -> Session [Diagnostic]-waitForDiagnosticsSource src = do-  diags <- waitForDiagnostics-  let res = filter matches diags-  if null res-    then waitForDiagnosticsSource src-    else return res-  where-    matches :: Diagnostic -> Bool-    matches d = d ^. source == Just (T.pack src)---- | Expects a 'PublishDiagnosticsNotification' and throws an--- 'UnexpectedDiagnostics' exception if there are any diagnostics--- returned.-noDiagnostics :: Session ()-noDiagnostics = do-  diagsNot <- message :: Session PublishDiagnosticsNotification-  when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics---- | Returns the symbols in a document.-getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])-getDocumentSymbols doc = do-  ResponseMessage _ rspLid res <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) :: Session DocumentSymbolsResponse-  case res of-    Right (DSDocumentSymbols (List xs)) -> return (Left xs)-    Right (DSSymbolInformation (List xs)) -> return (Right xs)-    Left err -> throw (UnexpectedResponseError rspLid err)---- | Returns the code actions in the specified range.-getCodeActions :: TextDocumentIdentifier -> Range -> Session [CAResult]-getCodeActions doc range = do-  ctx <- getCodeActionContext doc-  rsp <- request TextDocumentCodeAction (CodeActionParams doc range ctx Nothing)--  case rsp ^. result of-    Right (List xs) -> return xs-    Left error -> throw (UnexpectedResponseError (rsp ^. LSP.id) error)---- | Returns all the code actions in a document by--- querying the code actions at each of the current--- diagnostics' positions.-getAllCodeActions :: TextDocumentIdentifier -> Session [CAResult]-getAllCodeActions doc = do-  ctx <- getCodeActionContext doc--  foldM (go ctx) [] =<< getCurrentDiagnostics doc--  where-    go :: CodeActionContext -> [CAResult] -> Diagnostic -> Session [CAResult]-    go ctx acc diag = do-      ResponseMessage _ rspLid res <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx Nothing)--      case res of-        Left e -> throw (UnexpectedResponseError rspLid e)-        Right (List cmdOrCAs) -> pure (acc ++ cmdOrCAs)--getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext-getCodeActionContext doc = do-  curDiags <- getCurrentDiagnostics doc-  return $ CodeActionContext (List curDiags) Nothing---- | Returns the current diagnostics that have been sent to the client.--- Note that this does not wait for more to come in.-getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]-getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get---- | Returns the tokens of all progress sessions that have started but not yet ended.-getIncompleteProgressSessions :: Session (Set.Set ProgressToken)-getIncompleteProgressSessions = curProgressSessions <$> get---- | Executes a command.-executeCommand :: Command -> Session ()-executeCommand cmd = do-  let args = decode $ encode $ fromJust $ cmd ^. arguments-      execParams = ExecuteCommandParams (cmd ^. command) args Nothing-  request_ WorkspaceExecuteCommand execParams---- | Executes a code action.--- Matching with the specification, if a code action--- contains both an edit and a command, the edit will--- be applied first.-executeCodeAction :: CodeAction -> Session ()-executeCodeAction action = do-  maybe (return ()) handleEdit $ action ^. edit-  maybe (return ()) executeCommand $ action ^. command--  where handleEdit :: WorkspaceEdit -> Session ()-        handleEdit e =-          -- Its ok to pass in dummy parameters here as they aren't used-          let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)-            in updateState (ReqApplyWorkspaceEdit req)---- | Adds the current version to the document, as tracked by the session.-getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier-getVersionedDoc (TextDocumentIdentifier uri) = do-  fs <- vfsMap . vfs <$> get-  let ver =-        case fs Map.!? toNormalizedUri uri of-          Just vf -> Just (virtualFileVersion vf)-          _ -> Nothing-  return (VersionedTextDocumentIdentifier uri ver)---- | Applys an edit to the document and returns the updated document version.-applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier-applyEdit doc edit = do--  verDoc <- getVersionedDoc doc--  caps <- asks sessionCapabilities--  let supportsDocChanges = fromMaybe False $ do-        let mWorkspace = C._workspace caps-        C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace-        C.WorkspaceEditClientCapabilities mDocChanges <- mEdit-        mDocChanges--  let wEdit = if supportsDocChanges-      then-        let docEdit = TextDocumentEdit verDoc (List [edit])-        in WorkspaceEdit Nothing (Just (List [docEdit]))-      else-        let changes = HashMap.singleton (doc ^. uri) (List [edit])-        in WorkspaceEdit (Just changes) Nothing--  let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)-  updateState (ReqApplyWorkspaceEdit req)--  -- version may have changed-  getVersionedDoc doc---- | Returns the completions for the position in the document.-getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]-getCompletions doc pos = do-  rsp <- request TextDocumentCompletion (TextDocumentPositionParams doc pos Nothing)--  case getResponseResult rsp of-    Completions (List items) -> return items-    CompletionList (CompletionListType _ (List items)) -> return items---- | Returns the references for the position in the document.-getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.-              -> Position -- ^ The position to lookup.-              -> Bool -- ^ Whether to include declarations as references.-              -> Session [Location] -- ^ The locations of the references.-getReferences doc pos inclDecl =-  let ctx = ReferenceContext inclDecl-      params = ReferenceParams doc pos ctx Nothing-  in getResponseResult <$> request TextDocumentReferences params---- | Returns the definition(s) for the term at the specified position.-getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.-               -> Position -- ^ The position the term is at.-               -> Session [Location] -- ^ The location(s) of the definitions-getDefinitions doc pos = do-  let params = TextDocumentPositionParams doc pos Nothing-  rsp <- request TextDocumentDefinition params :: Session DefinitionResponse-  case getResponseResult rsp of-    SingleLoc loc -> pure [loc]-    MultiLoc locs -> pure locs---- | Returns the type definition(s) for the term at the specified position.-getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.-                   -> Position -- ^ The position the term is at.-                   -> Session [Location] -- ^ The location(s) of the definitions-getTypeDefinitions doc pos = do-  let params = TextDocumentPositionParams doc pos Nothing-  rsp <- request TextDocumentTypeDefinition params :: Session TypeDefinitionResponse-  case getResponseResult rsp of-    SingleLoc loc -> pure [loc]-    MultiLoc locs -> pure locs---- | Renames the term at the specified position.-rename :: TextDocumentIdentifier -> Position -> String -> Session ()-rename doc pos newName = do-  let params = RenameParams doc pos (T.pack newName) Nothing-  rsp <- request TextDocumentRename params :: Session RenameResponse-  let wEdit = getResponseResult rsp-      req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)-  updateState (ReqApplyWorkspaceEdit req)---- | Returns the hover information at the specified position.-getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)-getHover doc pos =-  let params = TextDocumentPositionParams doc pos Nothing-  in getResponseResult <$> request TextDocumentHover params---- | Returns the highlighted occurences of the term at the specified position-getHighlights :: TextDocumentIdentifier -> Position -> Session [DocumentHighlight]-getHighlights doc pos =-  let params = TextDocumentPositionParams doc pos Nothing-  in getResponseResult <$> request TextDocumentDocumentHighlight params---- | Checks the response for errors and throws an exception if needed.--- Returns the result if successful.-getResponseResult :: ResponseMessage a -> a-getResponseResult rsp =-  case rsp ^. result of-    Right x -> x-    Left err -> throw $ UnexpectedResponseError (rsp ^. LSP.id) err---- | Applies formatting to the specified document.-formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()-formatDoc doc opts = do-  let params = DocumentFormattingParams doc opts Nothing-  edits <- getResponseResult <$> request TextDocumentFormatting params-  applyTextEdits doc edits---- | Applies formatting to the specified range in a document.-formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()-formatRange doc opts range = do-  let params = DocumentRangeFormattingParams doc range opts Nothing-  edits <- getResponseResult <$> request TextDocumentRangeFormatting params-  applyTextEdits doc edits--applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()-applyTextEdits doc edits =-  let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) Nothing-      -- Send a dummy message to updateState so it can do bookkeeping-      req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)-  in updateState (ReqApplyWorkspaceEdit req)---- | Returns the code lenses for the specified document.-getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens]-getCodeLenses tId = do-    rsp <- request TextDocumentCodeLens (CodeLensParams tId Nothing) :: Session CodeLensResponse-    case getResponseResult rsp of-        List res -> pure res---- | Returns a list of capabilities that the server has requested to /dynamically/--- register during the 'Session'.------ @since 0.11.0.0-getRegisteredCapabilities :: Session [Registration]-getRegisteredCapabilities = (Map.elems . curDynCaps) <$> get

@@ -1,115 +0,0 @@-{-# LANGUAGE CPP #-}--- For some reason ghc warns about not using--- Control.Monad.IO.Class but it's needed for--- MonadIO-{-# OPTIONS_GHC -Wunused-imports #-}-module Language.Haskell.LSP.Test.Compat where--import Data.Maybe-import System.IO--#if MIN_VERSION_process(1,6,3)--- We have to hide cleanupProcess for process-1.6.3.0--- cause it is in the public api for 1.6.3.0 versions--- shipped with ghc >= 8.6 and < 8.6.4-import System.Process hiding (getPid, cleanupProcess, withCreateProcess)-# if MIN_VERSION_process(1,6,4)-import qualified System.Process (getPid, cleanupProcess, withCreateProcess)-# else-import Foreign.C.Error-import GHC.IO.Exception ( IOErrorType(..), IOException(..) )--import qualified System.Process (getPid)-import qualified Control.Exception as C-# endif-#else-import Control.Concurrent.MVar-import Foreign.C.Error-import GHC.IO.Exception ( IOErrorType(..), IOException(..) )-import System.Process hiding (withCreateProcess)-import System.Process.Internals--import qualified Control.Exception as C-#endif--#ifdef mingw32_HOST_OS-import qualified System.Win32.Process-#else-import qualified System.Posix.Process-#endif---getCurrentProcessID :: IO Int-#ifdef mingw32_HOST_OS-getCurrentProcessID = fromIntegral <$> System.Win32.Process.getCurrentProcessId-#else-getCurrentProcessID = fromIntegral <$> System.Posix.Process.getProcessID-#endif--getProcessID :: ProcessHandle -> IO Int-getProcessID p = fromIntegral . fromJust <$> getProcessID' p-  where-#if MIN_VERSION_process(1,6,3)-  getProcessID' = System.Process.getPid-#else-#if MIN_VERSION_process(1,6,0)-  getProcessID' (ProcessHandle mh _ _) = do-#else-  getProcessID' (ProcessHandle mh _) = do-#endif-    p_ <- readMVar mh-    case p_ of-#ifdef mingw32_HOST_OS-      OpenHandle h -> do-        pid <- System.Win32.Process.getProcessId h-        return $ Just pid-#else-      OpenHandle pid -> return $ Just pid-#endif-      _ -> return Nothing-#endif--cleanupProcess-  :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()--withCreateProcess-  :: CreateProcess-  -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)-  -> IO a--#if MIN_VERSION_process(1,6,4)--cleanupProcess = System.Process.cleanupProcess--withCreateProcess = System.Process.withCreateProcess--#else--cleanupProcess (mb_stdin, mb_stdout, mb_stderr, ph) = do-    -- We ignore the spurious "permission denied" error in windows:-    --   see https://github.com/haskell/process/issues/110-    ignorePermDenied $ terminateProcess ph-    -- Note, it's important that other threads that might be reading/writing-    -- these handles also get killed off, since otherwise they might be holding-    -- the handle lock and prevent us from closing, leading to deadlock.-    maybe (return ()) (ignoreSigPipe . hClose) mb_stdin-    maybe (return ()) hClose mb_stdout-    maybe (return ()) hClose mb_stderr--    return ()-  where ignoreSigPipe = ignoreIOError ResourceVanished ePIPE-        ignorePermDenied = ignoreIOError PermissionDenied eACCES-    -ignoreIOError :: IOErrorType -> Errno -> IO () -> IO ()-ignoreIOError ioErrorType errno =-  C.handle $ \e -> case e of-                     IOError { ioe_type  = iot-                             , ioe_errno = Just ioe }-                       | iot == ioErrorType && Errno ioe == errno -> return ()-                     _ -> C.throwIO e--withCreateProcess c action =-  C.bracket (createProcess c) cleanupProcess-            (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)--#endif

@@ -1,157 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Language.Haskell.LSP.Test.Decoding where--import           Prelude                 hiding ( id )-import           Data.Aeson-import           Data.Foldable-import           Control.Exception-import           Control.Lens-import qualified Data.ByteString.Lazy.Char8    as B-import           Data.Maybe-import           System.IO-import           System.IO.Error-import           Language.Haskell.LSP.Types-import           Language.Haskell.LSP.Types.Lens-import           Language.Haskell.LSP.Messages-import           Language.Haskell.LSP.Test.Exceptions-import qualified Data.HashMap.Strict           as HM--getAllMessages :: Handle -> IO [B.ByteString]-getAllMessages h = do-  done <- hIsEOF h-  if done-    then return []-    else do-      msg <- getNextMessage h--      (msg :) <$> getAllMessages h---- | Fetches the next message bytes based on--- the Content-Length header-getNextMessage :: Handle -> IO B.ByteString-getNextMessage h = do-  headers <- getHeaders h-  case read . init <$> lookup "Content-Length" headers of-    Nothing   -> throw NoContentLengthHeader-    Just size -> B.hGet h size--addHeader :: B.ByteString -> B.ByteString-addHeader content = B.concat-  [ "Content-Length: "-  , B.pack $ show $ B.length content-  , "\r\n"-  , "\r\n"-  , content-  ]--getHeaders :: Handle -> IO [(String, String)]-getHeaders h = do-  l <- catch (hGetLine h) eofHandler-  let (name, val) = span (/= ':') l-  if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h-  where eofHandler e-          | isEOFError e = throw UnexpectedServerTermination-          | otherwise = throw e--type RequestMap = HM.HashMap LspId ClientMethod--newRequestMap :: RequestMap-newRequestMap = HM.empty--updateRequestMap :: RequestMap -> LspId -> ClientMethod -> RequestMap-updateRequestMap reqMap id method = HM.insert id method reqMap--getRequestMap :: [FromClientMessage] -> RequestMap-getRequestMap = foldl helper HM.empty- where-  helper acc msg = case msg of-    (ReqInitialize val) -> insert val acc-    (ReqShutdown val) -> insert val acc-    (ReqHover val) -> insert val acc-    (ReqCompletion val) -> insert val acc-    (ReqCompletionItemResolve val) -> insert val acc-    (ReqSignatureHelp val) -> insert val acc-    (ReqDefinition val) -> insert val acc-    (ReqTypeDefinition val) -> insert val acc-    (ReqFindReferences val) -> insert val acc-    (ReqDocumentHighlights val) -> insert val acc-    (ReqDocumentSymbols val) -> insert val acc-    (ReqWorkspaceSymbols val) -> insert val acc-    (ReqCodeAction val) -> insert val acc-    (ReqCodeLens val) -> insert val acc-    (ReqCodeLensResolve val) -> insert val acc-    (ReqDocumentFormatting val) -> insert val acc-    (ReqDocumentRangeFormatting val) -> insert val acc-    (ReqDocumentOnTypeFormatting val) -> insert val acc-    (ReqRename val) -> insert val acc-    (ReqExecuteCommand val) -> insert val acc-    (ReqDocumentLink val) -> insert val acc-    (ReqDocumentLinkResolve val) -> insert val acc-    (ReqWillSaveWaitUntil val) -> insert val acc-    _ -> acc-  insert m = HM.insert (m ^. id) (m ^. method)--matchResponseMsgType :: ClientMethod -> B.ByteString -> FromServerMessage-matchResponseMsgType req = case req of-  Initialize                    -> RspInitialize . decoded-  Shutdown                      -> RspShutdown . decoded-  TextDocumentHover             -> RspHover . decoded-  TextDocumentCompletion        -> RspCompletion . decoded-  CompletionItemResolve         -> RspCompletionItemResolve . decoded-  TextDocumentSignatureHelp     -> RspSignatureHelp . decoded-  TextDocumentDefinition        -> RspDefinition . decoded-  TextDocumentTypeDefinition    -> RspTypeDefinition . decoded-  TextDocumentReferences        -> RspFindReferences . decoded-  TextDocumentDocumentHighlight -> RspDocumentHighlights . decoded-  TextDocumentDocumentSymbol    -> RspDocumentSymbols . decoded-  WorkspaceSymbol               -> RspWorkspaceSymbols . decoded-  TextDocumentCodeAction        -> RspCodeAction . decoded-  TextDocumentCodeLens          -> RspCodeLens . decoded-  CodeLensResolve               -> RspCodeLensResolve . decoded-  TextDocumentFormatting        -> RspDocumentFormatting . decoded-  TextDocumentRangeFormatting   -> RspDocumentRangeFormatting . decoded-  TextDocumentOnTypeFormatting  -> RspDocumentOnTypeFormatting . decoded-  TextDocumentRename            -> RspRename . decoded-  WorkspaceExecuteCommand       -> RspExecuteCommand . decoded-  TextDocumentDocumentLink      -> RspDocumentLink . decoded-  DocumentLinkResolve           -> RspDocumentLinkResolve . decoded-  TextDocumentWillSaveWaitUntil -> RspWillSaveWaitUntil . decoded-  CustomClientMethod{}          -> RspCustomServer . decoded-  x                             -> error . ((show x ++ " is not a request: ") ++) . show-  where decoded x = fromMaybe (error $ "Couldn't decode response for the request type: "-                                        ++ show req ++ "\n" ++ show x)-                              (decode x)--decodeFromServerMsg :: RequestMap -> B.ByteString -> FromServerMessage-decodeFromServerMsg reqMap bytes =-  case HM.lookup "method" obj of-    Just methodStr -> case fromJSON methodStr of-      Success method -> case method of-        -- We can work out the type of the message-        TextDocumentPublishDiagnostics -> NotPublishDiagnostics $ fromJust $ decode bytes-        WindowShowMessage              -> NotShowMessage $ fromJust $ decode bytes-        WindowLogMessage               -> NotLogMessage $ fromJust $ decode bytes-        CancelRequestServer            -> NotCancelRequestFromServer $ fromJust $ decode bytes-        Progress                       ->-          fromJust $ asum [NotWorkDoneProgressBegin <$> decode bytes, NotWorkDoneProgressReport <$> decode bytes, NotWorkDoneProgressEnd <$> decode bytes]-        WindowWorkDoneProgressCreate   -> ReqWorkDoneProgressCreate $ fromJust $ decode bytes-        TelemetryEvent                 -> NotTelemetry $ fromJust $ decode bytes-        WindowShowMessageRequest       -> ReqShowMessage $ fromJust $ decode bytes-        ClientRegisterCapability       -> ReqRegisterCapability $ fromJust $ decode bytes-        ClientUnregisterCapability     -> ReqUnregisterCapability $ fromJust $ decode bytes-        WorkspaceApplyEdit             -> ReqApplyWorkspaceEdit $ fromJust $ decode bytes-        WorkspaceWorkspaceFolders      -> error "ReqWorkspaceFolders not supported yet"-        WorkspaceConfiguration         -> error "ReqWorkspaceConfiguration not supported yet"-        CustomServerMethod _-            | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes-            | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes-            | otherwise -> NotCustomServer $ fromJust $ decode bytes--      Error e -> error e--    Nothing -> case decode bytes :: Maybe (ResponseMessage Value) of-      Just msg -> case HM.lookup (requestId $ msg ^. id) reqMap of-        Just req -> matchResponseMsgType req bytes -- try to decode it to more specific type-        Nothing  -> error "Couldn't match up response with request"-      Nothing -> error "Couldn't decode message"-    where obj = fromJust $ decode bytes :: Object

@@ -1,60 +0,0 @@-module Language.Haskell.LSP.Test.Exceptions where--import Control.Exception-import Language.Haskell.LSP.Messages-import Language.Haskell.LSP.Types-import Data.Aeson-import Data.Aeson.Encode.Pretty-import Data.Algorithm.Diff-import Data.Algorithm.DiffOutput-import Data.List-import qualified Data.ByteString.Lazy.Char8 as B---- | An exception that can be thrown during a 'Haskell.LSP.Test.Session.Session'-data SessionException = Timeout (Maybe FromServerMessage)-                      | NoContentLengthHeader-                      | UnexpectedMessage String FromServerMessage-                      | ReplayOutOfOrder FromServerMessage [FromServerMessage]-                      | UnexpectedDiagnostics-                      | IncorrectApplyEditRequest String-                      | UnexpectedResponseError LspIdRsp ResponseError-                      | UnexpectedServerTermination-                      | IllegalInitSequenceMessage FromServerMessage-  deriving Eq--instance Exception SessionException--instance Show SessionException where-  show (Timeout lastMsg) =-    "Timed out waiting to receive a message from the server." ++-    case lastMsg of-      Just msg -> "\nLast message received:\n" ++ B.unpack (encodePretty msg)-      Nothing -> mempty-  show NoContentLengthHeader = "Couldn't read Content-Length header from the server."-  show (UnexpectedMessage expected lastMsg) =-    "Received an unexpected message from the server:\n" ++-    "Was parsing: " ++ expected ++ "\n" ++-    "Last message received:\n" ++ B.unpack (encodePretty lastMsg)-  show (ReplayOutOfOrder received expected) =-    let expected' = nub expected-        getJsonDiff = lines . B.unpack . encodePretty-        showExp exp = B.unpack (encodePretty exp) ++ "\nDiff:\n" ++-                ppDiff (getGroupedDiff (getJsonDiff received) (getJsonDiff exp))-    in "Replay is out of order:\n" ++-       -- Print json so its a bit easier to update the session logs-       "Received from server:\n" ++ B.unpack (encodePretty received) ++ "\n" ++-       "Raw from server:\n" ++ B.unpack (encode received) ++ "\n" ++-       "Expected one of:\n" ++ unlines (map showExp expected')-  show UnexpectedDiagnostics = "Unexpectedly received diagnostics from the server."-  show (IncorrectApplyEditRequest msgStr) = "ApplyEditRequest didn't contain document, instead received:\n"-                                          ++ msgStr-  show (UnexpectedResponseError lid e) = "Received an exepected error in a response for id " ++ show lid ++ ":\n"-                                          ++ show e-  show UnexpectedServerTermination = "Language server unexpectedly terminated"-  show (IllegalInitSequenceMessage msg) =-    "Received an illegal message between the initialize request and response:\n"-      ++  B.unpack (encodePretty msg)---- | A predicate that matches on any 'SessionException'-anySessionException :: SessionException -> Bool-anySessionException = const True

@@ -1,96 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE OverloadedStrings #-}-module Language.Haskell.LSP.Test.Files-  ( swapFiles-  , rootDir-  )-where--import           Language.Haskell.LSP.Capture-import           Language.Haskell.LSP.Types-import           Language.Haskell.LSP.Types.Lens-import           Language.Haskell.LSP.Messages-import           Control.Lens-import qualified Data.HashMap.Strict           as HM-import qualified Data.Text                     as T-import           Data.Maybe-import           System.Directory-import           System.FilePath--swapFiles :: FilePath -> [Event] -> IO [Event]-swapFiles relCurBaseDir msgs = do-  let capturedBaseDir = rootDir msgs--  curBaseDir <- (</> relCurBaseDir) <$> getCurrentDirectory-  let transform uri =-        let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri)-            newFp = curBaseDir </> makeRelative capturedBaseDir fp-          in filePathToUri newFp-      newMsgs = map (mapUris transform) msgs--  return newMsgs--rootDir :: [Event] -> FilePath-rootDir (FromClient _ (ReqInitialize req):_) =-  fromMaybe (error "Couldn't find root dir") $ do-    rootUri <- req ^. params .rootUri-    uriToFilePath rootUri-rootDir _ = error "Couldn't find initialize request in session"--mapUris :: (Uri -> Uri) -> Event -> Event-mapUris f event =-  case event of-    FromClient t msg -> FromClient t (fromClientMsg msg)-    FromServer t msg -> FromServer t (fromServerMsg msg)--  where-    --TODO: Handle all other URIs that might need swapped-    fromClientMsg (NotDidOpenTextDocument n) = NotDidOpenTextDocument $ swapUri (params . textDocument) n-    fromClientMsg (NotDidChangeTextDocument n) = NotDidChangeTextDocument $ swapUri (params . textDocument) n-    fromClientMsg (NotWillSaveTextDocument n) = NotWillSaveTextDocument $ swapUri (params . textDocument) n-    fromClientMsg (NotDidSaveTextDocument n) = NotDidSaveTextDocument $ swapUri (params . textDocument) n-    fromClientMsg (NotDidCloseTextDocument n) = NotDidCloseTextDocument $ swapUri (params . textDocument) n-    fromClientMsg (ReqInitialize r) = ReqInitialize $ params .~ transformInit (r ^. params) $ r-    fromClientMsg (ReqDocumentSymbols r) = ReqDocumentSymbols $ swapUri (params . textDocument) r-    fromClientMsg (ReqRename r) = ReqRename $ swapUri (params . textDocument) r-    fromClientMsg x = x--    fromServerMsg :: FromServerMessage -> FromServerMessage-    fromServerMsg (ReqApplyWorkspaceEdit r) =-      ReqApplyWorkspaceEdit $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r--    fromServerMsg (NotPublishDiagnostics n) = NotPublishDiagnostics $ swapUri params n--    fromServerMsg (RspDocumentSymbols r) =-      let swapUri' (DSSymbolInformation si) = DSSymbolInformation (swapUri location <$> si)-          swapUri' (DSDocumentSymbols dss) = DSDocumentSymbols dss -- no file locations here-      in RspDocumentSymbols $ r & result %~ (fmap swapUri')--    fromServerMsg (RspRename r) = RspRename $ r & result %~ (fmap swapWorkspaceEdit)--    fromServerMsg x = x--    swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit-    swapWorkspaceEdit e =-      let newDocChanges = fmap (fmap (swapUri textDocument)) $ e ^. documentChanges-          newChanges = fmap (swapKeys f) $ e ^. changes-      in WorkspaceEdit newChanges newDocChanges--    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--    swapUri :: HasUri b Uri => Lens' a b -> a -> a-    swapUri lens x =-      let newUri = f (x ^. lens . uri)-        in (lens . uri) .~ newUri $ x--    -- | Transforms rootUri/rootPath.-    transformInit :: InitializeParams -> InitializeParams-    transformInit x =-      let newRootUri = fmap f (x ^. rootUri)-          newRootPath = do-            fp <- T.unpack <$> x ^. rootPath-            let uri = filePathToUri fp-            T.pack <$> uriToFilePath (f uri)-        in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x

@@ -1,154 +0,0 @@-{-# LANGUAGE RankNTypes #-}-module Language.Haskell.LSP.Test.Messages where--import Data.Aeson-import Language.Haskell.LSP.Messages-import Language.Haskell.LSP.Types--isServerResponse :: FromServerMessage -> Bool-isServerResponse (RspInitialize               _) = True-isServerResponse (RspShutdown                 _) = True-isServerResponse (RspHover                    _) = True-isServerResponse (RspCompletion               _) = True-isServerResponse (RspCompletionItemResolve    _) = True-isServerResponse (RspSignatureHelp            _) = True-isServerResponse (RspDefinition               _) = True-isServerResponse (RspTypeDefinition           _) = True-isServerResponse (RspFindReferences           _) = True-isServerResponse (RspDocumentHighlights       _) = True-isServerResponse (RspDocumentSymbols          _) = True-isServerResponse (RspWorkspaceSymbols         _) = True-isServerResponse (RspCodeAction               _) = True-isServerResponse (RspCodeLens                 _) = True-isServerResponse (RspCodeLensResolve          _) = True-isServerResponse (RspDocumentFormatting       _) = True-isServerResponse (RspDocumentRangeFormatting  _) = True-isServerResponse (RspDocumentOnTypeFormatting _) = True-isServerResponse (RspRename                   _) = True-isServerResponse (RspExecuteCommand           _) = True-isServerResponse (RspError                    _) = True-isServerResponse (RspDocumentLink             _) = True-isServerResponse (RspDocumentLinkResolve      _) = True-isServerResponse (RspWillSaveWaitUntil        _) = True-isServerResponse _                               = False--isServerRequest :: FromServerMessage -> Bool-isServerRequest (ReqRegisterCapability       _) = True-isServerRequest (ReqApplyWorkspaceEdit       _) = True-isServerRequest (ReqShowMessage              _) = True-isServerRequest (ReqUnregisterCapability     _) = True-isServerRequest _                               = False--isServerNotification :: FromServerMessage -> Bool-isServerNotification (NotPublishDiagnostics       _) = True-isServerNotification (NotLogMessage               _) = True-isServerNotification (NotShowMessage              _) = True-isServerNotification (NotTelemetry                _) = True-isServerNotification (NotCancelRequestFromServer  _) = True-isServerNotification _                               = False--handleServerMessage-    :: forall a.-       (forall b c. RequestMessage ServerMethod b c -> a)-    -> (forall d. ResponseMessage d -> a)-    -> (forall e. NotificationMessage ServerMethod e -> a)-    -> FromServerMessage-    -> a-handleServerMessage request response notification msg = case msg of-    (ReqRegisterCapability       m) -> request m-    (ReqApplyWorkspaceEdit       m) -> request m-    (ReqShowMessage              m) -> request m-    (ReqUnregisterCapability     m) -> request m-    (ReqCustomServer             m) -> request m-    (ReqWorkDoneProgressCreate   m) -> request m-    (RspInitialize               m) -> response m-    (RspShutdown                 m) -> response m-    (RspHover                    m) -> response m-    (RspCompletion               m) -> response m-    (RspCompletionItemResolve    m) -> response m-    (RspSignatureHelp            m) -> response m-    (RspDefinition               m) -> response m-    (RspFindReferences           m) -> response m-    (RspDocumentHighlights       m) -> response m-    (RspDocumentSymbols          m) -> response m-    (RspWorkspaceSymbols         m) -> response m-    (RspCodeAction               m) -> response m-    (RspCodeLens                 m) -> response m-    (RspCodeLensResolve          m) -> response m-    (RspDocumentFormatting       m) -> response m-    (RspDocumentRangeFormatting  m) -> response m-    (RspDocumentOnTypeFormatting m) -> response m-    (RspRename                   m) -> response m-    (RspExecuteCommand           m) -> response m-    (RspError                    m) -> response m-    (RspDocumentLink             m) -> response m-    (RspDocumentLinkResolve      m) -> response m-    (RspWillSaveWaitUntil        m) -> response m-    (RspTypeDefinition           m) -> response m-    (RspImplementation           m) -> response m-    (RspDocumentColor            m) -> response m-    (RspColorPresentation        m) -> response m-    (RspFoldingRange             m) -> response m-    (RspCustomServer             m) -> response m-    (NotPublishDiagnostics       m) -> notification m-    (NotLogMessage               m) -> notification m-    (NotShowMessage              m) -> notification m-    (NotWorkDoneProgressBegin    m) -> notification m-    (NotWorkDoneProgressReport   m) -> notification m-    (NotWorkDoneProgressEnd      m) -> notification m-    (NotTelemetry                m) -> notification m-    (NotCancelRequestFromServer  m) -> notification m-    (NotCustomServer             m) -> notification m--handleClientMessage-    :: forall a.-       (forall b c . (ToJSON b, ToJSON c) => RequestMessage ClientMethod b c -> a)-    -> (forall d . ToJSON d => ResponseMessage d -> a)-    -> (forall e . ToJSON e => NotificationMessage ClientMethod e -> a)-    -> FromClientMessage-    -> a-handleClientMessage request response notification msg = case msg of- (ReqInitialize               m) -> request m- (ReqShutdown                 m) -> request m- (ReqHover                    m) -> request m- (ReqCompletion               m) -> request m- (ReqCompletionItemResolve    m) -> request m- (ReqSignatureHelp            m) -> request m- (ReqDefinition               m) -> request m- (ReqFindReferences           m) -> request m- (ReqDocumentHighlights       m) -> request m- (ReqDocumentSymbols          m) -> request m- (ReqWorkspaceSymbols         m) -> request m- (ReqCodeAction               m) -> request m- (ReqCodeLens                 m) -> request m- (ReqCodeLensResolve          m) -> request m- (ReqDocumentFormatting       m) -> request m- (ReqDocumentRangeFormatting  m) -> request m- (ReqDocumentOnTypeFormatting m) -> request m- (ReqPrepareRename            m) -> request m- (ReqRename                   m) -> request m- (ReqExecuteCommand           m) -> request m- (ReqDocumentLink             m) -> request m- (ReqDocumentLinkResolve      m) -> request m- (ReqWillSaveWaitUntil        m) -> request m- (ReqImplementation           m) -> request m- (ReqTypeDefinition           m) -> request m- (ReqDocumentColor            m) -> request m- (ReqColorPresentation        m) -> request m- (ReqFoldingRange             m) -> request m- (RspApplyWorkspaceEdit       m) -> response m- (RspFromClient               m) -> response m- (NotInitialized              m) -> notification m- (NotExit                     m) -> notification m- (NotCancelRequestFromClient  m) -> notification m- (NotDidChangeConfiguration   m) -> notification m- (NotDidOpenTextDocument      m) -> notification m- (NotDidChangeTextDocument    m) -> notification m- (NotDidCloseTextDocument     m) -> notification m- (NotWillSaveTextDocument     m) -> notification m- (NotDidSaveTextDocument      m) -> notification m- (NotDidChangeWatchedFiles    m) -> notification m- (NotDidChangeWorkspaceFolders m) -> notification m- (NotWorkDoneProgressCancel    m) -> notification m- (ReqCustomClient             m) -> request m- (NotCustomClient             m) -> notification m

@@ -1,153 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE OverloadedStrings #-}--module Language.Haskell.LSP.Test.Parsing-  ( -- $receiving-    satisfy-  , satisfyMaybe-  , message-  , anyRequest-  , anyResponse-  , anyNotification-  , anyMessage-  , loggingNotification-  , publishDiagnosticsNotification-  , responseForId-  ) where--import Control.Applicative-import Control.Concurrent-import Control.Lens-import Control.Monad.IO.Class-import Control.Monad-import Data.Aeson-import qualified Data.ByteString.Lazy.Char8 as B-import Data.Conduit.Parser hiding (named)-import qualified Data.Conduit.Parser (named)-import qualified Data.Text as T-import Data.Typeable-import Language.Haskell.LSP.Messages-import Language.Haskell.LSP.Types-import qualified Language.Haskell.LSP.Types.Lens as LSP-import Language.Haskell.LSP.Test.Messages-import Language.Haskell.LSP.Test.Session---- $receiving--- To receive a message, just specify the type that expect:------ @--- msg1 <- message :: Session ApplyWorkspaceEditRequest--- msg2 <- message :: Session HoverResponse--- @------ 'Language.Haskell.LSP.Test.Session' is actually just a parser--- that operates on messages under the hood. This means that you--- can create and combine parsers to match speicifc sequences of--- messages that you expect.------ For example, if you wanted to match either a definition or--- references request:------ > defOrImpl = (message :: Session DefinitionRequest)--- >          <|> (message :: Session ReferencesRequest)------ If you wanted to match any number of telemetry--- notifications immediately followed by a response:------ @--- logThenDiags =---  skipManyTill (message :: Session TelemetryNotification)---               anyResponse--- @---- | Consumes and returns the next message, if it satisfies the specified predicate.------ @since 0.5.2.0-satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage-satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing)---- | Consumes and returns the result of the specified predicate if it returns `Just`.------ @since 0.6.1.0-satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a-satisfyMaybe pred = do--  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)--  x <- Session await--  unless skipTimeout (bumpTimeoutId timeoutId)--  modify $ \s -> s { lastReceivedMessage = Just x }--  case pred x of-    Just a -> do-      logMsg LogServer x-      return a-    Nothing -> empty--named :: T.Text -> Session a -> Session a-named s (Session x) = Session (Data.Conduit.Parser.named s x)---- | Matches a message of type @a@.-message :: forall a. (Typeable a, FromJSON a) => Session a-message =-  let parser = decode . encodeMsg :: FromServerMessage -> Maybe a-  in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $-     satisfyMaybe parser---- | Matches if the message is a notification.-anyNotification :: Session FromServerMessage-anyNotification = named "Any notification" $ satisfy isServerNotification---- | Matches if the message is a request.-anyRequest :: Session FromServerMessage-anyRequest = named "Any request" $ satisfy isServerRequest---- | Matches if the message is a response.-anyResponse :: Session FromServerMessage-anyResponse = named "Any response" $ satisfy isServerResponse---- | Matches a response for a specific id.-responseForId :: forall a. FromJSON a => LspId -> Session (ResponseMessage a)-responseForId lid = named (T.pack $ "Response for id: " ++ show lid) $ do-  let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)-  satisfyMaybe $ \msg -> do-    z <- parser msg-    guard (z ^. LSP.id == responseId lid)-    pure z---- | Matches any type of message.-anyMessage :: Session FromServerMessage-anyMessage = satisfy (const True)---- | A version of encode that encodes FromServerMessages as if they--- weren't wrapped.-encodeMsg :: FromServerMessage -> B.ByteString-encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })---- | Matches if the message is a log message notification or a show message notification/request.-loggingNotification :: Session FromServerMessage-loggingNotification = named "Logging notification" $ satisfy shouldSkip-  where-    shouldSkip (NotLogMessage _) = True-    shouldSkip (NotShowMessage _) = True-    shouldSkip (ReqShowMessage _) = True-    shouldSkip _ = False---- | Matches a 'Language.Haskell.LSP.Test.PublishDiagnosticsNotification'--- (textDocument/publishDiagnostics) notification.-publishDiagnosticsNotification :: Session PublishDiagnosticsNotification-publishDiagnosticsNotification = named "Publish diagnostics notification" $-  satisfyMaybe $ \msg -> case msg of-    NotPublishDiagnostics diags -> Just diags-    _ -> Nothing

@@ -1,237 +0,0 @@--- | A testing tool for replaying captured client logs back to a server,--- and validating that the server output matches up with another log.-module Language.Haskell.LSP.Test.Replay-  ( replaySession-  )-where--import           Prelude hiding (id)-import           Control.Concurrent-import           Control.Monad.IO.Class-import qualified Data.ByteString.Lazy.Char8    as B-import qualified Data.Text                     as T-import           Language.Haskell.LSP.Capture-import           Language.Haskell.LSP.Messages-import           Language.Haskell.LSP.Types-import           Language.Haskell.LSP.Types.Lens as LSP-import           Data.Aeson-import           Data.Default-import           Data.List-import           Data.Maybe-import           Control.Lens hiding (List)-import           Control.Monad-import           System.FilePath-import           System.IO-import           Language.Haskell.LSP.Test-import           Language.Haskell.LSP.Test.Compat-import           Language.Haskell.LSP.Test.Files-import           Language.Haskell.LSP.Test.Decoding-import           Language.Haskell.LSP.Test.Messages-import           Language.Haskell.LSP.Test.Server-import           Language.Haskell.LSP.Test.Session---- | Replays a captured client output and--- makes sure it matches up with an expected response.--- The session directory should have a captured session file in it--- named "session.log".--- You can get these capture files from 'Language.Haskell.LSP.resCaptureFile' in--- haskell-lsp.-replaySession :: String -- ^ The command to run the server.-              -> FilePath -- ^ The recorded session directory.-              -> IO ()-replaySession serverExe sessionDir = do--  entries <- B.lines <$> B.readFile (sessionDir </> "session.log")--  -- decode session-  let unswappedEvents = map (fromJust . decode) entries--  withServer serverExe False $ \serverIn serverOut serverProc -> do--    pid <- getProcessID serverProc-    events <- swapCommands pid <$> swapFiles sessionDir unswappedEvents--    let clientEvents = filter isClientMsg events-        serverEvents = filter isServerMsg events-        clientMsgs = map (\(FromClient _ msg) -> msg) clientEvents-        serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents-        requestMap = getRequestMap clientMsgs--    reqSema <- newEmptyMVar-    rspSema <- newEmptyMVar-    passSema <- newEmptyMVar-    mainThread <- myThreadId--    sessionThread <- liftIO $ forkIO $-      runSessionWithHandles serverIn serverOut serverProc-                            (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread)-                            def-                            fullCaps-                            sessionDir-                            (return ()) -- No finalizer cleanup-                            (sendMessages clientMsgs reqSema rspSema)-    takeMVar passSema-    killThread sessionThread--  where-    isClientMsg (FromClient _ _) = True-    isClientMsg _                = False--    isServerMsg (FromServer _ _) = True-    isServerMsg _                = False--sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session ()-sendMessages [] _ _ = return ()-sendMessages (nextMsg:remainingMsgs) reqSema rspSema =-  handleClientMessage request response notification nextMsg- where-  -- TODO: May need to prevent premature exit notification being sent-  notification msg@(NotificationMessage _ Exit _) = do-    liftIO $ putStrLn "Will send exit notification soon"-    liftIO $ threadDelay 10000000-    sendMessage msg--    liftIO $ error "Done"--  notification msg@(NotificationMessage _ m _) = do-    sendMessage msg--    liftIO $ putStrLn $ "Sent a notification " ++ show m--    sendMessages remainingMsgs reqSema rspSema--  request msg@(RequestMessage _ id m _) = do-    sendRequestMessage msg-    liftIO $ putStrLn $  "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response"--    rsp <- liftIO $ takeMVar rspSema-    when (responseId id /= rsp) $-      error $ "Expected id " ++ show id ++ ", got " ++ show rsp--    sendMessages remainingMsgs reqSema rspSema--  response msg@(ResponseMessage _ id _) = do-    liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server"-    reqId <- liftIO $ takeMVar reqSema-    if responseId reqId /= id-      then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId-      else do-        sendResponse msg-        liftIO $ putStrLn $ "Sent response to request id " ++ show id--    sendMessages remainingMsgs reqSema rspSema--sendRequestMessage :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session ()-sendRequestMessage req = do-  -- Update the request map-  reqMap <- requestMap <$> ask-  liftIO $ modifyMVar_ reqMap $-    \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method)--  sendMessage req---isNotification :: FromServerMessage -> Bool-isNotification (NotPublishDiagnostics      _) = True-isNotification (NotLogMessage              _) = True-isNotification (NotShowMessage             _) = True-isNotification (NotCancelRequestFromServer _) = True-isNotification _                              = False--listenServer :: [FromServerMessage]-             -> RequestMap-             -> MVar LspId-             -> MVar LspIdRsp-             -> MVar ()-             -> ThreadId-             -> Handle-             -> SessionContext-             -> IO ()-listenServer [] _ _ _ passSema _ _ _ = putMVar passSema ()-listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx = do--  msgBytes <- getNextMessage serverOut-  let msg = decodeFromServerMsg reqMap msgBytes--  handleServerMessage request response notification msg--  if shouldSkip msg-    then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut ctx-    else if inRightOrder msg expectedMsgs-      then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx-      else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs-                ++ [head $ dropWhile isNotification expectedMsgs]-               exc = ReplayOutOfOrder msg remainingMsgs-            in liftIO $ throwTo mainThreadId exc--  where-  response :: ResponseMessage a -> IO ()-  response res = do-    putStrLn $ "Got response for id " ++ show (res ^. id)--    putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request--  request :: RequestMessage ServerMethod a b -> IO ()-  request req = do-    putStrLn-      $  "Got request for id "-      ++ show (req ^. id)-      ++ " "-      ++ show (req ^. method)--    putMVar reqSema (req ^. id) -- unblock the handler waiting for a response--  notification :: NotificationMessage ServerMethod a -> IO ()-  notification n = putStrLn $ "Got notification " ++ show (n ^. method)------ TODO: QuickCheck tests?--- | Checks wether or not the message appears in the right order--- @ N1 N2 N3 REQ1 N4 N5 REQ2 RES1 @--- given N2, notification order doesn't matter.--- @ N1 N3 REQ1 N4 N5 REQ2 RES1 @--- given REQ1--- @ N1 N3 N4 N5 REQ2 RES1 @--- given RES1--- @ N1 N3 N4 N5 XXXX RES1 @ False!--- Order of requests and responses matter-inRightOrder :: FromServerMessage -> [FromServerMessage] -> Bool--inRightOrder _ [] = error "Why is this empty"--inRightOrder received (expected : msgs)-  | received == expected               = True-  | isNotification expected            = inRightOrder received msgs-  | otherwise                          = False---- | Ignore logging notifications since they vary from session to session-shouldSkip :: FromServerMessage -> Bool-shouldSkip (NotLogMessage  _) = True-shouldSkip (NotShowMessage _) = True-shouldSkip (ReqShowMessage _) = True-shouldSkip _                  = False---- | Swaps out any commands uniqued with process IDs to match the specified process ID-swapCommands :: Int -> [Event] -> [Event]-swapCommands _ [] = []--swapCommands pid (FromClient t (ReqExecuteCommand req):xs) =  FromClient t (ReqExecuteCommand swapped):swapCommands pid xs-  where swapped = params . command .~ newCmd $ req-        newCmd = swapPid pid (req ^. params . command)--swapCommands pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapCommands pid xs-  where swapped = case newCommands of-          Just cmds -> result . _Right . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp-          Nothing -> rsp-        oldCommands = rsp ^? result . _Right . LSP.capabilities . executeCommandProvider . _Just . commands-        newCommands = fmap (fmap (swapPid pid)) oldCommands--swapCommands pid (x:xs) = x:swapCommands pid xs--hasPid :: T.Text -> Bool-hasPid = (>= 2) . T.length . T.filter (':' ==)-swapPid :: Int -> T.Text -> T.Text-swapPid pid t-  | hasPid t = T.append (T.pack $ show pid) $ T.dropWhile (/= ':') t-  | otherwise = t

@@ -1,22 +0,0 @@-module Language.Haskell.LSP.Test.Server (withServer) where--import Control.Concurrent.Async-import Control.Monad-import Language.Haskell.LSP.Test.Compat-import System.IO-import System.Process hiding (withCreateProcess)--withServer :: String -> Bool -> (Handle -> Handle -> ProcessHandle -> IO a) -> IO a-withServer serverExe logStdErr f = do-  -- TODO Probably should just change runServer to accept-  -- separate command and arguments-  let cmd:args = words serverExe-      createProc = (proc cmd args) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }-  withCreateProcess createProc $ \(Just serverIn) (Just serverOut) (Just serverErr) serverProc -> do-    -- Need to continuously consume to stderr else it gets blocked-    -- Can't pass NoStream either to std_err-    hSetBuffering serverErr NoBuffering-    hSetBinaryMode serverErr True-    let errSinkThread = forever $ hGetLine serverErr >>= when logStdErr . putStrLn-    withAsync errSinkThread $ \_ -> do-      f serverIn serverOut serverProc

@@ -1,441 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}--module Language.Haskell.LSP.Test.Session-  ( Session(..)-  , SessionConfig(..)-  , defaultConfig-  , SessionMessage(..)-  , SessionContext(..)-  , SessionState(..)-  , runSessionWithHandles-  , get-  , put-  , modify-  , modifyM-  , ask-  , asks-  , sendMessage-  , updateState-  , withTimeout-  , getCurTimeoutId-  , bumpTimeoutId-  , logMsg-  , LogMsgType(..)-  )--where--import Control.Applicative-import Control.Concurrent hiding (yield)-import Control.Exception-import Control.Lens hiding (List)-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Except-#if __GLASGOW_HASKELL__ == 806-import Control.Monad.Fail-#endif-import Control.Monad.Trans.Reader (ReaderT, runReaderT)-import qualified Control.Monad.Trans.Reader as Reader (ask)-import Control.Monad.Trans.State (StateT, runStateT)-import qualified Control.Monad.Trans.State as State-import qualified Data.ByteString.Lazy.Char8 as B-import Data.Aeson-import Data.Aeson.Encode.Pretty-import Data.Conduit as Conduit-import Data.Conduit.Parser as Parser-import Data.Default-import Data.Foldable-import Data.List-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Data.HashMap.Strict as HashMap-import Data.Maybe-import Data.Function-import Language.Haskell.LSP.Messages-import Language.Haskell.LSP.Types.Capabilities-import Language.Haskell.LSP.Types-import Language.Haskell.LSP.Types.Lens-import qualified Language.Haskell.LSP.Types.Lens as LSP-import Language.Haskell.LSP.VFS-import Language.Haskell.LSP.Test.Compat-import Language.Haskell.LSP.Test.Decoding-import Language.Haskell.LSP.Test.Exceptions-import System.Console.ANSI-import System.Directory-import System.IO-import System.Process (ProcessHandle())-#ifndef mingw32_HOST_OS-import System.Process (waitForProcess)-#endif-import System.Timeout---- | A session representing one instance of launching and connecting to a server.------ You can send and receive messages to the server within 'Session' via--- 'Language.Haskell.LSP.Test.message',--- 'Language.Haskell.LSP.Test.sendRequest' and--- 'Language.Haskell.LSP.Test.sendNotification'.--newtype Session a = Session (ConduitParser FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) a)-  deriving (Functor, Applicative, Monad, MonadIO, Alternative)--#if __GLASGOW_HASKELL__ >= 806-instance MonadFail Session where-  fail s = do-    lastMsg <- fromJust . lastReceivedMessage <$> get-    liftIO $ throw (UnexpectedMessage s lastMsg)-#endif---- | Stuff you can configure for a 'Session'.-data SessionConfig = SessionConfig-  { messageTimeout :: Int  -- ^ Maximum time to wait for a message in seconds, defaults to 60.-  , logStdErr      :: Bool-  -- ^ Redirect the server's stderr to this stdout, defaults to False.-  -- Can be overriden with @LSP_TEST_LOG_STDERR@.-  , logMessages    :: Bool-  -- ^ Trace the messages sent and received to stdout, defaults to False.-  -- Can be overriden with the environment variable @LSP_TEST_LOG_MESSAGES@.-  , logColor       :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.-  , lspConfig      :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing.-  , ignoreLogNotifications :: Bool-  -- ^ Whether or not to ignore 'Language.Haskell.LSP.Types.ShowMessageNotification' and-  -- 'Language.Haskell.LSP.Types.LogMessageNotification', defaults to False.-  ---  -- @since 0.9.0.0-  }---- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.-defaultConfig :: SessionConfig-defaultConfig = SessionConfig 60 False False True Nothing False--instance Default SessionConfig where-  def = defaultConfig--data SessionMessage = ServerMessage FromServerMessage-                    | TimeoutMessage Int-  deriving Show--data SessionContext = SessionContext-  {-    serverIn :: Handle-  , 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-  , requestMap :: MVar RequestMap-  , initRsp :: MVar InitializeResponse-  , config :: SessionConfig-  , sessionCapabilities :: ClientCapabilities-  }--class Monad m => HasReader r m where-  ask :: m r-  asks :: (r -> b) -> m b-  asks f = f <$> ask--instance HasReader SessionContext Session where-  ask  = Session (lift $ lift Reader.ask)--instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where-  ask = lift $ lift Reader.ask--getCurTimeoutId :: (HasReader SessionContext m, MonadIO m) => m Int-getCurTimeoutId = asks curTimeoutId >>= liftIO . readMVar---- Pass this the timeoutid you *were* waiting on-bumpTimeoutId :: (HasReader SessionContext m, MonadIO m) => Int -> m ()-bumpTimeoutId prev = do-  v <- asks curTimeoutId-  -- when updating the curtimeoutid, account for the fact that something else-  -- might have bumped the timeoutid in the meantime-  liftIO $ modifyMVar_ v (\x -> pure (max x (prev + 1)))--data SessionState = SessionState-  {-    curReqId :: LspId-  , vfs :: VFS-  , curDiagnostics :: Map.Map NormalizedUri [Diagnostic]-  , overridingTimeout :: Bool-  -- ^ The last received message from the server.-  -- Used for providing exception information-  , lastReceivedMessage :: Maybe FromServerMessage-  , curDynCaps :: Map.Map T.Text Registration-  -- ^ The capabilities that the server has dynamically registered with us so-  -- far-  , curProgressSessions :: Set.Set ProgressToken-  }--class Monad m => HasState s m where-  get :: m s--  put :: s -> m ()--  modify :: (s -> s) -> m ()-  modify f = get >>= put . f--  modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()-  modifyM f = get >>= f >>= put--instance HasState SessionState Session where-  get = Session (lift State.get)-  put = Session . lift . State.put--instance Monad m => HasState s (StateT s m) where-  get = State.get-  put = State.put--instance (Monad m, (HasState s m)) => HasState s (ConduitM a b m)- where-  get = lift get-  put = lift . put--instance (Monad m, (HasState s m)) => HasState s (ConduitParser a m)- where-  get = lift get-  put = lift . put--runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)-runSession context state (Session session) = runReaderT (runStateT conduit state) context-  where-    conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)--    handler (Unexpected "ConduitParser.empty") = do-      lastMsg <- fromJust . lastReceivedMessage <$> get-      name <- getParserName-      liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg)--    handler e = throw e--    chanSource = do-      msg <- liftIO $ readChan (messageChan context)-      unless (ignoreLogNotifications (config context) && isLogNotification msg) $-        yield msg-      chanSource--    isLogNotification (ServerMessage (NotShowMessage _)) = True-    isLogNotification (ServerMessage (NotLogMessage _)) = True-    isLogNotification _ = False--    watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()-    watchdog = Conduit.awaitForever $ \msg -> do-      curId <- getCurTimeoutId-      case msg of-        ServerMessage sMsg -> yield sMsg-        TimeoutMessage tId -> when (curId == tId) $ lastReceivedMessage <$> get >>= throw . Timeout---- | An internal version of 'runSession' that allows for a custom handler to listen to the server.--- It also does not automatically send initialize and exit messages.-runSessionWithHandles :: Handle -- ^ Server in-                      -> Handle -- ^ Server out-                      -> ProcessHandle -- ^ Server process-                      -> (Handle -> SessionContext -> IO ()) -- ^ Server listener-                      -> SessionConfig-                      -> ClientCapabilities-                      -> FilePath -- ^ Root directory-                      -> Session () -- ^ To exit the Server properly-                      -> Session a-                      -> IO a-runSessionWithHandles serverIn serverOut serverProc serverHandler config caps rootDir exitServer session = do-  absRootDir <- canonicalizePath rootDir--  hSetBuffering serverIn  NoBuffering-  hSetBuffering serverOut NoBuffering-  -- This is required to make sure that we don’t get any-  -- newline conversion or weird encoding issues.-  hSetBinaryMode serverIn True-  hSetBinaryMode serverOut True--  reqMap <- newMVar newRequestMap-  messageChan <- newChan-  timeoutIdVar <- newMVar 0-  initRsp <- newEmptyMVar--  mainThreadId <- myThreadId--  let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps-      initState vfs = SessionState (IdInt 0) vfs mempty False Nothing mempty mempty-      runSession' ses = initVFS $ \vfs -> runSession context (initState vfs) ses--      errorHandler = throwTo mainThreadId :: SessionException -> IO ()-      serverListenerLauncher =-        forkIO $ catch (serverHandler serverOut context) errorHandler-      server = (Just serverIn, Just serverOut, Nothing, serverProc)-      msgTimeoutMs = messageTimeout config * 10^6-      serverAndListenerFinalizer tid = do-        finally (timeout msgTimeoutMs (runSession' exitServer)) $ do-          -- Make sure to kill the listener first, before closing-          -- handles etc via cleanupProcess-          killThread tid-          -- Give the server some time to exit cleanly-          -- It makes the server hangs in windows so we have to avoid it-#ifndef mingw32_HOST_OS-          timeout msgTimeoutMs (waitForProcess serverProc)-#endif-          cleanupProcess server--  (result, _) <- bracket serverListenerLauncher-                         serverAndListenerFinalizer-                         (const $ runSession' session)-  return result--updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()-updateStateC = awaitForever $ \msg -> do-  updateState msg-  yield msg--updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)-            => FromServerMessage -> m ()-updateState (NotWorkDoneProgressBegin req) =-  modify $ \s -> s { curProgressSessions = Set.insert (req ^. params . token) $ curProgressSessions s }-updateState (NotWorkDoneProgressEnd req) =-  modify $ \s -> s { curProgressSessions = Set.delete (req ^. params . token) $ curProgressSessions s }---- Keep track of dynamic capability registration-updateState (ReqRegisterCapability req) = do-  let List newRegs = (\r -> (r ^. LSP.id, r)) <$> req ^. params . registrations-  modify $ \s ->-    s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) }--updateState (ReqUnregisterCapability req) = do-  let List unRegs = (^. LSP.id) <$> req ^. params . unregistrations-  modify $ \s ->-    let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs-    in s { curDynCaps = newCurDynCaps }--updateState (NotPublishDiagnostics n) = do-  let List diags = n ^. params . diagnostics-      doc = n ^. params . uri-  modify $ \s ->-    let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s)-      in s { curDiagnostics = newDiags }--updateState (ReqApplyWorkspaceEdit r) = do--  -- First, prefer the versioned documentChanges field-  allChangeParams <- case r ^. params . edit . documentChanges of-    Just (List cs) -> do-      mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs-      return $ map getParams cs-    -- Then fall back to the changes field-    Nothing -> case r ^. params . edit . changes of-      Just cs -> do-        mapM_ checkIfNeedsOpened (HashMap.keys cs)-        concat <$> mapM (uncurry getChangeParams) (HashMap.toList cs)-      Nothing ->-        error "WorkspaceEdit contains neither documentChanges nor changes!"--  modifyM $ \s -> do-    newVFS <- liftIO $ changeFromServerVFS (vfs s) r-    return $ s { vfs = newVFS }--  let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams-      mergedParams = map mergeParams groupedParams--  -- TODO: Don't do this when replaying a session-  forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange)--  -- Update VFS to new document versions-  let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams-      latestVersions = map ((^. textDocument) . last) sortedVersions-      bumpedVersions = map (version . _Just +~ 1) latestVersions--  forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->-    modify $ \s ->-      let oldVFS = vfs s-          update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver + 1) t-          newVFS = updateVFS (Map.adjust update (toNormalizedUri uri)) oldVFS-      in s { vfs = newVFS }--  where checkIfNeedsOpened uri = do-          oldVFS <- vfs <$> get-          ctx <- ask--          -- if its not open, open it-          unless (toNormalizedUri uri `Map.member` vfsMap oldVFS) $ do-            let fp = fromJust $ uriToFilePath uri-            contents <- liftIO $ T.readFile fp-            let item = TextDocumentItem (filePathToUri fp) "" 0 contents-                msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)-            liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)--            modifyM $ \s -> do-              let (newVFS,_) = openVFS (vfs s) msg-              return $ s { vfs = newVFS }--        getParams (TextDocumentEdit docId (List edits)) =-          let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits-            in DidChangeTextDocumentParams docId (List changeEvents)--        -- For a uri returns an infinite list of versions [n,n+1,n+2,...]-        -- where n is the current version-        textDocumentVersions uri = do-          m <- vfsMap . vfs <$> get-          let curVer = fromMaybe 0 $-                _lsp_version <$> m Map.!? (toNormalizedUri uri)-          pure $ map (VersionedTextDocumentIdentifier uri . Just) [curVer + 1..]--        textDocumentEdits uri edits = do-          vers <- textDocumentVersions uri-          pure $ map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip vers edits--        getChangeParams uri (List edits) =-          map <$> pure getParams <*> textDocumentEdits uri (reverse edits)--        mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams-        mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))-                              in DidChangeTextDocumentParams (head params ^. textDocument) (List events)-updateState _ = return ()--sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()-sendMessage msg = do-  h <- serverIn <$> ask-  logMsg LogClient msg-  liftIO $ B.hPut h (addHeader $ encode msg)---- | Execute a block f that will throw a 'Language.Haskell.LSP.Test.Exception.Timeout' exception--- after duration seconds. This will override the global timeout--- for waiting for messages to arrive defined in 'SessionConfig'.-withTimeout :: Int -> Session a -> Session a-withTimeout duration f = do-  chan <- asks messageChan-  timeoutId <- getCurTimeoutId-  modify $ \s -> s { overridingTimeout = True }-  liftIO $ forkIO $ do-    threadDelay (duration * 1000000)-    writeChan chan (TimeoutMessage timeoutId)-  res <- f-  bumpTimeoutId timeoutId-  modify $ \s -> s { overridingTimeout = False }-  return res--data LogMsgType = LogServer | LogClient-  deriving Eq---- | Logs the message if the config specified it-logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m)-       => LogMsgType -> a -> m ()-logMsg t msg = do-  shouldLog <- asks $ logMessages . config-  shouldColor <- asks $ logColor . config-  liftIO $ when shouldLog $ do-    when shouldColor $ setSGR [SetColor Foreground Dull color]-    putStrLn $ arrow ++ showPretty msg-    when shouldColor $ setSGR [Reset]--  where arrow-          | t == LogServer  = "<-- "-          | otherwise       = "--> "-        color-          | t == LogServer  = Magenta-          | otherwise       = Cyan--        showPretty = B.unpack . encodePretty

@@ -0,0 +1,727 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExistentialQuantification #-}++{-|+Module      : Language.LSP.Test+Description : A functional testing framework for LSP servers.+Maintainer  : luke_lau@icloud.com+Stability   : experimental+Portability : non-portable++Provides the framework to start functionally testing+<https://github.com/Microsoft/language-server-protocol Language Server Protocol servers>.+You should import "Language.LSP.Types" alongside this.+-}+module Language.LSP.Test+  (+  -- * Sessions+    Session+  , runSession+  , runSessionWithConfig+  , runSessionWithHandles+  -- ** Config+  , SessionConfig(..)+  , defaultConfig+  , C.fullCaps+  -- ** Exceptions+  , module Language.LSP.Test.Exceptions+  , withTimeout+  -- * Sending+  , request+  , request_+  , sendRequest+  , sendNotification+  , sendResponse+  -- * Receving+  , module Language.LSP.Test.Parsing+  -- * Utilities+  -- | Quick helper functions for common tasks.++  -- ** Initialization+  , initializeResponse+  -- ** Documents+  , createDoc+  , openDoc+  , closeDoc+  , changeDoc+  , documentContents+  , getDocumentEdit+  , getDocUri+  , getVersionedDoc+  -- ** Symbols+  , getDocumentSymbols+  -- ** Diagnostics+  , waitForDiagnostics+  , waitForDiagnosticsSource+  , noDiagnostics+  , getCurrentDiagnostics+  , getIncompleteProgressSessions+  -- ** Commands+  , executeCommand+  -- ** Code Actions+  , getCodeActions+  , getAllCodeActions+  , executeCodeAction+  -- ** Completions+  , getCompletions+  -- ** References+  , getReferences+  -- ** Definitions+  , getDeclarations+  , getDefinitions+  , getTypeDefinitions+  , getImplementations+  -- ** Renaming+  , rename+  -- ** Hover+  , getHover+  -- ** Highlights+  , getHighlights+  -- ** Formatting+  , formatDoc+  , formatRange+  -- ** Edits+  , applyEdit+  -- ** Code lenses+  , getCodeLenses+  -- ** Capabilities+  , getRegisteredCapabilities+  ) where++import Control.Applicative.Combinators+import Control.Concurrent+import Control.Monad+import Control.Monad.IO.Class+import Control.Exception+import Control.Lens hiding ((.=), List, Empty)+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+import Data.Aeson+import Data.Default+import qualified Data.HashMap.Strict as HashMap+import Data.List+import Data.Maybe+import Language.LSP.Types+import Language.LSP.Types.Lens hiding+  (id, capabilities, message, executeCommand, applyEdit, rename)+import qualified Language.LSP.Types.Lens as LSP+import qualified Language.LSP.Types.Capabilities as C+import Language.LSP.VFS+import Language.LSP.Test.Compat+import Language.LSP.Test.Decoding+import Language.LSP.Test.Exceptions+import Language.LSP.Test.Parsing+import Language.LSP.Test.Session+import Language.LSP.Test.Server+import System.Environment+import System.IO+import System.Directory+import System.FilePath+import System.Process (ProcessHandle)+import qualified System.FilePath.Glob as Glob++-- | Starts a new session.+--+-- > runSession "hie" fullCaps "path/to/root/dir" $ do+-- >   doc <- openDoc "Desktop/simple.hs" "haskell"+-- >   diags <- waitForDiagnostics+-- >   let pos = Position 12 5+-- >       params = TextDocumentPositionParams doc+-- >   hover <- request STextdocumentHover params+runSession :: String -- ^ The command to run the server.+           -> C.ClientCapabilities -- ^ The capabilities that the client should declare.+           -> FilePath -- ^ The filepath to the root directory for the session.+           -> Session a -- ^ The session to run.+           -> IO a+runSession = runSessionWithConfig def++-- | Starts a new sesion with a custom configuration.+runSessionWithConfig :: SessionConfig -- ^ Configuration options for the session.+                     -> String -- ^ The command to run the server.+                     -> C.ClientCapabilities -- ^ The capabilities that the client should declare.+                     -> FilePath -- ^ The filepath to the root directory for the session.+                     -> Session a -- ^ The session to run.+                     -> IO a+runSessionWithConfig config' serverExe caps rootDir session = do+  config <- envOverrideConfig config'+  withServer serverExe (logStdErr config) $ \serverIn serverOut serverProc ->+    runSessionWithHandles' (Just serverProc) serverIn serverOut config caps rootDir session++-- | Starts a new session, using the specified handles to communicate with the+-- server. You can use this to host the server within the same process.+-- An example with lsp might look like:+--+-- > (hinRead, hinWrite) <- createPipe+-- > (houtRead, houtWrite) <- createPipe+-- > +-- > forkIO $ void $ runServerWithHandles hinRead houtWrite serverDefinition+-- > runSessionWithHandles hinWrite houtRead defaultConfig fullCaps "." $ do+-- >   -- ...+runSessionWithHandles :: Handle -- ^ The input handle+                      -> Handle -- ^ The output handle+                      -> SessionConfig+                      -> C.ClientCapabilities -- ^ The capabilities that the client should declare.+                      -> FilePath -- ^ The filepath to the root directory for the session.+                      -> Session a -- ^ The session to run.+                      -> IO a+runSessionWithHandles = runSessionWithHandles' Nothing+++runSessionWithHandles' :: Maybe ProcessHandle+                       -> Handle -- ^ The input handle+                       -> Handle -- ^ The output handle+                       -> SessionConfig+                       -> C.ClientCapabilities -- ^ The capabilities that the client should declare.+                       -> FilePath -- ^ The filepath to the root directory for the session.+                       -> Session a -- ^ The session to run.+                       -> IO a+runSessionWithHandles' serverProc serverIn serverOut config' caps rootDir session = do+  pid <- getCurrentProcessID+  absRootDir <- canonicalizePath rootDir++  config <- envOverrideConfig config'++  let initializeParams = InitializeParams Nothing+                                          (Just pid)+                                          (Just lspTestClientInfo)+                                          (Just $ T.pack absRootDir)+                                          (Just $ filePathToUri absRootDir)+                                          Nothing+                                          caps+                                          (Just TraceOff)+                                          (List <$> initialWorkspaceFolders config)+  runSession' serverIn serverOut serverProc listenServer config caps rootDir exitServer $ do+    -- Wrap the session around initialize and shutdown calls+    initReqId <- sendRequest SInitialize initializeParams++    -- Because messages can be sent in between the request and response,+    -- collect them and then...+    (inBetween, initRspMsg) <- manyTill_ anyMessage (responseForId SInitialize initReqId)++    case initRspMsg ^. LSP.result of+      Left error -> liftIO $ putStrLn ("Error while initializing: " ++ show error)+      Right _ -> pure ()++    initRspVar <- initRsp <$> ask+    liftIO $ putMVar initRspVar initRspMsg+    sendNotification SInitialized (Just InitializedParams)++    case lspConfig config of+      Just cfg -> sendNotification SWorkspaceDidChangeConfiguration (DidChangeConfigurationParams cfg)+      Nothing -> return ()++    -- ... relay them back to the user Session so they can match on them!+    -- As long as they are allowed.+    forM_ inBetween checkLegalBetweenMessage+    msgChan <- asks messageChan+    liftIO $ writeList2Chan msgChan (ServerMessage <$> inBetween)++    -- Run the actual test+    session+  where+  -- | Asks the server to shutdown and exit politely+  exitServer :: Session ()+  exitServer = request_ SShutdown Empty >> sendNotification SExit Empty++  -- | Listens to the server output until the shutdown ack,+  -- makes sure it matches the record and signals any semaphores+  listenServer :: Handle -> SessionContext -> IO ()+  listenServer serverOut context = do+    msgBytes <- getNextMessage serverOut++    msg <- modifyMVar (requestMap context) $ \reqMap ->+      pure $ decodeFromServerMsg reqMap msgBytes+    writeChan (messageChan context) (ServerMessage msg)++    case msg of+      (FromServerRsp SShutdown _) -> return ()+      _                           -> listenServer serverOut context++  -- | Is this message allowed to be sent by the server between the intialize+  -- request and response?+  -- https://microsoft.github.io/language-server-protocol/specifications/specification-3-15/#initialize+  checkLegalBetweenMessage :: FromServerMessage -> Session ()+  checkLegalBetweenMessage (FromServerMess SWindowShowMessage _) = pure ()+  checkLegalBetweenMessage (FromServerMess SWindowLogMessage _) = pure ()+  checkLegalBetweenMessage (FromServerMess STelemetryEvent _) = pure ()+  checkLegalBetweenMessage (FromServerMess SWindowShowMessageRequest _) = pure ()+  checkLegalBetweenMessage msg = throw (IllegalInitSequenceMessage msg)++-- | Check environment variables to override the config+envOverrideConfig :: SessionConfig -> IO SessionConfig+envOverrideConfig cfg = do+  logMessages' <- fromMaybe (logMessages cfg) <$> checkEnv "LSP_TEST_LOG_MESSAGES"+  logStdErr' <- fromMaybe (logStdErr cfg) <$> checkEnv "LSP_TEST_LOG_STDERR"+  return $ cfg { logMessages = logMessages', logStdErr = logStdErr' }+  where checkEnv :: String -> IO (Maybe Bool)+        checkEnv s = fmap convertVal <$> lookupEnv s+        convertVal "0" = False+        convertVal _ = True++-- | The current text contents of a document.+documentContents :: TextDocumentIdentifier -> Session T.Text+documentContents doc = do+  vfs <- vfs <$> get+  let file = vfsMap vfs Map.! toNormalizedUri (doc ^. uri)+  return (virtualFileText file)++-- | Parses an ApplyEditRequest, checks that it is for the passed document+-- and returns the new content+getDocumentEdit :: TextDocumentIdentifier -> Session T.Text+getDocumentEdit doc = do+  req <- message SWorkspaceApplyEdit++  unless (checkDocumentChanges req || checkChanges req) $+    liftIO $ throw (IncorrectApplyEditRequest (show req))++  documentContents doc+  where+    checkDocumentChanges req =+      let changes = req ^. params . edit . documentChanges+          maybeDocs = fmap (fmap documentChangeUri) changes+      in case maybeDocs of+        Just docs -> (doc ^. uri) `elem` docs+        Nothing -> False+    checkChanges req =+      let mMap = req ^. params . edit . changes+        in maybe False (HashMap.member (doc ^. uri)) mMap++-- | Sends a request to the server and waits for its response.+-- Will skip any messages in between the request and the response+-- @+-- rsp <- request STextDocumentDocumentSymbol params+-- @+-- Note: will skip any messages in between the request and the response.+request :: SClientMethod m -> MessageParams m -> Session (ResponseMessage m)+request m = sendRequest m >=> skipManyTill anyMessage . responseForId m++-- | The same as 'sendRequest', but discard the response.+request_ :: SClientMethod (m :: Method FromClient Request) -> MessageParams m -> Session ()+request_ p = void . request p++-- | Sends a request to the server. Unlike 'request', this doesn't wait for the response.+sendRequest+  :: SClientMethod m -- ^ The request method.+  -> MessageParams m -- ^ The request parameters.+  -> Session (LspId m) -- ^ The id of the request that was sent.+sendRequest method params = do+  idn <- curReqId <$> get+  modify $ \c -> c { curReqId = idn+1 }+  let id = IdInt idn++  let mess = RequestMessage "2.0" id method params++  -- Update the request map+  reqMap <- requestMap <$> ask+  liftIO $ modifyMVar_ reqMap $+    \r -> return $ fromJust $ updateRequestMap r id method++  ~() <- case splitClientMethod method of+    IsClientReq -> sendMessage mess+    IsClientEither -> sendMessage $ ReqMess mess++  return id++-- | Sends a notification to the server.+sendNotification :: SClientMethod (m :: Method FromClient Notification) -- ^ The notification method.+                 -> MessageParams m -- ^ The notification parameters.+                 -> Session ()+-- Open a virtual file if we send a did open text document notification+sendNotification STextDocumentDidOpen params = do+  let n = NotificationMessage "2.0" STextDocumentDidOpen params+  oldVFS <- vfs <$> get+  let (newVFS,_) = openVFS oldVFS n+  modify (\s -> s { vfs = newVFS })+  sendMessage n++-- Close a virtual file if we send a close text document notification+sendNotification STextDocumentDidClose params = do+  let n = NotificationMessage "2.0" STextDocumentDidClose params+  oldVFS <- vfs <$> get+  let (newVFS,_) = closeVFS oldVFS n+  modify (\s -> s { vfs = newVFS })+  sendMessage n++sendNotification STextDocumentDidChange params = do+    let n = NotificationMessage "2.0" STextDocumentDidChange params+    oldVFS <- vfs <$> get+    let (newVFS,_) = changeFromClientVFS oldVFS n+    modify (\s -> s { vfs = newVFS })+    sendMessage n++sendNotification method params =+  case splitClientMethod method of+    IsClientNot -> sendMessage (NotificationMessage "2.0" method params)+    IsClientEither -> sendMessage (NotMess $ NotificationMessage "2.0" method params)++-- | Sends a response to the server.+sendResponse :: ToJSON (ResponseResult m) => ResponseMessage m -> Session ()+sendResponse = sendMessage++-- | Returns the initialize response that was received from the server.+-- The initialize requests and responses are not included the session,+-- so if you need to test it use this.+initializeResponse :: Session (ResponseMessage Initialize)+initializeResponse = ask >>= (liftIO . readMVar) . initRsp++-- | /Creates/ a new text document. This is different from 'openDoc'+-- as it sends a workspace/didChangeWatchedFiles notification letting the server+-- know that a file was created within the workspace, __provided that the server+-- has registered for it__, and the file matches any patterns the server+-- registered for.+-- It /does not/ actually create a file on disk, but is useful for convincing+-- the server that one does exist.+--+-- @since 11.0.0.0+createDoc :: FilePath -- ^ The path to the document to open, __relative to the root directory__.+          -> T.Text -- ^ The text document's language identifier, e.g. @"haskell"@.+          -> T.Text -- ^ The content of the text document to create.+          -> Session TextDocumentIdentifier -- ^ The identifier of the document just created.+createDoc file languageId contents = do+  dynCaps <- curDynCaps <$> get+  rootDir <- asks rootDir+  caps <- asks sessionCapabilities+  absFile <- liftIO $ canonicalizePath (rootDir </> file)+  let pred :: SomeRegistration -> [Registration WorkspaceDidChangeWatchedFiles]+      pred (SomeRegistration r@(Registration _ SWorkspaceDidChangeWatchedFiles _)) = [r]+      pred _ = mempty+      regs = concatMap pred $ Map.elems dynCaps+      watchHits :: FileSystemWatcher -> Bool+      watchHits (FileSystemWatcher pattern kind) =+        -- If WatchKind is exlcuded, defaults to all true as per spec+        fileMatches (T.unpack pattern) && createHits (fromMaybe (WatchKind True True True) kind)++      fileMatches pattern = Glob.match (Glob.compile pattern) relOrAbs+        -- If the pattern is absolute then match against the absolute fp+        where relOrAbs+                | isAbsolute pattern = absFile+                | otherwise = file++      createHits (WatchKind create _ _) = create++      regHits :: Registration WorkspaceDidChangeWatchedFiles -> Bool+      regHits reg = foldl' (\acc w -> acc || watchHits w) False (reg ^. registerOptions . watchers)++      clientCapsSupports =+          caps ^? workspace . _Just . didChangeWatchedFiles . _Just . dynamicRegistration . _Just+            == Just True+      shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs++  when shouldSend $+    sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $+      List [ FileEvent (filePathToUri (rootDir </> file)) FcCreated ]+  openDoc' file languageId contents++-- | Opens a text document that /exists on disk/, and sends a+-- textDocument/didOpen notification to the server.+openDoc :: FilePath -> T.Text -> Session TextDocumentIdentifier+openDoc file languageId = do+  context <- ask+  let fp = rootDir context </> file+  contents <- liftIO $ T.readFile fp+  openDoc' file languageId contents++-- | This is a variant of `openDoc` that takes the file content as an argument.+-- Use this is the file exists /outside/ of the current workspace.+openDoc' :: FilePath -> T.Text -> T.Text -> Session TextDocumentIdentifier+openDoc' file languageId contents = do+  context <- ask+  let fp = rootDir context </> file+      uri = filePathToUri fp+      item = TextDocumentItem uri languageId 0 contents+  sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams item)+  pure $ TextDocumentIdentifier uri++-- | Closes a text document and sends a textDocument/didOpen notification to the server.+closeDoc :: TextDocumentIdentifier -> Session ()+closeDoc docId = do+  let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))+  sendNotification STextDocumentDidClose params++-- | Changes a text document and sends a textDocument/didOpen notification to the server.+changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session ()+changeDoc docId changes = do+  verDoc <- getVersionedDoc docId+  let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes)+  sendNotification STextDocumentDidChange params++-- | Gets the Uri for the file corrected to the session directory.+getDocUri :: FilePath -> Session Uri+getDocUri file = do+  context <- ask+  let fp = rootDir context </> file+  return $ filePathToUri fp++-- | Waits for diagnostics to be published and returns them.+waitForDiagnostics :: Session [Diagnostic]+waitForDiagnostics = do+  diagsNot <- skipManyTill anyMessage (message STextDocumentPublishDiagnostics)+  let (List diags) = diagsNot ^. params . LSP.diagnostics+  return diags++-- | The same as 'waitForDiagnostics', but will only match a specific+-- 'Language.LSP.Types._source'.+waitForDiagnosticsSource :: String -> Session [Diagnostic]+waitForDiagnosticsSource src = do+  diags <- waitForDiagnostics+  let res = filter matches diags+  if null res+    then waitForDiagnosticsSource src+    else return res+  where+    matches :: Diagnostic -> Bool+    matches d = d ^. source == Just (T.pack src)++-- | Expects a 'PublishDiagnosticsNotification' and throws an+-- 'UnexpectedDiagnostics' exception if there are any diagnostics+-- returned.+noDiagnostics :: Session ()+noDiagnostics = do+  diagsNot <- message STextDocumentPublishDiagnostics+  when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics++-- | Returns the symbols in a document.+getDocumentSymbols :: TextDocumentIdentifier -> Session (Either [DocumentSymbol] [SymbolInformation])+getDocumentSymbols doc = do+  ResponseMessage _ rspLid res <- request STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc)+  case res of+    Right (InL (List xs)) -> return (Left xs)+    Right (InR (List xs)) -> return (Right xs)+    Left err -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) err)++-- | Returns the code actions in the specified range.+getCodeActions :: TextDocumentIdentifier -> Range -> Session [Command |? CodeAction]+getCodeActions doc range = do+  ctx <- getCodeActionContext doc+  rsp <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc range ctx)++  case rsp ^. result of+    Right (List xs) -> return xs+    Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) error)++-- | Returns all the code actions in a document by+-- querying the code actions at each of the current+-- diagnostics' positions.+getAllCodeActions :: TextDocumentIdentifier -> Session [Command |? CodeAction]+getAllCodeActions doc = do+  ctx <- getCodeActionContext doc++  foldM (go ctx) [] =<< getCurrentDiagnostics doc++  where+    go :: CodeActionContext -> [Command |? CodeAction] -> Diagnostic -> Session [Command |? CodeAction]+    go ctx acc diag = do+      ResponseMessage _ rspLid res <- request STextDocumentCodeAction (CodeActionParams Nothing Nothing doc (diag ^. range) ctx)++      case res of+        Left e -> throw (UnexpectedResponseError (SomeLspId $ fromJust rspLid) e)+        Right (List cmdOrCAs) -> pure (acc ++ cmdOrCAs)++getCodeActionContext :: TextDocumentIdentifier -> Session CodeActionContext+getCodeActionContext doc = do+  curDiags <- getCurrentDiagnostics doc+  return $ CodeActionContext (List curDiags) Nothing++-- | Returns the current diagnostics that have been sent to the client.+-- Note that this does not wait for more to come in.+getCurrentDiagnostics :: TextDocumentIdentifier -> Session [Diagnostic]+getCurrentDiagnostics doc = fromMaybe [] . Map.lookup (toNormalizedUri $ doc ^. uri) . curDiagnostics <$> get++-- | Returns the tokens of all progress sessions that have started but not yet ended.+getIncompleteProgressSessions :: Session (Set.Set ProgressToken)+getIncompleteProgressSessions = curProgressSessions <$> get++-- | Executes a command.+executeCommand :: Command -> Session ()+executeCommand cmd = do+  let args = decode $ encode $ fromJust $ cmd ^. arguments+      execParams = ExecuteCommandParams Nothing (cmd ^. command) args+  void $ sendRequest SWorkspaceExecuteCommand execParams++-- | Executes a code action.+-- Matching with the specification, if a code action+-- contains both an edit and a command, the edit will+-- be applied first.+executeCodeAction :: CodeAction -> Session ()+executeCodeAction action = do+  maybe (return ()) handleEdit $ action ^. edit+  maybe (return ()) executeCommand $ action ^. command++  where handleEdit :: WorkspaceEdit -> Session ()+        handleEdit e =+          -- Its ok to pass in dummy parameters here as they aren't used+          let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing e)+            in updateState (FromServerMess SWorkspaceApplyEdit req)++-- | Adds the current version to the document, as tracked by the session.+getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier+getVersionedDoc (TextDocumentIdentifier uri) = do+  fs <- vfsMap . vfs <$> get+  let ver =+        case fs Map.!? toNormalizedUri uri of+          Just vf -> Just (virtualFileVersion vf)+          _ -> Nothing+  return (VersionedTextDocumentIdentifier uri ver)++-- | Applys an edit to the document and returns the updated document version.+applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier+applyEdit doc edit = do++  verDoc <- getVersionedDoc doc++  caps <- asks sessionCapabilities++  let supportsDocChanges = fromMaybe False $ do+        let mWorkspace = caps ^. LSP.workspace+        C.WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace+        C.WorkspaceEditClientCapabilities mDocChanges _ _ <- mEdit+        mDocChanges++  let wEdit = if supportsDocChanges+      then+        let docEdit = TextDocumentEdit verDoc (List [edit])+        in WorkspaceEdit Nothing (Just (List [InL docEdit]))+      else+        let changes = HashMap.singleton (doc ^. uri) (List [edit])+        in WorkspaceEdit (Just changes) Nothing++  let req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)+  updateState (FromServerMess SWorkspaceApplyEdit req)++  -- version may have changed+  getVersionedDoc doc++-- | Returns the completions for the position in the document.+getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem]+getCompletions doc pos = do+  rsp <- request STextDocumentCompletion (CompletionParams doc pos Nothing Nothing Nothing)++  case getResponseResult rsp of+    InL (List items) -> return items+    InR (CompletionList _ (List items)) -> return items++-- | Returns the references for the position in the document.+getReferences :: TextDocumentIdentifier -- ^ The document to lookup in.+              -> Position -- ^ The position to lookup.+              -> Bool -- ^ Whether to include declarations as references.+              -> Session (List Location) -- ^ The locations of the references.+getReferences doc pos inclDecl =+  let ctx = ReferenceContext inclDecl+      params = ReferenceParams doc pos Nothing Nothing ctx+  in getResponseResult <$> request STextDocumentReferences params++-- | Returns the declarations(s) for the term at the specified position.+getDeclarations :: TextDocumentIdentifier -- ^ The document the term is in.+                -> Position -- ^ The position the term is at.+                -> Session ([Location] |? [LocationLink])+getDeclarations = getDeclarationyRequest STextDocumentDeclaration DeclarationParams++-- | Returns the definition(s) for the term at the specified position.+getDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.+               -> Position -- ^ The position the term is at.+               -> Session ([Location] |? [LocationLink])+getDefinitions = getDeclarationyRequest STextDocumentDefinition DefinitionParams++-- | Returns the type definition(s) for the term at the specified position.+getTypeDefinitions :: TextDocumentIdentifier -- ^ The document the term is in.+                   -> Position -- ^ The position the term is at.+                   -> Session ([Location] |? [LocationLink])+getTypeDefinitions = getDeclarationyRequest STextDocumentTypeDefinition TypeDefinitionParams ++-- | Returns the type definition(s) for the term at the specified position.+getImplementations :: TextDocumentIdentifier -- ^ The document the term is in.+                   -> Position -- ^ The position the term is at.+                   -> Session ([Location] |? [LocationLink])+getImplementations = getDeclarationyRequest STextDocumentImplementation ImplementationParams+++getDeclarationyRequest :: (ResponseResult m ~ (Location |? (List Location |? List LocationLink)))+                       => SClientMethod m+                       -> (TextDocumentIdentifier+                            -> Position+                            -> Maybe ProgressToken+                            -> Maybe ProgressToken+                            -> MessageParams m)+                       -> TextDocumentIdentifier+                       -> Position+                       -> Session ([Location] |? [LocationLink])+getDeclarationyRequest method paramCons doc pos = do+  let params = paramCons doc pos Nothing Nothing+  rsp <- request method params+  case getResponseResult rsp of+      InL loc -> pure (InL [loc])+      InR (InL (List locs)) -> pure (InL locs)+      InR (InR (List locLinks)) -> pure (InR locLinks)++-- | Renames the term at the specified position.+rename :: TextDocumentIdentifier -> Position -> String -> Session ()+rename doc pos newName = do+  let params = RenameParams doc pos Nothing (T.pack newName)+  rsp <- request STextDocumentRename params+  let wEdit = getResponseResult rsp+      req = RequestMessage "" (IdInt 0) SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wEdit)+  updateState (FromServerMess SWorkspaceApplyEdit req)++-- | Returns the hover information at the specified position.+getHover :: TextDocumentIdentifier -> Position -> Session (Maybe Hover)+getHover doc pos =+  let params = HoverParams doc pos Nothing+  in getResponseResult <$> request STextDocumentHover params++-- | Returns the highlighted occurences of the term at the specified position+getHighlights :: TextDocumentIdentifier -> Position -> Session (List DocumentHighlight)+getHighlights doc pos =+  let params = DocumentHighlightParams doc pos Nothing Nothing+  in getResponseResult <$> request STextDocumentDocumentHighlight params++-- | Checks the response for errors and throws an exception if needed.+-- Returns the result if successful.+getResponseResult :: ResponseMessage m -> ResponseResult m+getResponseResult rsp =+  case rsp ^. result of+    Right x -> x+    Left err -> throw $ UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. LSP.id) err++-- | Applies formatting to the specified document.+formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()+formatDoc doc opts = do+  let params = DocumentFormattingParams Nothing doc opts+  edits <- getResponseResult <$> request STextDocumentFormatting params+  applyTextEdits doc edits++-- | Applies formatting to the specified range in a document.+formatRange :: TextDocumentIdentifier -> FormattingOptions -> Range -> Session ()+formatRange doc opts range = do+  let params = DocumentRangeFormattingParams Nothing doc range opts+  edits <- getResponseResult <$> request STextDocumentRangeFormatting params+  applyTextEdits doc edits++applyTextEdits :: TextDocumentIdentifier -> List TextEdit -> Session ()+applyTextEdits doc edits =+  let wEdit = WorkspaceEdit (Just (HashMap.singleton (doc ^. uri) edits)) 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)++-- | Returns the code lenses for the specified document.+getCodeLenses :: TextDocumentIdentifier -> Session [CodeLens]+getCodeLenses tId = do+    rsp <- request STextDocumentCodeLens (CodeLensParams Nothing Nothing tId)+    case getResponseResult rsp of+        List res -> pure res++-- | Returns a list of capabilities that the server has requested to /dynamically/+-- register during the 'Session'.+--+-- @since 0.11.0.0+getRegisteredCapabilities :: Session [SomeRegistration]+getRegisteredCapabilities = Map.elems . curDynCaps <$> get

@@ -0,0 +1,120 @@+{-# LANGUAGE CPP, OverloadedStrings #-}+-- For some reason ghc warns about not using+-- Control.Monad.IO.Class but it's needed for+-- MonadIO+{-# OPTIONS_GHC -Wunused-imports #-}+module Language.LSP.Test.Compat where++import Data.Maybe+import System.IO+import Language.LSP.Types++#if MIN_VERSION_process(1,6,3)+-- We have to hide cleanupProcess for process-1.6.3.0+-- cause it is in the public api for 1.6.3.0 versions+-- shipped with ghc >= 8.6 and < 8.6.4+import System.Process hiding (getPid, cleanupProcess, withCreateProcess)+# if MIN_VERSION_process(1,6,4)+import qualified System.Process (getPid, cleanupProcess, withCreateProcess)+# else+import Foreign.C.Error+import GHC.IO.Exception ( IOErrorType(..), IOException(..) )++import qualified System.Process (getPid)+import qualified Control.Exception as C+# endif+#else+import Control.Concurrent.MVar+import Foreign.C.Error+import GHC.IO.Exception ( IOErrorType(..), IOException(..) )+import System.Process hiding (withCreateProcess)+import System.Process.Internals++import qualified Control.Exception as C+#endif++#ifdef mingw32_HOST_OS+import qualified System.Win32.Process+#else+import qualified System.Posix.Process+#endif+++getCurrentProcessID :: IO Int+#ifdef mingw32_HOST_OS+getCurrentProcessID = fromIntegral <$> System.Win32.Process.getCurrentProcessId+#else+getCurrentProcessID = fromIntegral <$> System.Posix.Process.getProcessID+#endif++getProcessID :: ProcessHandle -> IO Int+getProcessID p = fromIntegral . fromJust <$> getProcessID' p+  where+#if MIN_VERSION_process(1,6,3)+  getProcessID' = System.Process.getPid+#else+#if MIN_VERSION_process(1,6,0)+  getProcessID' (ProcessHandle mh _ _) = do+#else+  getProcessID' (ProcessHandle mh _) = do+#endif+    p_ <- readMVar mh+    case p_ of+#ifdef mingw32_HOST_OS+      OpenHandle h -> do+        pid <- System.Win32.Process.getProcessId h+        return $ Just pid+#else+      OpenHandle pid -> return $ Just pid+#endif+      _ -> return Nothing+#endif++cleanupProcess+  :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()++withCreateProcess+  :: CreateProcess+  -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)+  -> IO a++#if MIN_VERSION_process(1,6,4)++cleanupProcess = System.Process.cleanupProcess++withCreateProcess = System.Process.withCreateProcess++#else++cleanupProcess (mb_stdin, mb_stdout, mb_stderr, ph) = do+    -- We ignore the spurious "permission denied" error in windows:+    --   see https://github.com/haskell/process/issues/110+    ignorePermDenied $ terminateProcess ph+    -- Note, it's important that other threads that might be reading/writing+    -- these handles also get killed off, since otherwise they might be holding+    -- the handle lock and prevent us from closing, leading to deadlock.+    maybe (return ()) (ignoreSigPipe . hClose) mb_stdin+    maybe (return ()) hClose mb_stdout+    maybe (return ()) hClose mb_stderr++    return ()+  where ignoreSigPipe = ignoreIOError ResourceVanished ePIPE+        ignorePermDenied = ignoreIOError PermissionDenied eACCES+    +ignoreIOError :: IOErrorType -> Errno -> IO () -> IO ()+ignoreIOError ioErrorType errno =+  C.handle $ \e -> case e of+                     IOError { ioe_type  = iot+                             , ioe_errno = Just ioe }+                       | iot == ioErrorType && Errno ioe == errno -> return ()+                     _ -> C.throwIO e++withCreateProcess c action =+  C.bracket (createProcess c) cleanupProcess+            (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)++#endif+++lspTestClientInfo :: ClientInfo+lspTestClientInfo = ClientInfo "lsp-test" (Just CURRENT_PACKAGE_VERSION)

@@ -0,0 +1,104 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeInType #-}+module Language.LSP.Test.Decoding where++import           Prelude                 hiding ( id )+import           Data.Aeson+import           Data.Aeson.Types+import           Data.Foldable+import           Data.Functor.Product+import           Data.Functor.Const+import           Control.Exception+import           Control.Lens+import qualified Data.ByteString.Lazy.Char8    as B+import           Data.Maybe+import           System.IO+import           System.IO.Error+import           Language.LSP.Types+import           Language.LSP.Types.Lens+import           Language.LSP.Test.Exceptions++import Data.IxMap+import Data.Kind++getAllMessages :: Handle -> IO [B.ByteString]+getAllMessages h = do+  done <- hIsEOF h+  if done+    then return []+    else do+      msg <- getNextMessage h++      (msg :) <$> getAllMessages h++-- | Fetches the next message bytes based on+-- the Content-Length header+getNextMessage :: Handle -> IO B.ByteString+getNextMessage h = do+  headers <- getHeaders h+  case read . init <$> lookup "Content-Length" headers of+    Nothing   -> throw NoContentLengthHeader+    Just size -> B.hGet h size++addHeader :: B.ByteString -> B.ByteString+addHeader content = B.concat+  [ "Content-Length: "+  , B.pack $ show $ B.length content+  , "\r\n"+  , "\r\n"+  , content+  ]++getHeaders :: Handle -> IO [(String, String)]+getHeaders h = do+  l <- catch (hGetLine h) eofHandler+  let (name, val) = span (/= ':') l+  if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h+  where eofHandler e+          | isEOFError e = throw UnexpectedServerTermination+          | otherwise = throw e++type RequestMap = IxMap LspId (SMethod :: Method FromClient Request -> Type )++newRequestMap :: RequestMap+newRequestMap = emptyIxMap++updateRequestMap :: RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap+updateRequestMap reqMap id method = insertIxMap id method reqMap++getRequestMap :: [FromClientMessage] -> RequestMap+getRequestMap = foldl' helper emptyIxMap+ where+  helper :: RequestMap -> FromClientMessage -> RequestMap+  helper acc msg = case msg of+    FromClientMess m mess -> case splitClientMethod m of+      IsClientNot -> acc+      IsClientReq -> fromJust $ updateRequestMap acc (mess ^. id) m+      IsClientEither -> case mess of+        NotMess _ -> acc+        ReqMess msg -> fromJust $ updateRequestMap acc (msg ^. id) m+    _ -> acc++decodeFromServerMsg :: RequestMap -> B.ByteString -> (RequestMap, FromServerMessage)+decodeFromServerMsg reqMap bytes = unP $ fromJust $ parseMaybe p obj+  where obj = fromJust $ decode bytes :: Value+        p = parseServerMessage $ \lid ->+          let (mm, newMap) = pickFromIxMap lid reqMap+            in case mm of+              Nothing -> Nothing+              Just m -> Just $ (m, Pair m (Const newMap))+        unP (FromServerMess m msg) = (reqMap, FromServerMess m msg)+        unP (FromServerRsp (Pair m (Const newMap)) msg) = (newMap, FromServerRsp m msg)+        {-+        WorkspaceWorkspaceFolders      -> error "ReqWorkspaceFolders not supported yet"+        WorkspaceConfiguration         -> error "ReqWorkspaceConfiguration not supported yet"+        CustomServerMethod _+            | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes+            | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes+            | otherwise -> NotCustomServer $ fromJust $ decode bytes++      Error e -> error e+      -}

@@ -0,0 +1,59 @@+module Language.LSP.Test.Exceptions where++import Control.Exception+import Language.LSP.Types+import Data.Aeson+import Data.Aeson.Encode.Pretty+import Data.Algorithm.Diff+import Data.Algorithm.DiffOutput+import Data.List+import qualified Data.ByteString.Lazy.Char8 as B++-- | An exception that can be thrown during a 'Haskell.LSP.Test.Session.Session'+data SessionException = Timeout (Maybe FromServerMessage)+                      | NoContentLengthHeader+                      | UnexpectedMessage String FromServerMessage+                      | ReplayOutOfOrder FromServerMessage [FromServerMessage]+                      | UnexpectedDiagnostics+                      | IncorrectApplyEditRequest String+                      | UnexpectedResponseError SomeLspId  ResponseError+                      | UnexpectedServerTermination+                      | IllegalInitSequenceMessage FromServerMessage+  deriving Eq++instance Exception SessionException++instance Show SessionException where+  show (Timeout lastMsg) =+    "Timed out waiting to receive a message from the server." +++    case lastMsg of+      Just msg -> "\nLast message received:\n" ++ B.unpack (encodePretty msg)+      Nothing -> mempty+  show NoContentLengthHeader = "Couldn't read Content-Length header from the server."+  show (UnexpectedMessage expected lastMsg) =+    "Received an unexpected message from the server:\n" +++    "Was parsing: " ++ expected ++ "\n" +++    "But the last message received was:\n" ++ B.unpack (encodePretty lastMsg)+  show (ReplayOutOfOrder received expected) =+    let expected' = nub expected+        getJsonDiff = lines . B.unpack . encodePretty+        showExp exp = B.unpack (encodePretty exp) ++ "\nDiff:\n" +++                ppDiff (getGroupedDiff (getJsonDiff received) (getJsonDiff exp))+    in "Replay is out of order:\n" +++       -- Print json so its a bit easier to update the session logs+       "Received from server:\n" ++ B.unpack (encodePretty received) ++ "\n" +++       "Raw from server:\n" ++ B.unpack (encode received) ++ "\n" +++       "Expected one of:\n" ++ unlines (map showExp expected')+  show UnexpectedDiagnostics = "Unexpectedly received diagnostics from the server."+  show (IncorrectApplyEditRequest msgStr) = "ApplyEditRequest didn't contain document, instead received:\n"+                                          ++ msgStr+  show (UnexpectedResponseError lid e) = "Received an exepected error in a response for id " ++ show lid ++ ":\n"+                                          ++ show e+  show UnexpectedServerTermination = "Language server unexpectedly terminated"+  show (IllegalInitSequenceMessage msg) =+    "Received an illegal message between the initialize request and response:\n"+      ++  B.unpack (encodePretty msg)++-- | A predicate that matches on any 'SessionException'+anySessionException :: SessionException -> Bool+anySessionException = const True

@@ -0,0 +1,105 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+module Language.LSP.Test.Files+  ( swapFiles+  , rootDir+  )+where++import           Language.LSP.Types+import           Language.LSP.Types.Lens hiding (id)+import           Control.Lens+import qualified Data.HashMap.Strict           as HM+import qualified Data.Text                     as T+import           Data.Maybe+import           System.Directory+import           System.FilePath+import Data.Time.Clock++data Event+  = ClientEv UTCTime FromClientMessage+  | ServerEv UTCTime FromServerMessage++swapFiles :: FilePath -> [Event] -> IO [Event]+swapFiles relCurBaseDir msgs = do+  let capturedBaseDir = rootDir msgs++  curBaseDir <- (</> relCurBaseDir) <$> getCurrentDirectory+  let transform uri =+        let fp = fromMaybe (error "Couldn't transform uri") (uriToFilePath uri)+            newFp = curBaseDir </> makeRelative capturedBaseDir fp+          in filePathToUri newFp+      newMsgs = map (mapUris transform) msgs++  return newMsgs++rootDir :: [Event] -> FilePath+rootDir (ClientEv _ (FromClientMess SInitialize req):_) =+  fromMaybe (error "Couldn't find root dir") $ do+    rootUri <- req ^. params .rootUri+    uriToFilePath rootUri+rootDir _ = error "Couldn't find initialize request in session"++mapUris :: (Uri -> Uri) -> Event -> Event+mapUris f event =+  case event of+    ClientEv t msg -> ClientEv t (fromClientMsg msg)+    ServerEv t msg -> ServerEv t (fromServerMsg msg)++  where+    --TODO: Handle all other URIs that might need swapped+    fromClientMsg (FromClientMess m@SInitialize                 r) = FromClientMess m $ params .~ transformInit (r ^. params) $ r+    fromClientMsg (FromClientMess m@STextDocumentDidOpen        n) = FromClientMess m $ swapUri (params . textDocument) n+    fromClientMsg (FromClientMess m@STextDocumentDidChange      n) = FromClientMess m $ swapUri (params . textDocument) n+    fromClientMsg (FromClientMess m@STextDocumentWillSave       n) = FromClientMess m $ swapUri (params . textDocument) n+    fromClientMsg (FromClientMess m@STextDocumentDidSave        n) = FromClientMess m $ swapUri (params . textDocument) n+    fromClientMsg (FromClientMess m@STextDocumentDidClose       n) = FromClientMess m $ swapUri (params . textDocument) n+    fromClientMsg (FromClientMess m@STextDocumentDocumentSymbol n) = FromClientMess m $ swapUri (params . textDocument) n+    fromClientMsg (FromClientMess m@STextDocumentRename         n) = FromClientMess m $ swapUri (params . textDocument) n+    fromClientMsg x = x++    fromServerMsg :: FromServerMessage -> FromServerMessage+    fromServerMsg (FromServerMess m@SWorkspaceApplyEdit r) = FromServerMess m $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r+    fromServerMsg (FromServerMess m@STextDocumentPublishDiagnostics n) = FromServerMess m $ swapUri params n+    fromServerMsg (FromServerRsp m@STextDocumentDocumentSymbol r) =+      let swapUri' :: (List DocumentSymbol |? List SymbolInformation) -> List DocumentSymbol |? List SymbolInformation+          swapUri' (InR si) = InR (swapUri location <$> si)+          swapUri' (InL dss) = InL dss -- no file locations here+      in FromServerRsp m $ r & result %~ (fmap swapUri')+    fromServerMsg (FromServerRsp m@STextDocumentRename r) = FromServerRsp m $ r & result %~ (fmap swapWorkspaceEdit)+    fromServerMsg x = x++    swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit+    swapWorkspaceEdit e =+      let swapDocumentChangeUri :: DocumentChange -> DocumentChange+          swapDocumentChangeUri (InL textDocEdit) = InL $ swapUri textDocument textDocEdit+          swapDocumentChangeUri (InR (InL createFile)) = InR $ InL $ swapUri id createFile+          -- for RenameFile, we swap `newUri`+          swapDocumentChangeUri (InR (InR (InL renameFile))) = InR $ InR $ InL $ newUri .~ f (renameFile ^. newUri) $ renameFile+          swapDocumentChangeUri (InR (InR (InR deleteFile))) = InR $ InR $ InR $ swapUri id deleteFile++          newDocChanges = fmap (fmap swapDocumentChangeUri) $ e ^. documentChanges+          newChanges = fmap (swapKeys f) $ e ^. changes+       in WorkspaceEdit newChanges newDocChanges++    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++    swapUri :: HasUri b Uri => Lens' a b -> a -> a+    swapUri lens x =+      let newUri = f (x ^. lens . uri)+        in (lens . uri) .~ newUri $ x++    -- | Transforms rootUri/rootPath.+    transformInit :: InitializeParams -> InitializeParams+    transformInit x =+      let newRootUri = fmap f (x ^. rootUri)+          newRootPath = do+            fp <- T.unpack <$> x ^. rootPath+            let uri = filePathToUri fp+            T.pack <$> uriToFilePath (f uri)+        in (rootUri .~ newRootUri) $ (rootPath .~ newRootPath) x

@@ -0,0 +1,207 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.LSP.Test.Parsing+  ( -- $receiving+    satisfy+  , satisfyMaybe+  , message+  , response+  , responseForId+  , customRequest+  , customNotification+  , anyRequest+  , anyResponse+  , anyNotification+  , anyMessage+  , loggingNotification+  , publishDiagnosticsNotification+  ) where++import Control.Applicative+import Control.Concurrent+import Control.Monad.IO.Class+import Control.Monad+import Data.Conduit.Parser hiding (named)+import qualified Data.Conduit.Parser (named)+import qualified Data.Text as T+import Data.Typeable+import Language.LSP.Types+import Language.LSP.Test.Session++-- $receiving+-- To receive a message, specify the method of the message to expect:+--+-- @+-- msg1 <- message SWorkspaceApplyEdit+-- msg2 <- message STextDocumentHover+-- @+--+-- 'Language.LSP.Test.Session' is actually just a parser+-- that operates on messages under the hood. This means that you+-- can create and combine parsers to match speicifc sequences of+-- messages that you expect.+--+-- For example, if you wanted to match either a definition or+-- references request:+--+-- > defOrImpl = message STextDocumentDefinition+-- >          <|> message STextDocumentReferences+--+-- If you wanted to match any number of telemetry+-- notifications immediately followed by a response:+--+-- @+-- logThenDiags =+--  skipManyTill (message STelemetryEvent)+--               anyResponse+-- @++-- | Consumes and returns the next message, if it satisfies the specified predicate.+--+-- @since 0.5.2.0+satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage+satisfy pred = satisfyMaybe (\msg -> if pred msg then Just msg else Nothing)++-- | Consumes and returns the result of the specified predicate if it returns `Just`.+--+-- @since 0.6.1.0+satisfyMaybe :: (FromServerMessage -> Maybe a) -> Session a+satisfyMaybe pred = satisfyMaybeM (pure . pred)++satisfyMaybeM :: (FromServerMessage -> Session (Maybe a)) -> Session a+satisfyMaybeM pred = do +  +  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)++  x <- Session await++  unless skipTimeout (bumpTimeoutId timeoutId)++  modify $ \s -> s { lastReceivedMessage = Just x }++  res <- pred x++  case res of+    Just a -> do+      logMsg LogServer x+      return a+    Nothing -> empty++named :: T.Text -> Session a -> Session a+named s (Session x) = Session (Data.Conduit.Parser.named s x)+++-- | Matches a request or a notification coming from the server.+message :: SServerMethod m -> Session (ServerMessage m)+message m1 = named (T.pack $ "Request for: " <> show m1) $ satisfyMaybe $ \case+  FromServerMess m2 msg -> do+    HRefl <- mEqServer m1 m2+    pure msg+  _ -> Nothing++customRequest :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Request))+customRequest m = named m $ satisfyMaybe $ \case+  FromServerMess m1 msg -> case splitServerMethod m1 of+    IsServerEither -> case msg of+      ReqMess _ | m1 == SCustomMethod m -> Just msg+      _ -> Nothing+    _ -> Nothing+  _ -> Nothing++customNotification :: T.Text -> Session (ServerMessage (CustomMethod :: Method FromServer Notification))+customNotification m = named m $ satisfyMaybe $ \case+  FromServerMess m1 msg -> case splitServerMethod m1 of+    IsServerEither -> case msg of+      NotMess _ | m1 == SCustomMethod m -> Just msg+      _ -> Nothing+    _ -> Nothing+  _ -> Nothing++-- | Matches if the message is a notification.+anyNotification :: Session FromServerMessage+anyNotification = named "Any notification" $ satisfy $ \case+  FromServerMess m msg -> case splitServerMethod m of+    IsServerNot -> True+    IsServerEither -> case msg of+      NotMess _ -> True+      _ -> False+    _ -> False+  FromServerRsp _ _ -> False++-- | Matches if the message is a request.+anyRequest :: Session FromServerMessage+anyRequest = named "Any request" $ satisfy $ \case+  FromServerMess m _ -> case splitServerMethod m of+    IsServerReq -> True+    _ -> False+  FromServerRsp _ _ -> False++-- | Matches if the message is a response.+anyResponse :: Session FromServerMessage+anyResponse = named "Any response" $ satisfy $ \case+  FromServerMess _ _ -> False+  FromServerRsp _ _ -> True++-- | Matches a response coming from the server.+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+    pure msg+  _ -> Nothing++-- | Like 'response', but matches a response for a specific id.+responseForId :: SMethod (m :: Method FromClient Request) -> LspId m -> Session (ResponseMessage m)+responseForId m lid = named (T.pack $ "Response for id: " ++ show lid) $ do+  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++-- | Matches any type of message.+anyMessage :: Session FromServerMessage+anyMessage = satisfy (const True)++-- | Matches if the message is a log message notification or a show message notification/request.+loggingNotification :: Session FromServerMessage+loggingNotification = named "Logging notification" $ satisfy shouldSkip+  where+    shouldSkip (FromServerMess SWindowLogMessage _) = True+    shouldSkip (FromServerMess SWindowShowMessage _) = True+    shouldSkip (FromServerMess SWindowShowMessageRequest _) = True+    shouldSkip _ = False++-- | Matches a 'Language.LSP.Types.TextDocumentPublishDiagnostics'+-- (textDocument/publishDiagnostics) notification.+publishDiagnosticsNotification :: Session (Message TextDocumentPublishDiagnostics)+publishDiagnosticsNotification = named "Publish diagnostics notification" $+  satisfyMaybe $ \msg -> case msg of+    FromServerMess STextDocumentPublishDiagnostics diags -> Just diags+    _ -> Nothing

@@ -0,0 +1,22 @@+module Language.LSP.Test.Server (withServer) where++import Control.Concurrent.Async+import Control.Monad+import Language.LSP.Test.Compat+import System.IO+import System.Process hiding (withCreateProcess)++withServer :: String -> Bool -> (Handle -> Handle -> ProcessHandle -> IO a) -> IO a+withServer serverExe logStdErr f = do+  -- TODO Probably should just change runServer to accept+  -- separate command and arguments+  let cmd:args = words serverExe+      createProc = (proc cmd args) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }+  withCreateProcess createProc $ \(Just serverIn) (Just serverOut) (Just serverErr) serverProc -> do+    -- Need to continuously consume to stderr else it gets blocked+    -- Can't pass NoStream either to std_err+    hSetBuffering serverErr NoBuffering+    hSetBinaryMode serverErr True+    let errSinkThread = forever $ hGetLine serverErr >>= when logStdErr . putStrLn+    withAsync errSinkThread $ \_ -> do+      f serverIn serverOut serverProc

@@ -0,0 +1,473 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeInType #-}++module Language.LSP.Test.Session+  ( Session(..)+  , SessionConfig(..)+  , defaultConfig+  , SessionMessage(..)+  , SessionContext(..)+  , SessionState(..)+  , runSession'+  , get+  , put+  , modify+  , modifyM+  , ask+  , asks+  , sendMessage+  , updateState+  , withTimeout+  , getCurTimeoutId+  , bumpTimeoutId+  , logMsg+  , LogMsgType(..)+  , documentChangeUri+  )++where++import Control.Applicative+import Control.Concurrent hiding (yield)+import Control.Exception+import Control.Lens hiding (List)+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Except+#if __GLASGOW_HASKELL__ == 806+import Control.Monad.Fail+#endif+import Control.Monad.Trans.Reader (ReaderT, runReaderT)+import qualified Control.Monad.Trans.Reader as Reader (ask)+import Control.Monad.Trans.State (StateT, runStateT)+import qualified Control.Monad.Trans.State as State+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Aeson+import Data.Aeson.Encode.Pretty+import Data.Conduit as Conduit+import Data.Conduit.Parser as Parser+import Data.Default+import Data.Foldable+import Data.List+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.HashMap.Strict as HashMap+import Data.Maybe+import Data.Function+import Language.LSP.Types.Capabilities+import Language.LSP.Types+import Language.LSP.Types.Lens+import qualified Language.LSP.Types.Lens as LSP+import Language.LSP.VFS+import Language.LSP.Test.Compat+import Language.LSP.Test.Decoding+import Language.LSP.Test.Exceptions+import System.Console.ANSI+import System.Directory+import System.IO+import System.Process (ProcessHandle())+#ifndef mingw32_HOST_OS+import System.Process (waitForProcess)+#endif+import System.Timeout++-- | A session representing one instance of launching and connecting to a server.+--+-- You can send and receive messages to the server within 'Session' via+-- 'Language.LSP.Test.message',+-- 'Language.LSP.Test.sendRequest' and+-- 'Language.LSP.Test.sendNotification'.++newtype Session a = Session (ConduitParser FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) a)+  deriving (Functor, Applicative, Monad, MonadIO, Alternative)++#if __GLASGOW_HASKELL__ >= 806+instance MonadFail Session where+  fail s = do+    lastMsg <- fromJust . lastReceivedMessage <$> get+    liftIO $ throw (UnexpectedMessage s lastMsg)+#endif++-- | Stuff you can configure for a 'Session'.+data SessionConfig = SessionConfig+  { messageTimeout :: Int  -- ^ Maximum time to wait for a message in seconds, defaults to 60.+  , logStdErr      :: Bool+  -- ^ Redirect the server's stderr to this stdout, defaults to False.+  -- Can be overriden with @LSP_TEST_LOG_STDERR@.+  , logMessages    :: Bool+  -- ^ Trace the messages sent and received to stdout, defaults to False.+  -- Can be overriden with the environment variable @LSP_TEST_LOG_MESSAGES@.+  , logColor       :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.+  , lspConfig      :: Maybe Value -- ^ The initial LSP config as JSON value, defaults to Nothing.+  , ignoreLogNotifications :: Bool+  -- ^ Whether or not to ignore 'Language.LSP.Types.ShowMessageNotification' and+  -- 'Language.LSP.Types.LogMessageNotification', defaults to False.+  --+  -- @since 0.9.0.0+  , initialWorkspaceFolders :: Maybe [WorkspaceFolder]+  -- ^ The initial workspace folders to send in the @initialize@ request.+  -- Defaults to Nothing.+  }++-- | The configuration used in 'Language.LSP.Test.runSession'.+defaultConfig :: SessionConfig+defaultConfig = SessionConfig 60 False False True Nothing False Nothing++instance Default SessionConfig where+  def = defaultConfig++data SessionMessage = ServerMessage FromServerMessage+                    | TimeoutMessage Int+  deriving Show++data SessionContext = SessionContext+  {+    serverIn :: Handle+  , 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+  , requestMap :: MVar RequestMap+  , initRsp :: MVar (ResponseMessage Initialize)+  , config :: SessionConfig+  , sessionCapabilities :: ClientCapabilities+  }++class Monad m => HasReader r m where+  ask :: m r+  asks :: (r -> b) -> m b+  asks f = f <$> ask++instance HasReader SessionContext Session where+  ask  = Session (lift $ lift Reader.ask)++instance Monad m => HasReader r (ConduitM a b (StateT s (ReaderT r m))) where+  ask = lift $ lift Reader.ask++getCurTimeoutId :: (HasReader SessionContext m, MonadIO m) => m Int+getCurTimeoutId = asks curTimeoutId >>= liftIO . readMVar++-- Pass this the timeoutid you *were* waiting on+bumpTimeoutId :: (HasReader SessionContext m, MonadIO m) => Int -> m ()+bumpTimeoutId prev = do+  v <- asks curTimeoutId+  -- when updating the curtimeoutid, account for the fact that something else+  -- might have bumped the timeoutid in the meantime+  liftIO $ modifyMVar_ v (\x -> pure (max x (prev + 1)))++data SessionState = SessionState+  {+    curReqId :: 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+  -- ^ The capabilities that the server has dynamically registered with us so+  -- far+  , curProgressSessions :: Set.Set ProgressToken+  }++class Monad m => HasState s m where+  get :: m s++  put :: s -> m ()++  modify :: (s -> s) -> m ()+  modify f = get >>= put . f++  modifyM :: (HasState s m, Monad m) => (s -> m s) -> m ()+  modifyM f = get >>= f >>= put++instance HasState SessionState Session where+  get = Session (lift State.get)+  put = Session . lift . State.put++instance Monad m => HasState s (StateT s m) where+  get = State.get+  put = State.put++instance (Monad m, (HasState s m)) => HasState s (ConduitM a b m)+ where+  get = lift get+  put = lift . put++instance (Monad m, (HasState s m)) => HasState s (ConduitParser a m)+ where+  get = lift get+  put = lift . put++runSessionMonad :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)+runSessionMonad context state (Session session) = runReaderT (runStateT conduit state) context+  where+    conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler)++    handler (Unexpected "ConduitParser.empty") = do+      lastMsg <- fromJust . lastReceivedMessage <$> get+      name <- getParserName+      liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg)++    handler e = throw e++    chanSource = do+      msg <- liftIO $ readChan (messageChan context)+      unless (ignoreLogNotifications (config context) && isLogNotification msg) $+        yield msg+      chanSource++    isLogNotification (ServerMessage (FromServerMess SWindowShowMessage _)) = True+    isLogNotification (ServerMessage (FromServerMess SWindowLogMessage _)) = True+    isLogNotification _ = False++    watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()+    watchdog = Conduit.awaitForever $ \msg -> do+      curId <- getCurTimeoutId+      case msg of+        ServerMessage sMsg -> yield sMsg+        TimeoutMessage tId -> when (curId == tId) $ lastReceivedMessage <$> get >>= throw . Timeout++-- | An internal version of 'runSession' that allows for a custom handler to listen to the server.+-- It also does not automatically send initialize and exit messages.+runSession' :: Handle -- ^ Server in+            -> Handle -- ^ Server out+            -> Maybe ProcessHandle -- ^ Server process+            -> (Handle -> SessionContext -> IO ()) -- ^ Server listener+            -> SessionConfig+            -> ClientCapabilities+            -> FilePath -- ^ Root directory+            -> Session () -- ^ To exit the Server properly+            -> Session a+            -> IO a+runSession' serverIn serverOut mServerProc serverHandler config caps rootDir exitServer session = do+  absRootDir <- canonicalizePath rootDir++  hSetBuffering serverIn  NoBuffering+  hSetBuffering serverOut NoBuffering+  -- This is required to make sure that we don’t get any+  -- newline conversion or weird encoding issues.+  hSetBinaryMode serverIn True+  hSetBinaryMode serverOut True++  reqMap <- newMVar newRequestMap+  messageChan <- newChan+  timeoutIdVar <- newMVar 0+  initRsp <- newEmptyMVar++  mainThreadId <- myThreadId++  let context = SessionContext serverIn absRootDir messageChan timeoutIdVar reqMap initRsp config caps+      initState vfs = SessionState 0 vfs mempty False Nothing mempty mempty+      runSession' ses = initVFS $ \vfs -> runSessionMonad context (initState vfs) ses++      errorHandler = throwTo mainThreadId :: SessionException -> IO ()+      serverListenerLauncher =+        forkIO $ catch (serverHandler serverOut context) errorHandler+      msgTimeoutMs = messageTimeout config * 10^6+      serverAndListenerFinalizer tid = do+        let cleanup+              | Just sp <- mServerProc = do+                  -- Give the server some time to exit cleanly+                  -- It makes the server hangs in windows so we have to avoid it+#ifndef mingw32_HOST_OS+                  timeout msgTimeoutMs (waitForProcess sp)+#endif+                  cleanupProcess (Just serverIn, Just serverOut, Nothing, sp)+              | otherwise = pure ()+        finally (timeout msgTimeoutMs (runSession' exitServer))+                -- Make sure to kill the listener first, before closing+                -- handles etc via cleanupProcess+                (killThread tid >> cleanup)++  (result, _) <- bracket serverListenerLauncher+                         serverAndListenerFinalizer+                         (const $ initVFS $ \vfs -> runSessionMonad context (initState vfs) session)+  return result++updateStateC :: ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()+updateStateC = awaitForever $ \msg -> do+  updateState msg+  respond msg+  yield msg+  where+    respond :: (MonadIO m, HasReader SessionContext m) => FromServerMessage -> m ()+    respond (FromServerMess SWindowWorkDoneProgressCreate req) =+      sendMessage $ ResponseMessage "2.0" (Just $ req ^. LSP.id) (Right ())+    respond (FromServerMess SWorkspaceApplyEdit r) = do+      sendMessage $ ResponseMessage "2.0" (Just $ r ^. LSP.id) (Right $ ApplyWorkspaceEditResponseBody True Nothing)+    respond _ = pure ()+++-- extract Uri out from DocumentChange+-- didn't put this in `lsp-types` because TH was getting in the way+documentChangeUri :: DocumentChange -> Uri+documentChangeUri (InL x) = x ^. textDocument . uri+documentChangeUri (InR (InL x)) = x ^. uri+documentChangeUri (InR (InR (InL x))) = x ^. oldUri+documentChangeUri (InR (InR (InR x))) = x ^. uri++updateState :: (MonadIO m, HasReader SessionContext m, HasState SessionState m)+            => FromServerMessage -> m ()+updateState (FromServerMess SProgress req) = case req ^. params . value of+  Begin _ ->+    modify $ \s -> s { curProgressSessions = Set.insert (req ^. params . token) $ curProgressSessions s }+  End _ ->+    modify $ \s -> s { curProgressSessions = Set.delete (req ^. params . token) $ curProgressSessions s }+  _ -> pure ()++-- Keep track of dynamic capability registration+updateState (FromServerMess SClientRegisterCapability req) = do+  let List newRegs = (\sr@(SomeRegistration r) -> (r ^. LSP.id, sr)) <$> req ^. params . registrations+  modify $ \s ->+    s { curDynCaps = Map.union (Map.fromList newRegs) (curDynCaps s) }++updateState (FromServerMess SClientUnregisterCapability req) = do+  let List unRegs = (^. LSP.id) <$> req ^. params . unregisterations+  modify $ \s ->+    let newCurDynCaps = foldr' Map.delete (curDynCaps s) unRegs+    in s { curDynCaps = newCurDynCaps }++updateState (FromServerMess STextDocumentPublishDiagnostics n) = do+  let List diags = n ^. params . diagnostics+      doc = n ^. params . uri+  modify $ \s ->+    let newDiags = Map.insert (toNormalizedUri doc) diags (curDiagnostics s)+      in s { curDiagnostics = newDiags }++updateState (FromServerMess SWorkspaceApplyEdit r) = do++  -- First, prefer the versioned documentChanges field+  allChangeParams <- case r ^. params . edit . documentChanges of+    Just (List cs) -> do+      mapM_ (checkIfNeedsOpened . documentChangeUri) cs+      return $ mapMaybe getParamsFromDocumentChange cs+    -- Then fall back to the changes field+    Nothing -> case r ^. params . edit . changes of+      Just cs -> do+        mapM_ checkIfNeedsOpened (HashMap.keys cs)+        concat <$> mapM (uncurry getChangeParams) (HashMap.toList cs)+      Nothing ->+        error "WorkspaceEdit contains neither documentChanges nor changes!"++  modifyM $ \s -> do+    newVFS <- liftIO $ changeFromServerVFS (vfs s) r+    return $ s { vfs = newVFS }++  let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams+      mergedParams = map mergeParams groupedParams++  -- TODO: Don't do this when replaying a session+  forM_ mergedParams (sendMessage . NotificationMessage "2.0" STextDocumentDidChange)++  -- Update VFS to new document versions+  let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams+      latestVersions = map ((^. textDocument) . last) sortedVersions+      bumpedVersions = map (version . _Just +~ 1) latestVersions++  forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) ->+    modify $ \s ->+      let oldVFS = vfs s+          update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver + 1) t+          newVFS = updateVFS (Map.adjust update (toNormalizedUri uri)) oldVFS+      in s { vfs = newVFS }++  where checkIfNeedsOpened uri = do+          oldVFS <- vfs <$> get+          ctx <- ask++          -- if its not open, open it+          unless (toNormalizedUri uri `Map.member` vfsMap oldVFS) $ do+            let fp = fromJust $ uriToFilePath uri+            contents <- liftIO $ T.readFile fp+            let item = TextDocumentItem (filePathToUri fp) "" 0 contents+                msg = NotificationMessage "2.0" STextDocumentDidOpen (DidOpenTextDocumentParams item)+            liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)++            modifyM $ \s -> do+              let (newVFS,_) = openVFS (vfs s) msg+              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)++        getParamsFromDocumentChange :: DocumentChange -> Maybe DidChangeTextDocumentParams+        getParamsFromDocumentChange (InL textDocumentEdit) = Just $ getParamsFromTextDocumentEdit textDocumentEdit+        getParamsFromDocumentChange _ = Nothing+++        -- For a uri returns an infinite list of versions [n,n+1,n+2,...]+        -- where n is the current version+        textDocumentVersions uri = do+          m <- vfsMap . vfs <$> get+          let curVer = fromMaybe 0 $+                _lsp_version <$> m Map.!? (toNormalizedUri uri)+          pure $ map (VersionedTextDocumentIdentifier uri . Just) [curVer + 1..]++        textDocumentEdits uri edits = do+          vers <- textDocumentVersions uri+          pure $ map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip vers edits++        getChangeParams uri (List edits) = do +          map <$> pure getParamsFromTextDocumentEdit <*> textDocumentEdits uri (reverse edits)++        mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams+        mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))+                              in DidChangeTextDocumentParams (head params ^. textDocument) (List events)+updateState _ = return ()++sendMessage :: (MonadIO m, HasReader SessionContext m, ToJSON a) => a -> m ()+sendMessage msg = do+  h <- serverIn <$> ask+  logMsg LogClient msg+  liftIO $ B.hPut h (addHeader $ encode msg)++-- | Execute a block f that will throw a 'Language.LSP.Test.Exception.Timeout' exception+-- after duration seconds. This will override the global timeout+-- for waiting for messages to arrive defined in 'SessionConfig'.+withTimeout :: Int -> Session a -> Session a+withTimeout duration f = do+  chan <- asks messageChan+  timeoutId <- getCurTimeoutId+  modify $ \s -> s { overridingTimeout = True }+  liftIO $ forkIO $ do+    threadDelay (duration * 1000000)+    writeChan chan (TimeoutMessage timeoutId)+  res <- f+  bumpTimeoutId timeoutId+  modify $ \s -> s { overridingTimeout = False }+  return res++data LogMsgType = LogServer | LogClient+  deriving Eq++-- | Logs the message if the config specified it+logMsg :: (ToJSON a, MonadIO m, HasReader SessionContext m)+       => LogMsgType -> a -> m ()+logMsg t msg = do+  shouldLog <- asks $ logMessages . config+  shouldColor <- asks $ logColor . config+  liftIO $ when shouldLog $ do+    when shouldColor $ setSGR [SetColor Foreground Dull color]+    putStrLn $ arrow ++ showPretty msg+    when shouldColor $ setSGR [Reset]++  where arrow+          | t == LogServer  = "<-- "+          | otherwise       = "--> "+        color+          | t == LogServer  = Magenta+          | otherwise       = Cyan++        showPretty = B.unpack . encodePretty

@@ -1,3 +1,5 @@+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-}@@ -15,16 +17,16 @@ import           Control.Monad.IO.Class import           Control.Monad import           Control.Lens hiding (List)-import           Language.Haskell.LSP.Messages-import           Language.Haskell.LSP.Test-import           Language.Haskell.LSP.Types-import           Language.Haskell.LSP.Types.Lens hiding+import           Language.LSP.Test+import           Language.LSP.Types+import           Language.LSP.Types.Lens hiding   (capabilities, message, rename, applyEdit)-import qualified Language.Haskell.LSP.Types.Lens as LSP-import           Language.Haskell.LSP.Types.Capabilities as LSP+import qualified Language.LSP.Types.Lens as LSP+import           Language.LSP.Types.Capabilities as LSP 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) #-}@@ -51,7 +53,7 @@                     -- won't receive a request - will timeout                     -- incoming logging requests shouldn't increase the                     -- timeout-                    withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest+                    withTimeout 5 $ skipManyTill anyMessage (message SWorkspaceApplyEdit)           -- wait just a bit longer than 5 seconds so we have time           -- to open the document           in timeout 6000000 sesh `shouldThrow` anySessionException@@ -90,7 +92,7 @@                 withTimeout 10 $ liftIO $ threadDelay 7000000                 getDocumentSymbols doc                 -- should now timeout-                skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest+                skipManyTill anyMessage (message SWorkspaceApplyEdit)             isTimeout (Timeout _) = True             isTimeout _ = False         in sesh `shouldThrow` isTimeout@@ -100,7 +102,7 @@       it "throw on time out" $         let sesh = runSessionWithConfig (def {messageTimeout = 10}) serverExe fullCaps "test/data/renamePass" $ do                 skipMany loggingNotification-                _ <- message :: Session ApplyWorkspaceEditRequest+                _ <- message SWorkspaceApplyEdit                 return ()         in sesh `shouldThrow` anySessionException @@ -112,52 +114,30 @@        describe "UnexpectedMessageException" $ do         it "throws when there's an unexpected message" $-          let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True+          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 "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True+          let selector (UnexpectedMessage "STextDocumentRename" (FromServerRsp STextDocumentDocumentSymbol _)) = True               selector _ = False               sesh = do                 doc <- openDoc "Desktop/simple.hs" "haskell"-                sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing)+                sendRequest STextDocumentDocumentSymbol (DocumentSymbolParams Nothing Nothing doc)                 skipMany anyNotification-                message :: Session RenameResponse -- the wrong type+                response STextDocumentRename -- the wrong type             in runSession serverExe fullCaps "test/data/renamePass" sesh               `shouldThrow` selector -  -- This is too fickle at the moment-  -- describe "replaySession" $-  --   it "passes a test" $-  --     replaySession serverExe "test/data/renamePass"-  --   it "fails a test" $-  --     let selector (ReplayOutOfOrder _ _) = True-  --         selector _ = False-  --       in replaySession serverExe "test/data/renameFail" `shouldThrow` selector--  -- describe "manual javascript session" $-  --   it "passes a test" $-  --     runSession "javascript-typescript-stdio" fullCaps "test/data/javascriptPass" $ do-  --       doc <- openDoc "test.js" "javascript"--  --       noDiagnostics--  --       Right (fooSymbol:_) <- getDocumentSymbols doc--  --       liftIO $ do-  --         fooSymbol ^. name `shouldBe` "foo"-  --         fooSymbol ^. kind `shouldBe` SkFunction-   describe "text document VFS" $     it "sends back didChange notifications" $       runSession serverExe def "test/data/refactor" $ do         doc <- openDoc "Main.hs" "haskell"          let args = toJSON (doc ^. uri)-            reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing-        request_ WorkspaceExecuteCommand reqParams+            reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args]))+        request_ SWorkspaceExecuteCommand reqParams -        editReq <- message :: Session ApplyWorkspaceEditRequest+        editReq <- message SWorkspaceApplyEdit         liftIO $ do           let (Just cs) = editReq ^. params . edit . changes               [(u, List es)] = HM.toList cs@@ -172,8 +152,8 @@         doc <- openDoc "Main.hs" "haskell"          let args = toJSON (doc ^. uri)-            reqParams = ExecuteCommandParams "doAnEdit" (Just (List [args])) Nothing-        request_ WorkspaceExecuteCommand reqParams+            reqParams = ExecuteCommandParams Nothing "doAnEdit" (Just (List [args]))+        request_ SWorkspaceExecuteCommand reqParams         contents <- getDocumentEdit doc         liftIO $ contents `shouldBe` "howdy:: IO Int\nmain = return (42)\n" @@ -181,7 +161,7 @@     it "works" $ runSession serverExe fullCaps "test/data/refactor" $ do       doc <- openDoc "Main.hs" "haskell"       waitForDiagnostics-      [CACodeAction action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))+      [InR action] <- getCodeActions doc (Range (Position 1 14) (Position 1 18))       liftIO $ action ^. title `shouldBe` "Delete this"    describe "getAllCodeActions" $@@ -190,9 +170,9 @@       _ <- waitForDiagnostics       actions <- getAllCodeActions doc       liftIO $ do-        let [CACodeAction action] = actions+        let [InR action] = actions         action ^. title `shouldBe` "Delete this"-        action ^. command . _Just . command `shouldBe` "deleteThis"+        action ^. command . _Just . command  `shouldBe` "deleteThis"    describe "getDocumentSymbols" $     it "works" $ runSession serverExe fullCaps "test/data/renamePass" $ do@@ -311,7 +291,7 @@   describe "satisfy" $     it "works" $ runSession serverExe fullCaps "test/data" $ do       openDoc "Format.hs" "haskell"-      let pred (NotLogMessage _) = True+      let pred (FromServerMess SWindowLogMessage _) = True           pred _ = False       void $ satisfy pred @@ -319,32 +299,34 @@     it "works" $       runSessionWithConfig (defaultConfig { ignoreLogNotifications = True }) serverExe  fullCaps "test/data" $ do         openDoc "Format.hs" "haskell"-        void publishDiagnosticsNotification+        void publishDiagnosticsNotification           describe "dynamic capabilities" $ do+         it "keeps track" $ runSession serverExe fullCaps "test/data" $ do       loggingNotification -- initialized log message        createDoc ".register" "haskell" ""-      message :: Session RegisterCapabilityRequest+      message SClientRegisterCapability        doc <- createDoc "Foo.watch" "haskell" ""-      NotLogMessage msg <- loggingNotification+      msg <- message SWindowLogMessage       liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles" -      caps <- getRegisteredCapabilities-      liftIO $ caps `shouldBe`-        [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $-          DidChangeWatchedFilesRegistrationOptions $ List-          [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ]-        ]+      [SomeRegistration (Registration _ regMethod regOpts)] <- getRegisteredCapabilities+      liftIO $ do+        case regMethod `mEqClient` SWorkspaceDidChangeWatchedFiles of+          Just HRefl ->+            regOpts `shouldBe` (DidChangeWatchedFilesRegistrationOptions $ List+                                [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ])+          Nothing -> expectationFailure "Registration wasn't on workspace/didChangeWatchedFiles"        -- now unregister it by sending a specific createDoc       createDoc ".unregister" "haskell" ""-      message :: Session UnregisterCapabilityRequest+      message SClientUnregisterCapability        createDoc "Bar.watch" "haskell" ""-      void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing+      void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing       count 0 $ loggingNotification       void $ anyResponse @@ -354,25 +336,22 @@       loggingNotification -- initialized log message        createDoc ".register.abs" "haskell" ""-      message :: Session RegisterCapabilityRequest+      message SClientRegisterCapability        doc <- createDoc (curDir </> "Foo.watch") "haskell" ""-      NotLogMessage msg <- loggingNotification+      msg <- message SWindowLogMessage       liftIO $ msg ^. params . LSP.message `shouldBe` "got workspace/didChangeWatchedFiles"        -- now unregister it by sending a specific createDoc       createDoc ".unregister.abs" "haskell" ""-      message :: Session UnregisterCapabilityRequest+      message SClientUnregisterCapability        createDoc (curDir </> "Bar.watch") "haskell" ""-      void $ sendRequest TextDocumentHover $ TextDocumentPositionParams doc (Position 0 0) Nothing+      void $ sendRequest STextDocumentHover $ HoverParams doc (Position 0 0) Nothing       count 0 $ loggingNotification       void $ anyResponse  -mkRange :: Int -> Int -> Int -> Int -> Range-mkRange sl sc el ec = Range (Position sl sc) (Position el ec)- didChangeCaps :: ClientCapabilities didChangeCaps = def { _workspace = Just workspaceCaps }   where@@ -383,7 +362,7 @@ docChangesCaps = def { _workspace = Just workspaceCaps }   where     workspaceCaps = def { _workspaceEdit = Just editCaps }-    editCaps = WorkspaceEditClientCapabilities (Just True)+    editCaps = WorkspaceEditClientCapabilities (Just True) Nothing Nothing   findExeRecursive :: FilePath -> FilePath -> IO (Maybe FilePath)

@@ -1,122 +1,173 @@+{-# LANGUAGE TypeInType #-} {-# LANGUAGE OverloadedStrings #-}-import Data.Aeson-import Data.Default-import Data.List (isSuffixOf)-import qualified Data.HashMap.Strict as HM-import Language.Haskell.LSP.Core-import Language.Haskell.LSP.Control-import Language.Haskell.LSP.Messages-import Language.Haskell.LSP.Types-import Control.Concurrent+ import Control.Monad+import 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-  lfvar <- newEmptyMVar-  let initCbs = InitializeCallbacks-        { onInitialConfiguration = const $ Right ()-        , onConfigurationChange = const $ Right ()-        , onStartup = \lf -> do-            putMVar lfvar lf--            return Nothing-        }-      options = def-        { executeCommandCommands = Just ["doAnEdit"]-        }-  run initCbs (handlers lfvar) options Nothing--handlers :: MVar (LspFuncs ()) -> Handlers-handlers lfvar = def-  { initializedHandler = pure $ \_ -> send $ NotLogMessage $ fmServerLogMessageNotification MtLog "initialized"-  , hoverHandler = pure $ \req -> send $-      RspHover $ makeResponseMessage req (Just (Hover (HoverContents (MarkupContent MkPlainText "hello")) Nothing))-  , documentSymbolHandler = pure $ \req -> send $-      RspDocumentSymbols $ makeResponseMessage req $ DSDocumentSymbols $-        List [ DocumentSymbol "foo"-                              Nothing-                              SkObject-                              Nothing-                              (mkRange 0 0 3 6)-                              (mkRange 0 0 3 6)-                              Nothing-             ]-  , didOpenTextDocumentNotificationHandler = pure $ \noti -> do-      let NotificationMessage _ _ (DidOpenTextDocumentParams doc) = noti-          TextDocumentItem uri _ _ _ = doc-          Just fp = uriToFilePath uri-          diag = Diagnostic (mkRange 0 0 0 1)-                            (Just DsWarning)-                            (Just (NumberValue 42))-                            (Just "dummy-server")-                            "Here's a warning"-                            Nothing-                            Nothing-      when (".hs" `isSuffixOf` fp) $ void $ forkIO $ do-        threadDelay (2 * 10^6)-        send $ NotPublishDiagnostics $-          fmServerPublishDiagnosticsNotification $ PublishDiagnosticsParams uri $ List [diag]--      -- also act as a registerer for workspace/didChangeWatchedFiles-      when (".register" `isSuffixOf` fp) $ do-        reqId <- readMVar lfvar >>= getNextReqId-        send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $-          RegistrationParams $ List $-            [ Registration "0" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $-                DidChangeWatchedFilesRegistrationOptions $ List-                [ FileSystemWatcher "*.watch" (Just (WatchKind True True True)) ]-            ]-      when (".register.abs" `isSuffixOf` fp) $ do-        curDir <- getCurrentDirectory-        reqId <- readMVar lfvar >>= getNextReqId-        send $ ReqRegisterCapability $ fmServerRegisterCapabilityRequest reqId $-          RegistrationParams $ List $-            [ Registration "1" WorkspaceDidChangeWatchedFiles $ Just $ toJSON $-                DidChangeWatchedFilesRegistrationOptions $ List-                [ FileSystemWatcher (curDir </> "*.watch") (Just (WatchKind True True True)) ]-            ]+  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"]}+    } -      -- also act as an unregisterer for workspace/didChangeWatchedFiles-      when (".unregister" `isSuffixOf` fp) $ do-        reqId <- readMVar lfvar >>= getNextReqId-        send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $-          UnregistrationParams $ List [ Unregistration "0" "workspace/didChangeWatchedFiles" ]-      when (".unregister.abs" `isSuffixOf` fp) $ do-        reqId <- readMVar lfvar >>= getNextReqId-        send $ ReqUnregisterCapability $ fmServerUnregisterCapabilityRequest reqId $-          UnregistrationParams $ List [ Unregistration "1" "workspace/didChangeWatchedFiles" ]-  , executeCommandHandler = pure $ \req -> do-      send $ RspExecuteCommand $ makeResponseMessage req Null-      reqId <- readMVar lfvar >>= getNextReqId-      let RequestMessage _ _ _ (ExecuteCommandParams "doAnEdit" (Just (List [val])) _) = req-          Success docUri = fromJSON val-          edit = List [TextEdit (mkRange 0 0 0 5) "howdy"]-      send $ ReqApplyWorkspaceEdit $ fmServerApplyWorkspaceEditRequest reqId $-        ApplyWorkspaceEditParams $ WorkspaceEdit (Just (HM.singleton docUri edit))-                                                 Nothing-  , codeActionHandler = pure $ \req -> do-      let RequestMessage _ _ _ params = req-          CodeActionParams _ _ cactx _ = params-          CodeActionContext diags _ = cactx-          caresults = fmap diag2caresult diags-          diag2caresult d = CACodeAction $-            CodeAction "Delete this"-                       Nothing-                       (Just (List [d]))-                       Nothing-                      (Just (Command "" "deleteThis" Nothing))-      send $ RspCodeAction $ makeResponseMessage req caresults-  , didChangeWatchedFilesNotificationHandler = pure $ \_ ->-      send $ NotLogMessage $ fmServerLogMessageNotification MtLog "got workspace/didChangeWatchedFiles"-  , completionHandler = pure $ \req -> do-      let res = CompletionList (CompletionListType False (List [item]))-          item =-            CompletionItem "foo" (Just CiConstant) (Just (List [])) Nothing-            Nothing Nothing Nothing Nothing Nothing Nothing Nothing-            Nothing Nothing Nothing Nothing Nothing-      send $ RspCompletion $ makeResponseMessage req res+data HandlerEnv = HandlerEnv+  { relRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles),+    absRegToken :: MVar (RegistrationToken WorkspaceDidChangeWatchedFiles)   }-  where send msg = readMVar lfvar >>= \lf -> (sendFunc lf) msg -mkRange sl sc el ec = Range (Position sl sc) (Position el ec)+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+    ]