, directory
, filepath
, lens
+ , mtl
, parser-combinators
, process >= 1.6.3
, text
module Language.Haskell.LSP.Test.Exceptions where
import Control.Exception
+import Language.Haskell.LSP.Messages
data SessionException = TimeoutException
- deriving Show
+ | UnexpectedMessageException String FromServerMessage
+
instance Exception SessionException
+instance Show SessionException where
+ show TimeoutException = "Timed out waiting to receive a message from the server."
+ show (UnexpectedMessageException expected lastMsg) =
+ "Received an unexpected message from the server:\n" ++
+ "Expected: " ++ expected ++ "\n" ++
+ "Last message accepted: " ++ show lastMsg
+
anySessionException :: SessionException -> Bool
anySessionException = const True
\ No newline at end of file
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
module Language.Haskell.LSP.Test.Parsing where
import Control.Applicative
satisfy pred = do
timeout <- timeout <$> lift sessionConfig
tId <- liftIO myThreadId
- liftIO $ forkIO $ do
+ timeoutThread <- liftIO $ forkIO $ do
threadDelay (timeout * 1000000)
throwTo tId TimeoutException
x <- await
+ liftIO $ killThread timeoutThread
if pred x
then return x
else empty
-- | Matches if the message is a notification.
anyNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
-anyNotification = satisfy isServerNotification
+anyNotification = named "Any notification" $ satisfy isServerNotification
notification :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (NotificationMessage ServerMethod a)
-notification = do
+notification = named "Notification" $ do
let parser = decode . encodeMsg :: FromServerMessage -> Maybe (NotificationMessage ServerMethod a)
x <- satisfy (isJust . parser)
- return $ decodeMsg $ encodeMsg x
+ return $ castMsg x
-- | Matches if the message is a request.
anyRequest :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
-anyRequest = satisfy isServerRequest
+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 = do
+request = named "Request" $ do
let parser = decode . encodeMsg :: FromServerMessage -> Maybe (RequestMessage ServerMethod a b)
x <- satisfy (isJust . parser)
- return $ decodeMsg $ encodeMsg x
+ return $ castMsg x
-- | Matches if the message is a response.
anyResponse :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage
-anyResponse = satisfy isServerResponse
+anyResponse = named "Any response" $ satisfy isServerResponse
response :: forall m a. (MonadIO m, MonadSessionConfig m, FromJSON a) => ConduitParser FromServerMessage m (ResponseMessage a)
-response = do
+response = named "Response" $ do
let parser = decode . encodeMsg :: FromServerMessage -> Maybe (ResponseMessage a)
x <- satisfy (isJust . parser)
- return $ decodeMsg $ encodeMsg x
+ return $ castMsg x
+
+-- | 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 })
-decodeMsg :: FromJSON a => B.ByteString -> a
-decodeMsg x = fromMaybe (error $ "Unexpected message type\nGot:\n " ++ show x)
- (decode x)
-
-- | 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 = satisfy shouldSkip
+loggingNotification = named "Logging notification" $ satisfy shouldSkip
where
shouldSkip (NotLogMessage _) = True
shouldSkip (NotShowMessage _) = True
shouldSkip _ = False
publishDiagnosticsNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m PublishDiagnosticsNotification
-publishDiagnosticsNotification = do
+publishDiagnosticsNotification = named "Publish diagnostics notification" $ do
NotPublishDiagnostics diags <- satisfy test
return diags
where test (NotPublishDiagnostics _) = True
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.Trans.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, modify)
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Aeson
-import Data.Conduit
+import Data.Conduit hiding (await)
import Data.Conduit.Parser
import Data.Default
import Data.Foldable
import Data.List
+import qualified Data.Text as T
import qualified Data.HashMap.Strict as HashMap
import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.TH.ClientCapabilities
import Language.Haskell.LSP.VFS
import Language.Haskell.LSP.Test.Compat
import Language.Haskell.LSP.Test.Decoding
+import Language.Haskell.LSP.Test.Exceptions
import System.Directory
import System.IO
runSession :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
runSession chan preprocessor context state session = runReaderT (runStateT conduit state) context
- where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser session
+ where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler)
+ handler e@(Unexpected "ConduitParser.empty") = do
+
+ -- Horrible way to get last item in conduit:
+ -- Add a fake message so we can tell when to stop
+ liftIO $ writeChan chan (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing))
+ x <- peek
+ case x of
+ Just x -> do
+ lastMsg <- skipToEnd x
+ name <- getParserName
+ liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg)
+ Nothing -> throw e
+
+ handler e = throw e
+
+ skipToEnd x = do
+ y <- peek
+ case y of
+ Just (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) -> return x
+ Just _ -> await >>= skipToEnd
+ Nothing -> return x
get :: Monad m => ParserStateReader a s r m s
get = lift State.get
import Control.Monad.IO.Class
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.TH.ClientCapabilities
conf = def { capabilities = caps }
runSessionWithConfig conf "hie --lsp" "test/data/renamePass" $ return ()
- it "times out" $
+ describe "exceptions" $ do
+ it "throw on time out" $
let sesh = runSessionWithConfig (def {timeout = 10}) "hie --lsp" "test/data/renamePass" $ do
skipMany loggingNotification
_ <- request :: Session ApplyWorkspaceEditRequest
return ()
in sesh `shouldThrow` anySessionException
- it "doesn't time out" $ runSessionWithConfig (def {timeout = 10}) "hie --lsp" "test/data/renamePass" $ do
+ it "don't throw when no time out" $ runSessionWithConfig (def {timeout = 10}) "hie --lsp" "test/data/renamePass" $ do
loggingNotification
liftIO $ threadDelay 5
+ it "throw when there's an unexpected message" $
+ let msgExc (UnexpectedMessageException "Publish diagnostics notification" (NotLogMessage _)) = True
+ msgExc _ = False
+ in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` msgExc
+
+ it "throw when there's an unexpected message 2" $
+ let msgExc (UnexpectedMessageException "Response" (NotPublishDiagnostics _)) = True
+ msgExc _ = False
+ sesh = do
+ doc <- openDoc "Desktop/simple.hs" "haskell"
+ sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
+ skipMany anyNotification
+ response :: Session RenameResponse -- the wrong type
+ in runSession "hie --lsp" "test/data/renamePass" sesh
+ `shouldThrow` msgExc
describe "replay session" $ do
it "passes a test" $
projects / opengl.git / commitdiff