X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FParsing.hs;h=b28047ce0f93ac75fee9f54fad0581ab39d9ebf7;hb=0da56e90a0fd4ada9acb01ca9ce769c5924653ec;hp=2e829f372284373fa6d5673f9509e140c250387e;hpb=12ac9c23d054e92a82146320e2b061c11a87e3f1;p=opengl.git diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index 2e829f3..b28047c 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -1,84 +1,76 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} module Language.Haskell.LSP.Test.Parsing where import Control.Applicative -import Control.Concurrent.Chan -import Control.Concurrent.MVar -import Control.Monad.Trans.Class +import Control.Concurrent import Control.Monad.IO.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State +import Control.Monad.Trans.Class import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B -import Data.Conduit hiding (await) import Data.Conduit.Parser import Data.Maybe import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Test.Decoding +import Language.Haskell.LSP.Types hiding (error) +import Language.Haskell.LSP.Test.Exceptions import Language.Haskell.LSP.Test.Messages -import System.IO - -data SessionContext = SessionContext - { - serverIn :: Handle, - rootDir :: FilePath, - messageChan :: Chan FromServerMessage, - requestMap :: MVar RequestMap - } +import Language.Haskell.LSP.Test.Session +import System.Console.ANSI -newtype SessionState = SessionState - { - curReqId :: LspId - } - -type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) +satisfy :: (MonadIO m, MonadSessionConfig m) => (FromServerMessage -> Bool) -> ConduitParser FromServerMessage m FromServerMessage +satisfy pred = do + timeout <- timeout <$> lift sessionConfig + tId <- liftIO myThreadId + timeoutThread <- liftIO $ forkIO $ do + threadDelay (timeout * 1000000) + throwTo tId TimeoutException + x <- await + liftIO $ killThread timeoutThread --- | 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'. --- --- @ --- runSession \"path\/to\/root\/dir\" $ do --- docItem <- getDocItem "Desktop/simple.hs" "haskell" --- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem) --- diagnostics <- getMessage :: Session PublishDiagnosticsNotification --- @ -type Session = ParserStateReader FromServerMessage SessionState SessionContext IO + if pred x + then do + liftIO $ do + setSGR [SetColor Foreground Vivid Magenta] + putStrLn $ "<-- " ++ B.unpack (encodeMsg x) + setSGR [Reset] + return x + else empty -- | Matches if the message is a notification. -anyNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage -anyNotification = satisfy isServerNotification +anyNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage +anyNotification = named "Any notification" $ satisfy isServerNotification -notification :: forall m a. (Monad m, FromJSON a) => ConduitParser FromServerMessage m (NotificationMessage ServerMethod a) -notification = do +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) x <- satisfy (isJust . parser) - return $ fromJust $ decode $ encodeMsg x + return $ castMsg x -- | Matches if the message is a request. -anyRequest :: Monad m => ConduitParser FromServerMessage m FromServerMessage -anyRequest = satisfy isServerRequest +anyRequest :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage +anyRequest = named "Any request" $ satisfy isServerRequest -request :: forall m a b. (Monad m, FromJSON a, FromJSON b) => ConduitParser FromServerMessage m (RequestMessage ServerMethod a b) -request = do +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 $ fromJust $ decode $ encodeMsg x + return $ castMsg x -- | Matches if the message is a response. -anyResponse :: Monad m => ConduitParser FromServerMessage m FromServerMessage -anyResponse = satisfy isServerResponse +anyResponse :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage +anyResponse = named "Any response" $ satisfy isServerResponse -response :: forall m a. (Monad m, FromJSON a) => ConduitParser FromServerMessage m (ResponseMessage a) -response = do +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 $ fromJust $ decode $ 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. @@ -86,46 +78,17 @@ 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 :: Monad m => ConduitParser FromServerMessage m FromServerMessage -loggingNotification = satisfy shouldSkip +loggingNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m FromServerMessage +loggingNotification = named "Logging notification" $ satisfy shouldSkip where shouldSkip (NotLogMessage _) = True shouldSkip (NotShowMessage _) = True shouldSkip (ReqShowMessage _) = True shouldSkip _ = False -publishDiagnosticsNotification :: Monad m => ConduitParser FromServerMessage m PublishDiagnosticsNotification -publishDiagnosticsNotification = do +publishDiagnosticsNotification :: (MonadIO m, MonadSessionConfig m) => ConduitParser FromServerMessage m PublishDiagnosticsNotification +publishDiagnosticsNotification = named "Publish diagnostics notification" $ do NotPublishDiagnostics diags <- satisfy test return diags where test (NotPublishDiagnostics _) = True test _ = False \ No newline at end of file - -satisfy :: Monad m => (a -> Bool) -> ConduitParser a m a -satisfy pred = do - x <- await - if pred x - then return x - else empty - -chanSource :: MonadIO m => Chan o -> ConduitT i o m b -chanSource c = do - x <- liftIO $ readChan c - yield x - chanSource c - -runSession' :: Chan FromServerMessage -> SessionContext -> SessionState -> Session a -> IO (a, SessionState) -runSession' chan context state session = runReaderT (runStateT conduit state) context - where conduit = runConduit $ chanSource chan .| runConduitParser session - -get :: Monad m => ParserStateReader a s r m s -get = lift Control.Monad.Trans.State.get - -put :: Monad m => s -> ParserStateReader a s r m () -put = lift . Control.Monad.Trans.State.put - -modify :: Monad m => (s -> s) -> ParserStateReader a s r m () -modify = lift . Control.Monad.Trans.State.modify - -ask :: Monad m => ParserStateReader a s r m r -ask = lift $ lift Control.Monad.Trans.Reader.ask