packages feed

lsp-test (empty) → 0.1.0.0

raw patch · 15 files changed

+2180/−0 lines, 15 filesdep +Diffdep +Win32dep +aesonsetup-changed

Dependencies added: Diff, Win32, aeson, aeson-pretty, ansi-terminal, base, bytestring, conduit, conduit-parse, containers, data-default, directory, filepath, haskell-lsp, hspec, lens, lsp-test, mtl, parser-combinators, process, text, transformers, unix, unordered-containers, yi-rope

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Luke Lau (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Luke Lau nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,43 @@+# lsp-test [![Build Status](https://travis-ci.com/Bubba/haskell-lsp-test.svg?branch=master)](https://travis-ci.com/Bubba/haskell-lsp-test)+lsp-test is a functional testing framework for Language Server Protocol servers.++```haskell+import Language.Haskell.LSP.Test+runSession "hie" fullCaps "proj/dir" $ do+  doc <- openDoc "Foo.hs" "haskell"+  skipMany anyNotification+  symbols <- getDocumentSymbols doc+```++## Examples++### Unit tests with HSpec+```haskell+describe "diagnostics" $+  it "report errors" $ runSession "hie" fullCaps "test/data" $ do+    openDoc "Error.hs" "haskell"+    [diag] <- waitForDiagnosticsSource "ghcmod"+    liftIO $ do+      diag ^. severity `shouldBe` Just DsError+      diag ^. source `shouldBe` Just "ghcmod"+```++### Replaying captured session+```haskell+replaySession "hie" "test/data/renamePass"+```++### Parsing with combinators+```haskell+skipManyTill loggingNotification publishDiagnosticsNotification+count 4 (message :: Session ApplyWorkspaceEditRequest)+anyRequest <|> anyResponse+```++Try out the example tests in the `example` directory with `cabal new-test`.+For more examples check the [Wiki](https://github.com/Bubba/haskell-lsp-test/wiki/Introduction)++## Developing+To test make sure you have the following language servers installed:+- [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine)+- [javascript-typescript-langserver](https://github.com/sourcegraph/javascript-typescript-langserver)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lsp-test.cabal view
@@ -0,0 +1,87 @@+name:                lsp-test+version:             0.1.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+  <haskell-lsp-test https://hackage.haskell.org/package/haskell-lsp>.+  It's currently used for testing in <https://github.com/haskell/haskell-ide-engine haskell-ide-engine>.+homepage:            https://github.com/Bubba/haskell-lsp-test#readme+license:             BSD3+license-file:        LICENSE+author:              Luke Lau+maintainer:          luke_lau@icloud.com+stability:           experimental+bug-reports:         https://github.com/Bubba/haskell-lsp-test/issues+copyright:           2018 Luke Lau+category:            Testing+build-type:          Simple+cabal-version:       2.0+extra-source-files:  README.md+tested-with:         GHC == 8.2.2 , GHC == 8.4.2 , GHC == 8.4.3++source-repository head+  type:     git+  location: https://github.com/Bubba/haskell-lsp-test/++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+                     , parser-combinators:Control.Applicative.Combinators+  default-language:    Haskell2010+  build-depends:       base >= 4.7 && < 5+                     , haskell-lsp >= 0.5+                     , aeson+                     , aeson-pretty+                     , ansi-terminal+                     , bytestring+                     , conduit+                     , conduit-parse+                     , containers+                     , data-default+                     , Diff+                     , directory+                     , filepath+                     , lens+                     , mtl+                     , parser-combinators+                     , process+                     , text+                     , transformers+                     , unordered-containers+                     , yi-rope+  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+  ghc-options:         -W++test-suite tests+  type:                exitcode-stdio-1.0+  main-is:             Test.hs+  hs-source-dirs:      test+  ghc-options:         -W+  build-depends:       base >= 4.7 && < 5+                     , hspec+                     , lens+                     , data-default+                     , haskell-lsp >= 0.5+                     , lsp-test+                     , aeson+                     , unordered-containers+                     , text+  default-language:    Haskell2010+
+ src/Language/Haskell/LSP/Test.hs view
@@ -0,0 +1,513 @@+{-# 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 : POSIX++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+  , module Language.Haskell.LSP.Types.Capabilities+  -- ** 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+  , openDoc+  , closeDoc+  , documentContents+  , getDocumentEdit+  , getDocUri+  , getVersionedDoc+  -- ** Symbols+  , getDocumentSymbols+  -- ** Diagnostics+  , waitForDiagnostics+  , waitForDiagnosticsSource+  , noDiagnostics+  -- ** Commands+  , executeCommand+  -- ** Code Actions+  , getAllCodeActions+  , executeCodeAction+  -- ** Completions+  , getCompletions+  -- ** References+  , getReferences+  -- ** Definitions+  , getDefinitions+  -- ** Renaming+  , rename+  -- ** Hover+  , getHover+  -- ** Highlights+  , getHighlights+  -- ** Formatting+  , formatDoc+  , formatRange+  -- ** Edits+  , applyEdit+  ) 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.Text as T+import qualified Data.Text.IO as T+import Data.Aeson+import Data.Default+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Map as Map+import Data.Maybe+import Language.Haskell.LSP.Types hiding (id, capabilities, message)+import qualified Language.Haskell.LSP.Types as LSP+import Language.Haskell.LSP.Types.Capabilities+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.IO+import System.Directory+import System.FilePath+import qualified Yi.Rope as Rope++-- | 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.+           -> 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.+                     -> 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++  let initializeParams = InitializeParams (Just pid)+                                          (Just $ T.pack absRootDir)+                                          (Just $ filePathToUri absRootDir)+                                          Nothing+                                          caps+                                          (Just TraceOff)+  withServer serverExe (logStdErr config) $ \serverIn serverOut _ ->+    runSessionWithHandles serverIn serverOut listenServer config caps rootDir $ do++      -- Wrap the session around initialize and shutdown calls+      initRspMsg <- request Initialize initializeParams :: Session InitializeResponse++      liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRspMsg ^. LSP.error)++      initRspVar <- initRsp <$> ask+      liftIO $ putMVar initRspVar initRspMsg++      sendNotification Initialized InitializedParams++      -- Run the actual test+      result <- session++      sendNotification Exit ExitParams++      return result+  where+  -- | Listens to the server output, 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)++    listenServer serverOut context++-- | The current text contents of a document.+documentContents :: TextDocumentIdentifier -> Session T.Text+documentContents doc = do+  vfs <- vfs <$> get+  let file = vfs Map.! (doc ^. uri)+  return $ Rope.toText $ Language.Haskell.LSP.VFS._text 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+  newVFS <- liftIO $ 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+  newVFS <- liftIO $ closeVFS 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)++-- | Opens a text document and sends a notification to the client.+openDoc :: FilePath -> String -> Session TextDocumentIdentifier+openDoc file languageId = do+  item <- getDocItem file languageId+  sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)+  TextDocumentIdentifier <$> getDocUri file+  where+  -- | Reads in a text document as the first version.+  getDocItem :: FilePath -- ^ The path to the text document to read in.+            -> String -- ^ The language ID, e.g "haskell" for .hs files.+            -> Session TextDocumentItem+  getDocItem file languageId = do+    context <- ask+    let fp = rootDir context </> file+    contents <- liftIO $ T.readFile fp+    return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents++-- | Closes a text document and sends a notification to the client.+closeDoc :: TextDocumentIdentifier -> Session ()+closeDoc docId = do+  let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri))+  sendNotification TextDocumentDidClose params++  oldVfs <- vfs <$> get+  let notif = NotificationMessage "" TextDocumentDidClose params+  newVfs <- liftIO $ closeVFS oldVfs notif+  modify $ \s -> s { vfs = newVfs }++-- | 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+-- 'UnexpectedDiagnosticsException' 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 [SymbolInformation]+getDocumentSymbols doc = do+  ResponseMessage _ rspLid mRes mErr <- request TextDocumentDocumentSymbol (DocumentSymbolParams doc)+  maybe (return ()) (throw . UnexpectedResponseError rspLid) mErr+  let (Just (List symbols)) = mRes+  return symbols++-- | Returns all the code actions in a document by +-- querying the code actions at each of the current +-- diagnostics' positions.+getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction]+getAllCodeActions doc = do+  curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get+  let ctx = CodeActionContext (List curDiags) Nothing++  foldM (go ctx) [] curDiags++  where+    go :: CodeActionContext -> [CommandOrCodeAction] -> Diagnostic -> Session [CommandOrCodeAction]+    go ctx acc diag = do+      ResponseMessage _ rspLid mRes mErr <- request TextDocumentCodeAction (CodeActionParams doc (diag ^. range) ctx)++      case mErr of+        Just e -> throw (UnexpectedResponseError rspLid e)+        Nothing ->+          let Just (List cmdOrCAs) = mRes+            in return (acc ++ cmdOrCAs)++-- | Executes a command.+executeCommand :: Command -> Session ()+executeCommand cmd = do+  let args = decode $ encode $ fromJust $ cmd ^. arguments+      execParams = ExecuteCommandParams (cmd ^. command) args+  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 <- vfs <$> get+  let ver =+        case fs Map.!? uri of+          Just (VirtualFile v _) -> Just v+          _ -> 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 ClientCapabilities mWorkspace _ _ = caps+        WorkspaceClientCapabilities _ mEdit _ _ _ _ _ _ <- mWorkspace+        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)++  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+  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 =+  let params = TextDocumentPositionParams doc pos+  in getResponseResult <$> request TextDocumentDefinition params++-- | 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)+  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+  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+  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 = fromMaybe exc (rsp ^. result)+  where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id)+                                              (fromJust $ rsp ^. LSP.error)++-- | Applies formatting to the specified document.+formatDoc :: TextDocumentIdentifier -> FormattingOptions -> Session ()+formatDoc doc opts = do+  let params = DocumentFormattingParams doc opts+  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+  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+      req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit)+  in updateState (ReqApplyWorkspaceEdit req)
+ src/Language/Haskell/LSP/Test/Compat.hs view
@@ -0,0 +1,50 @@+{-# 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++#if MIN_VERSION_process(1,6,3)+import System.Process hiding (getPid)+import qualified System.Process (getPid)+#else+import System.Process+import System.Process.Internals+import Control.Concurrent.MVar+#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+  getProcessID' (ProcessHandle mh _ _) = do+    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
+ src/Language/Haskell/LSP/Test/Decoding.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.Haskell.LSP.Test.Decoding where++import           Prelude                 hiding ( id )+import           Data.Aeson+import           Control.Lens+import qualified Data.ByteString.Lazy.Char8    as B+import           Data.Maybe+import           System.IO+import           Language.Haskell.LSP.Types+                                         hiding ( error )+import           Language.Haskell.LSP.Messages+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   -> error "Couldn't read Content-Length header"+    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 <- hGetLine h+  let (name, val) = span (/= ':') l+  if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h++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+    (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+  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+  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" (fromJust $ decode bytes :: Object) 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+        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++      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"
+ src/Language/Haskell/LSP/Test/Exceptions.hs view
@@ -0,0 +1,46 @@+module Language.Haskell.LSP.Test.Exceptions where++import Control.Exception+import Language.Haskell.LSP.Messages+import Language.Haskell.LSP.Types+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+                      | UnexpectedMessage String FromServerMessage+                      | ReplayOutOfOrder FromServerMessage [FromServerMessage]+                      | UnexpectedDiagnostics+                      | IncorrectApplyEditRequest String+                      | UnexpectedResponseError LspIdRsp ResponseError+  deriving Eq++instance Exception SessionException++instance Show SessionException where+  show Timeout = "Timed out waiting to receive a message from the server."+  show (UnexpectedMessage expected lastMsg) =+    "Received an unexpected message from the server:\n" +++    "Was parsing: " ++ expected ++ "\n" +++    "Last message received: " ++ show 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" +++       "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++-- | A predicate that matches on any 'SessionException'+anySessionException :: SessionException -> Bool+anySessionException = const True
+ src/Language/Haskell/LSP/Test/Files.hs view
@@ -0,0 +1,97 @@+{-# 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 hiding ( error )+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 newSymbols = fmap (fmap (swapUri location)) $ r ^. result+      in RspDocumentSymbols $ result .~ newSymbols $ r++    fromServerMsg (RspRename r) =+      let oldResult = r ^. result :: Maybe WorkspaceEdit+          newResult = fmap swapWorkspaceEdit oldResult+      in RspRename $ result .~ newResult $ r++    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
+ src/Language/Haskell/LSP/Test/Messages.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE RankNTypes #-}+module Language.Haskell.LSP.Test.Messages where++import Data.Aeson+import Language.Haskell.LSP.Messages+import Language.Haskell.LSP.Types hiding (error)++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 (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+    (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+    (NotPublishDiagnostics       m) -> notification m+    (NotLogMessage               m) -> notification m+    (NotShowMessage              m) -> notification m+    (NotTelemetry                m) -> notification m+    (NotCancelRequestFromServer  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+ (ReqRename                   m) -> request m+ (ReqExecuteCommand           m) -> request m+ (ReqDocumentLink             m) -> request m+ (ReqDocumentLinkResolve      m) -> request m+ (ReqWillSaveWaitUntil        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+ (UnknownFromClientMessage    m) -> error $ "Unknown message sent from client: " ++ show m
+ src/Language/Haskell/LSP/Test/Parsing.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Haskell.LSP.Test.Parsing+  ( -- $receiving+    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+import Data.Maybe+import qualified Data.Text as T+import Data.Typeable+import Language.Haskell.LSP.Messages+import Language.Haskell.LSP.Types as LSP hiding (error, message)+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 +-- @++satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage+satisfy pred = do+  +  skipTimeout <- overridingTimeout <$> get+  timeoutId <- curTimeoutId <$> get+  unless skipTimeout $ do+    chan <- asks messageChan+    timeout <- asks (messageTimeout . config)+    void $ liftIO $ forkIO $ do+      threadDelay (timeout * 1000000)+      writeChan chan (TimeoutMessage timeoutId)++  x <- await++  unless skipTimeout $+    modify $ \s -> s { curTimeoutId = timeoutId + 1 }++  modify $ \s -> s { lastReceivedMessage = Just x }++  if pred x+    then do+      logMsg LogServer x+      return x+    else empty++-- | 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) $+    castMsg <$> satisfy (isJust . 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)+  x <- satisfy (maybe False (\z -> z ^. LSP.id == responseId lid) . parser)+  return $ castMsg x++-- | Matches any type of message.+anyMessage :: Session FromServerMessage+anyMessage = satisfy (const True)++-- | A stupid method for getting out the inner message.+castMsg :: FromJSON a => FromServerMessage -> a+castMsg = fromMaybe (error "Failed casting a message") . decode . encodeMsg++-- | 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" $ do+  NotPublishDiagnostics diags <- satisfy test+  return diags+  where test (NotPublishDiagnostics _) = True+        test _ = False
+ src/Language/Haskell/LSP/Test/Replay.hs view
@@ -0,0 +1,232 @@+-- | 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 as LSP hiding (error)+import           Data.Aeson+import           Data.Default+import           Data.List+import           Data.Maybe+import           Control.Lens hiding (List)+import           Control.Monad+import           System.FilePath+import           Language.Haskell.LSP.Test+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".+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 pid -> do++    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+                            (listenServer serverMsgs requestMap reqSema rspSema passSema mainThread)+                            def+                            fullCaps+                            sessionDir+                            (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 . _Just . LSP.capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp+          Nothing -> rsp+        oldCommands = rsp ^? result . _Just . 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
+ src/Language/Haskell/LSP/Test/Server.hs view
@@ -0,0 +1,28 @@+module Language.Haskell.LSP.Test.Server (withServer) where++import Control.Concurrent+import Control.Monad+import Language.Haskell.LSP.Test.Compat+import System.IO+import System.Process++withServer :: String -> Bool -> (Handle -> Handle -> Int -> 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 }+  (Just serverIn, Just serverOut, Just serverErr, serverProc) <- createProcess createProc++  -- Need to continuously consume to stderr else it gets blocked+  -- Can't pass NoStream either to std_err+  hSetBuffering serverErr NoBuffering+  errSinkThread <- forkIO $ forever $ hGetLine serverErr >>= when logStdErr . putStrLn++  pid <- getProcessID serverProc++  result <- f serverIn serverOut pid++  killThread errSinkThread+  terminateProcess serverProc+  return result
+ src/Language/Haskell/LSP/Test/Session.hs view
@@ -0,0 +1,322 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}++module Language.Haskell.LSP.Test.Session+  ( Session+  , SessionConfig(..)+  , defaultConfig+  , SessionMessage(..)+  , SessionContext(..)+  , SessionState(..)+  , runSessionWithHandles+  , get+  , put+  , modify+  , modifyM+  , ask+  , asks+  , sendMessage+  , updateState+  , withTimeout+  , logMsg+  , LogMsgType(..)+  )++where++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+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 (get, put)+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.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 hiding (error)+import Language.Haskell.LSP.VFS+import Language.Haskell.LSP.Test.Decoding+import Language.Haskell.LSP.Test.Exceptions+import System.Console.ANSI+import System.Directory+import System.IO++-- | A session representing one instance of launching and connecting to a server.+-- +-- You can send and receive messages to the server within 'Session' via 'getMessage',+-- 'sendRequest' and 'sendNotification'.+--++type Session = ParserStateReader FromServerMessage SessionState SessionContext IO++-- | 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.+  , logMessages    :: Bool -- ^ Trace the messages sent and received to stdout, defaults to True.+  , logColor       :: Bool -- ^ Add ANSI color to the logged messages, defaults to True.+  }++-- | The configuration used in 'Language.Haskell.LSP.Test.runSession'.+defaultConfig :: SessionConfig+defaultConfig = SessionConfig 60 False True True++instance Default SessionConfig where+  def = defaultConfig++data SessionMessage = ServerMessage FromServerMessage+                    | TimeoutMessage Int+  deriving Show++data SessionContext = SessionContext+  {+    serverIn :: Handle+  , rootDir :: FilePath+  , messageChan :: Chan SessionMessage+  , 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 Monad m => HasReader r (ParserStateReader a s r m) where+  ask = lift $ lift Reader.ask++instance Monad m => HasReader SessionContext (ConduitM a b (StateT s (ReaderT SessionContext m))) where+  ask = lift $ lift Reader.ask++data SessionState = SessionState+  {+    curReqId :: LspId+  , vfs :: VFS+  , curDiagnostics :: Map.Map Uri [Diagnostic]+  , curTimeoutId :: Int+  , overridingTimeout :: Bool+  -- ^ The last received message from the server.+  -- Used for providing exception information+  , lastReceivedMessage :: Maybe FromServerMessage+  }++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 Monad m => HasState s (ParserStateReader a s r m) where+  get = lift State.get+  put = lift . State.put++instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m))+ where+  get = lift State.get+  put = lift . State.put++type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))++runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState)+runSession context state 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)+      yield msg+      chanSource++    watchdog :: ConduitM SessionMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO)) ()+    watchdog = Conduit.awaitForever $ \msg -> do+      curId <- curTimeoutId <$> get+      case msg of+        ServerMessage sMsg -> yield sMsg+        TimeoutMessage tId -> when (curId == tId) $ 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+                      -> (Handle -> SessionContext -> IO ()) -- ^ Server listener+                      -> SessionConfig+                      -> ClientCapabilities+                      -> FilePath -- ^ Root directory+                      -> Session a+                      -> IO a+runSessionWithHandles serverIn serverOut serverHandler config caps rootDir session = do+  absRootDir <- canonicalizePath rootDir++  hSetBuffering serverIn  NoBuffering+  hSetBuffering serverOut NoBuffering++  reqMap <- newMVar newRequestMap+  messageChan <- newChan+  initRsp <- newEmptyMVar++  let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config caps+      initState = SessionState (IdInt 0) mempty mempty 0 False Nothing++  threadId <- forkIO $ void $ serverHandler serverOut context+  (result, _) <- runSession context initState session++  killThread threadId++  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 (NotPublishDiagnostics n) = do+  let List diags = n ^. params . diagnostics+      doc = n ^. params . uri+  modify (\s ->+    let newDiags = Map.insert doc diags (curDiagnostics s)+      in s { curDiagnostics = newDiags })++updateState (ReqApplyWorkspaceEdit r) = do++  allChangeParams <- case r ^. params . edit . documentChanges of+    Just (List cs) -> do+      mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs+      return $ map getParams cs+    Nothing -> case r ^. params . edit . changes of+      Just cs -> do+        mapM_ checkIfNeedsOpened (HashMap.keys cs)+        return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)+      Nothing -> error "No 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 t) = VirtualFile (fromMaybe oldV v) t+          newVFS = Map.adjust update uri oldVFS+      in s { vfs = newVFS }++  where checkIfNeedsOpened uri = do+          oldVFS <- vfs <$> get+          ctx <- ask++          -- if its not open, open it+          unless (uri `Map.member` 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 +              newVFS <- liftIO $ 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)++        textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..]++        textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits++        getChangeParams uri (List edits) = map 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 'TimeoutException'+-- after duration seconds. This will override the global timeout+-- for waiting for messages to arrive defined in 'SessionConfig'.+withTimeout :: Int -> Session a -> Session a+withTimeout duration f = do+  chan <- asks messageChan+  timeoutId <- curTimeoutId <$> get +  modify $ \s -> s { overridingTimeout = True }+  liftIO $ forkIO $ do+    threadDelay (duration * 1000000)+    writeChan chan (TimeoutMessage timeoutId)+  res <- f+  modify $ \s -> s { curTimeoutId = timeoutId + 1,+                     overridingTimeout = False +                   }+  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
+ test/Test.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}++import           Test.Hspec+import           Data.Aeson+import           Data.Default+import qualified Data.HashMap.Strict as HM+import           Data.Maybe+import qualified Data.Text as T+import           Control.Applicative.Combinators+import           Control.Concurrent+import           Control.Monad.IO.Class+import           Control.Monad+import           Control.Lens hiding (List)+import           GHC.Generics+import           Language.Haskell.LSP.Messages+import           Language.Haskell.LSP.Test+import           Language.Haskell.LSP.Test.Replay+import           Language.Haskell.LSP.Types.Capabilities+import           Language.Haskell.LSP.Types as LSP hiding (capabilities, message)+import           System.Timeout++{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}+{-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-}++main = hspec $ do+  describe "Session" $ do+    it "fails a test" $+      -- TODO: Catch the exception in haskell-lsp-test and provide nicer output+      let session = runSession "hie --lsp" fullCaps "test/data/renamePass" $ do+                      openDoc "Desktop/simple.hs" "haskell"+                      skipMany loggingNotification+                      anyRequest+        in session `shouldThrow` anyException+    it "initializeResponse" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do+      rsp <- initializeResponse+      liftIO $ rsp ^. result `shouldNotBe` Nothing++    it "runSessionWithConfig" $+      runSession "hie --lsp" didChangeCaps "test/data/renamePass" $ return ()++    describe "withTimeout" $ do+      it "times out" $+        let sesh = runSession "hie --lsp" fullCaps "test/data/renamePass" $ do+                    openDoc "Desktop/simple.hs" "haskell"+                    -- won't receive a request - will timeout+                    -- incoming logging requests shouldn't increase the+                    -- timeout+                    withTimeout 5 $ skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest+          -- wait just a bit longer than 5 seconds so we have time+          -- to open the document+          in timeout 6000000 sesh `shouldThrow` anySessionException+          +      it "doesn't time out" $+        let sesh = runSession "hie --lsp" fullCaps "test/data/renamePass" $ do+                    openDoc "Desktop/simple.hs" "haskell"+                    withTimeout 5 $ skipManyTill anyMessage publishDiagnosticsNotification+          in void $ timeout 6000000 sesh++      it "further timeout messages are ignored" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do+        doc <- openDoc "Desktop/simple.hs" "haskell"+        withTimeout 3 $ getDocumentSymbols doc+        liftIO $ threadDelay 5000000+        -- shouldn't throw an exception+        getDocumentSymbols doc+        return ()++      it "overrides global message timeout" $+        let sesh =+              runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" fullCaps "test/data/renamePass" $ do+                doc <- openDoc "Desktop/simple.hs" "haskell"+                -- shouldn't time out in here since we are overriding it+                withTimeout 10 $ liftIO $ threadDelay 7000000+                getDocumentSymbols doc+                return True+        in sesh `shouldReturn` True++      it "unoverrides global message timeout" $+        let sesh =+              runSessionWithConfig (def { messageTimeout = 5 }) "hie --lsp" fullCaps "test/data/renamePass" $ do+                doc <- openDoc "Desktop/simple.hs" "haskell"+                -- shouldn't time out in here since we are overriding it+                withTimeout 10 $ liftIO $ threadDelay 7000000+                getDocumentSymbols doc+                -- should now timeout+                skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest+        in sesh `shouldThrow` (== Timeout)+++    describe "SessionException" $ do+      it "throw on time out" $+        let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" fullCaps "test/data/renamePass" $ do+                skipMany loggingNotification+                _ <- message :: Session ApplyWorkspaceEditRequest+                return ()+        in sesh `shouldThrow` anySessionException++      it "don't throw when no time out" $ runSessionWithConfig (def {messageTimeout = 5}) "hie --lsp" fullCaps "test/data/renamePass" $ do+        loggingNotification+        liftIO $ threadDelay 10+        _ <- openDoc "Desktop/simple.hs" "haskell"+        return ()++      describe "UnexpectedMessageException" $ do+        it "throws when there's an unexpected message" $+          let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True+              selector _ = False+            in runSession "hie --lsp" fullCaps "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector+        it "provides the correct types that were expected and received" $+          let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True+              selector _ = False+              sesh = do+                doc <- openDoc "Desktop/simple.hs" "haskell"+                sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)+                skipMany anyNotification+                message :: Session RenameResponse -- the wrong type+            in runSession "hie --lsp" fullCaps "test/data/renamePass" sesh+              `shouldThrow` selector++  describe "replaySession" $ do+    it "passes a test" $+      replaySession "hie --lsp" "test/data/renamePass"+    it "fails a test" $+      let selector (ReplayOutOfOrder _ _) = True+          selector _ = False+        in replaySession "hie --lsp" "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++        (fooSymbol:_) <- getDocumentSymbols doc++        liftIO $ do+          fooSymbol ^. name `shouldBe` "foo"+          fooSymbol ^. kind `shouldBe` SkFunction++  describe "text document VFS" $+    it "sends back didChange notifications" $+      runSession "hie --lsp" def "test/data/refactor" $ do+        doc <- openDoc "Main.hs" "haskell"++        let args = toJSON $ AOP (doc ^. uri)+                                (Position 1 14)+                                "Redundant bracket"+            reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))+        request_ WorkspaceExecuteCommand reqParams++        editReq <- message :: Session ApplyWorkspaceEditRequest+        liftIO $ do+          let (Just cs) = editReq ^. params . edit . changes+              [(u, List es)] = HM.toList cs+          u `shouldBe` doc ^. uri+          es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]++        noDiagnostics++        contents <- documentContents doc+        liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"++  describe "getDocumentEdit" $+    it "automatically consumes applyedit requests" $+      runSession "hie --lsp" fullCaps "test/data/refactor" $ do+        doc <- openDoc "Main.hs" "haskell"++        let args = toJSON $ AOP (doc ^. uri)+                                (Position 1 14)+                                "Redundant bracket"+            reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))+        request_ WorkspaceExecuteCommand reqParams+        contents <- getDocumentEdit doc+        liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n"+        noDiagnostics++  describe "getAllCodeActions" $+    it "works" $ runSession "hie --lsp" fullCaps "test/data/refactor" $ do+      doc <- openDoc "Main.hs" "haskell"+      _ <- waitForDiagnostics+      actions <- getAllCodeActions doc+      liftIO $ do+        let [CommandOrCodeActionCodeAction action] = actions+        action ^. title `shouldBe` "Apply hint:Redundant bracket"+        action ^. command . _Just . command `shouldSatisfy` T.isSuffixOf ":applyrefact:applyOne"++  describe "getDocumentSymbols" $+    it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do+      doc <- openDoc "Desktop/simple.hs" "haskell"++      skipMany loggingNotification++      noDiagnostics++      (mainSymbol:_) <- getDocumentSymbols doc++      liftIO $ do+        mainSymbol ^. name `shouldBe` "main"+        mainSymbol ^. kind `shouldBe` SkFunction+        mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4)+        mainSymbol ^. containerName `shouldBe` Nothing++  describe "applyEdit" $ do+    it "increments the version" $ runSession "hie --lsp" docChangesCaps "test/data/renamePass" $ do+      doc <- openDoc "Desktop/simple.hs" "haskell"+      VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc+      let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo" +      VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit+      liftIO $ newVersion `shouldBe` oldVersion + 1+    it "changes the document contents" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do+      doc <- openDoc "Desktop/simple.hs" "haskell"+      let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo" +      applyEdit doc edit+      contents <- documentContents doc+      liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule"++  describe "getCompletions" $+    it "works" $ runSession "hie --lsp" def "test/data/renamePass" $ do+      doc <- openDoc "Desktop/simple.hs" "haskell"+      item:_ <- getCompletions doc (Position 5 5)+      liftIO $ do+        item ^. label `shouldBe` "interactWithUser"+        item ^. kind `shouldBe` Just CiFunction+        item ^. detail `shouldBe` Just "Items -> IO ()\nMain"++  describe "getReferences" $+    it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do+      doc <- openDoc "Desktop/simple.hs" "haskell"+      let pos = Position 40 3 -- interactWithUser+          uri = doc ^. LSP.uri+      refs <- getReferences doc pos True+      liftIO $ refs `shouldContain` map (Location uri) [+          mkRange 41 0 41 16+        , mkRange 75 6 75 22+        , mkRange 71 6 71 22+        ]++  describe "getDefinitions" $+    it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do+      doc <- openDoc "Desktop/simple.hs" "haskell"+      let pos = Position 49 25 -- addItem+      defs <- getDefinitions doc pos+      liftIO $ defs `shouldBe` [Location (doc ^. uri) (mkRange 28 0 28 7)]++  describe "waitForDiagnosticsSource" $+    it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do+      openDoc "Error.hs" "haskell"+      [diag] <- waitForDiagnosticsSource "ghcmod"+      liftIO $ do+        diag ^. severity `shouldBe` Just DsError+        diag ^. source `shouldBe` Just "ghcmod"++  describe "rename" $+    it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do+      doc <- openDoc "Rename.hs" "haskell"+      rename doc (Position 1 0) "bar"+      documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n"++  describe "getHover" $+    it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do+      doc <- openDoc "Desktop/simple.hs" "haskell"+      -- hover returns nothing until module is loaded+      skipManyTill loggingNotification $ count 2 noDiagnostics+      hover <- getHover doc (Position 45 9) -- putStrLn+      liftIO $ hover `shouldSatisfy` isJust++  describe "getHighlights" $+    it "works" $ runSession "hie --lsp" fullCaps "test/data/renamePass" $ do+      doc <- openDoc "Desktop/simple.hs" "haskell"+      skipManyTill loggingNotification $ count 2 noDiagnostics+      highlights <- getHighlights doc (Position 27 4) -- addItem+      liftIO $ length highlights `shouldBe` 4++  describe "formatDoc" $+    it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do+      doc <- openDoc "Format.hs" "haskell"+      oldContents <- documentContents doc+      formatDoc doc (FormattingOptions 4 True)+      documentContents doc >>= liftIO . (`shouldNotBe` oldContents)++  describe "formatRange" $+    it "works" $ runSession "hie --lsp" fullCaps "test/data" $ do+      doc <- openDoc "Format.hs" "haskell"+      oldContents <- documentContents doc+      formatRange doc (FormattingOptions 4 True) (Range (Position 1 10) (Position 2 10))+      documentContents doc >>= liftIO . (`shouldNotBe` oldContents)++  describe "closeDoc" $+    it "works" $+      let sesh =+            runSession "hie --lsp" fullCaps "test/data" $ do+              doc <- openDoc "Format.hs" "haskell"+              closeDoc doc+              -- need to evaluate to throw+              documentContents doc >>= liftIO . print+      in sesh `shouldThrow` anyException++mkRange sl sc el ec = Range (Position sl sc) (Position el ec)++didChangeCaps :: ClientCapabilities+didChangeCaps = def { _workspace = Just workspaceCaps }+  where+    workspaceCaps = def { _didChangeConfiguration = Just configCaps }+    configCaps = DidChangeConfigurationClientCapabilities (Just True)++docChangesCaps :: ClientCapabilities+docChangesCaps = def { _workspace = Just workspaceCaps }+  where+    workspaceCaps = def { _workspaceEdit = Just editCaps }+    editCaps = WorkspaceEditClientCapabilities (Just True)++data ApplyOneParams = AOP+  { file      :: Uri+  , start_pos :: Position+  , hintTitle :: String+  } deriving (Generic, ToJSON)