copyright: 2018 Luke Lau
category: Testing
build-type: Simple
-cabal-version: >=1.10
+cabal-version: >=2.0
extra-source-files: README.md
library
- hs-source-dirs: src
+ hs-source-dirs: lib
exposed-modules: Language.Haskell.LSP.Test
, Language.Haskell.LSP.Test.Replay
+ , Language.Haskell.LSP.Test.Machine
default-language: Haskell2010
build-depends: base >= 4.7 && < 5
+ , haskell-lsp-types
+ , haskell-lsp >= 0.3
+ , haskell-lsp-test-internal
+ , aeson
+ , bytestring
+ , containers
+ , data-default
+ , directory
+ , filepath
+ , lens
+ , parser-combinators
+ , text
+ , unordered-containers
+ , yi-rope
+
+ ghc-options: -W
+
+library haskell-lsp-test-internal
+ hs-source-dirs: src
+ default-language: Haskell2010
+ exposed-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.Script
+ Language.Haskell.LSP.Test.Server
+ Language.Haskell.LSP.Test.Session
+ build-depends: base
, haskell-lsp-types
, haskell-lsp >= 0.3
, aeson
, filepath
, lens
, mtl
+ , scientific
, parser-combinators
, process
, text
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
+
+executable lsp-test
+ hs-source-dirs: lsp-test
+ main-is: Main.hs
+ default-language: Haskell2010
+ build-depends: base >= 4.7 && < 5
+ , haskell-lsp-types
+ , haskell-lsp >= 0.3
+ , haskell-lsp-test-internal
+ , haskell-lsp-test
+ , aeson
+ , bytestring
+ , directory
+ , filepath
+ , text
+ , unordered-containers
+ , scientific
+
test-suite tests
type: exitcode-stdio-1.0
main-is: Test.hs
, data-default
, directory
, haskell-lsp-test
+ , haskell-lsp-test-internal
, haskell-lsp
, haskell-lsp-types
, conduit
, aeson
, unordered-containers
, text
- other-modules: ParsingTests
default-language: Haskell2010
-executable example
+executable lsp-test-example
hs-source-dirs: example
main-is: Main.hs
default-language: Haskell2010
, runSessionWithConfig
, Session
, SessionConfig(..)
- , MonadSessionConfig(..)
, SessionException(..)
, anySessionException
+ , withTimeout
-- * Sending
, sendRequest
, sendRequest_
, sendNotification'
, sendResponse
-- * Receving
+ , message
, anyRequest
- , request
, anyResponse
- , response
, anyNotification
- , notification
, anyMessage
, loggingNotification
, publishDiagnosticsNotification
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map as Map
import Data.Maybe
- import Language.Haskell.LSP.Types hiding (id, capabilities)
+ import Language.Haskell.LSP.Types hiding (id, capabilities, message)
import qualified Language.Haskell.LSP.Types as LSP
import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.VFS
sendNotification Exit ExitParams
return result
-
+ where
-- | Listens to the server output, makes sure it matches the record and
-- signals any semaphores
- listenServer :: Handle -> Session ()
- listenServer serverOut = do
- msgBytes <- liftIO $ getNextMessage serverOut
+ listenServer :: Handle -> SessionContext -> IO ()
+ listenServer serverOut context = do
+ msgBytes <- getNextMessage serverOut
- context <- ask
- reqMap <- liftIO $ readMVar $ requestMap context
+ reqMap <- readMVar $ requestMap context
let msg = decodeFromServerMsg reqMap msgBytes
- liftIO $ writeChan (messageChan context) msg
+ writeChan (messageChan context) (ServerMessage msg)
- listenServer serverOut
+ listenServer serverOut context
-- | The current text contents of a document.
documentContents :: TextDocumentIdentifier -> Session T.Text
-- and returns the new content
getDocumentEdit :: TextDocumentIdentifier -> Session T.Text
getDocumentEdit doc = do
- req <- request :: Session ApplyWorkspaceEditRequest
+ req <- message :: Session ApplyWorkspaceEditRequest
unless (checkDocumentChanges req || checkChanges req) $
liftIO $ throw (IncorrectApplyEditRequestException (show req))
waitForDiagnostics :: Session [Diagnostic]
waitForDiagnostics = do
- diagsNot <- skipManyTill anyMessage notification :: Session PublishDiagnosticsNotification
+ diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification
let (List diags) = diagsNot ^. params . LSP.diagnostics
return diags
-- returned.
noDiagnostics :: Session ()
noDiagnostics = do
- diagsNot <- notification :: Session PublishDiagnosticsNotification
+ diagsNot <- message :: Session PublishDiagnosticsNotification
when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
-- | Returns the symbols in a document.
where handleEdit :: WorkspaceEdit -> Session ()
handleEdit e =
let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e)
- in processMessage (ReqApplyWorkspaceEdit req)
+ in updateState (ReqApplyWorkspaceEdit req)
import Data.Maybe
import Control.Lens hiding (List)
import Control.Monad
- import System.IO
import System.FilePath
import Language.Haskell.LSP.Test
import Language.Haskell.LSP.Test.Files
isNotification (NotCancelRequestFromServer _) = True
isNotification _ = False
- listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar () -> ThreadId -> Handle -> Session ()
- listenServer [] _ _ _ passSema _ _ = liftIO $ putMVar passSema ()
- listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut = do
-
- msgBytes <- liftIO $ getNextMessage serverOut
+ -- 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
+ 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
+ then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx
else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs
++ [head $ dropWhile isNotification expectedMsgs]
exc = ReplayOutOfOrderException msg remainingMsgs
in liftIO $ throwTo mainThreadId exc
where
- response :: ResponseMessage a -> Session ()
+ response :: ResponseMessage a -> IO ()
response res = do
- liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id)
+ putStrLn $ "Got response for id " ++ show (res ^. id)
- liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
+ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request
- request :: RequestMessage ServerMethod a b -> Session ()
+ request :: RequestMessage ServerMethod a b -> IO ()
request req = do
- liftIO
- $ putStrLn
+ putStrLn
$ "Got request for id "
++ show (req ^. id)
++ " "
++ show (req ^. method)
- liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
+ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response
- notification :: NotificationMessage ServerMethod a -> Session ()
- notification n = liftIO $ putStrLn $ "Got notification " ++ show (n ^. method)
+ notification :: NotificationMessage ServerMethod a -> IO ()
+ notification n = putStrLn $ "Got notification " ++ show (n ^. method)
import Control.Concurrent
import Control.Lens
import Control.Monad.IO.Class
- import Control.Monad.Trans.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)
- import Language.Haskell.LSP.Test.Exceptions
import Language.Haskell.LSP.Test.Messages
import Language.Haskell.LSP.Test.Session
import System.Console.ANSI
- satisfy :: (MonadIO m, MonadSessionConfig m) => (FromServerMessage -> Bool) -> ConduitParser FromServerMessage m FromServerMessage
+ satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage
satisfy pred = do
- timeout <- timeout <$> lift sessionConfig
- tId <- liftIO myThreadId
- timeoutThread <- liftIO $ forkIO $ do
+
+ skipTimeout <- overridingTimeout <$> get
+ timeoutId <- curTimeoutId <$> get
+ unless skipTimeout $ do
+ chan <- asks messageChan
+ timeout <- asks (messageTimeout . config)
+ void $ liftIO $ forkIO $ do
threadDelay (timeout * 1000000)
- throwTo tId TimeoutException
+ writeChan chan (TimeoutMessage timeoutId)
+
x <- await
- liftIO $ killThread timeoutThread
+
+ unless skipTimeout $
+ modify $ \s -> s { curTimeoutId = timeoutId + 1 }
+
+ modify $ \s -> s { lastReceivedMessage = Just x }
if pred x
then do
return x
else empty
- -- | Matches if the message is a notification.
- anyNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
- anyNotification = named "Any notification" $ satisfy isServerNotification
-
- notification :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (NotificationMessage ServerMethod a)
- notification = named "Notification" $ do
- let parser = decode . encodeMsg :: FromServerMessage -> Maybe (NotificationMessage ServerMethod a)
+ -- | 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) $ do
x <- satisfy (isJust . parser)
return $ castMsg x
+ -- | Matches if the message is a notification.
+ anyNotification :: Session FromServerMessage
+ anyNotification = named "Any notification" $ satisfy isServerNotification
+
-- | Matches if the message is a request.
- anyRequest :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
+ anyRequest :: Session FromServerMessage
anyRequest = named "Any request" $ satisfy isServerRequest
- request :: forall m a b. (MonadIO m, MonadSessionConfig m, FromJSON a, FromJSON b) => ConduitParser FromServerMessage m (RequestMessage ServerMethod a b)
- request = named "Request" $ do
- let parser = decode . encodeMsg :: FromServerMessage -> Maybe (RequestMessage ServerMethod a b)
- x <- satisfy (isJust . parser)
- return $ castMsg x
-
-- | Matches if the message is a response.
- anyResponse :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
+ anyResponse :: Session FromServerMessage
anyResponse = named "Any response" $ satisfy isServerResponse
- response :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (ResponseMessage a)
- response = named "Response" $ do
- let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
- x <- satisfy (isJust . parser)
- return $ castMsg x
-
- responseForId :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => LspId -> ConduitParser FromServerMessage m (ResponseMessage a)
- responseForId lid = named "Response for id" $ do
+ 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
- anyMessage :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
+ anyMessage :: Session FromServerMessage
anyMessage = satisfy (const True)
-- | A stupid method for getting out the inner message.
-- | A version of encode that encodes FromServerMessages as if they
-- weren't wrapped.
encodeMsg :: FromServerMessage -> B.ByteString
-encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
+encodeMsg = encode . toJSONMsg
+
+toJSONMsg :: FromServerMessage -> Value
+toJSONMsg = genericToJSON (defaultOptions { sumEncoding = UntaggedValue })
-- | Matches if the message is a log message notification or a show message notification/request.
- loggingNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
+ loggingNotification :: Session FromServerMessage
loggingNotification = named "Logging notification" $ satisfy shouldSkip
where
shouldSkip (NotLogMessage _) = True
shouldSkip (ReqShowMessage _) = True
shouldSkip _ = False
- publishDiagnosticsNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m PublishDiagnosticsNotification
+ publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
publishDiagnosticsNotification = named "Publish diagnostics notification" $ do
NotPublishDiagnostics diags <- satisfy test
return diags
projects / lsp-test.git / commitdiff