X-Git-Url: http://git.lukelau.me/?a=blobdiff_plain;f=src%2FLanguage%2FHaskell%2FLSP%2FTest%2FParsing.hs;h=2936b31347f9db69ecf4b1a3951c552336953cfb;hb=7ee14165e9d2ebcc171716d41e3e207444c418b3;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..2936b31 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -1,131 +1,108 @@ {-# 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.Lens import Control.Monad.IO.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State +import Control.Monad import Data.Aeson +import Data.Aeson.Encode.Pretty import qualified Data.ByteString.Lazy.Char8 as B -import Data.Conduit hiding (await) 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 -import Language.Haskell.LSP.Test.Decoding +import Language.Haskell.LSP.Types as LSP hiding (error) import Language.Haskell.LSP.Test.Messages -import System.IO - -data SessionContext = SessionContext - { - serverIn :: Handle, - rootDir :: FilePath, - messageChan :: Chan FromServerMessage, - requestMap :: MVar RequestMap - } - -newtype SessionState = SessionState - { - curReqId :: LspId - } - -type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) - --- | 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 +import Language.Haskell.LSP.Test.Session +import System.Console.ANSI --- | Matches if the message is a notification. -anyNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage -anyNotification = satisfy isServerNotification +satisfy :: (FromServerMessage -> Bool) -> Session FromServerMessage +satisfy pred = do -notification :: forall m a. (Monad m, FromJSON a) => ConduitParser FromServerMessage m (NotificationMessage ServerMethod a) -notification = do - let parser = decode . encodeMsg :: FromServerMessage -> Maybe (NotificationMessage ServerMethod a) - x <- satisfy (isJust . parser) - return $ fromJust $ decode $ encodeMsg x + 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) --- | Matches if the message is a request. -anyRequest :: Monad m => ConduitParser FromServerMessage m FromServerMessage -anyRequest = satisfy isServerRequest + x <- await + + unless skipTimeout $ + modify $ \s -> s { curTimeoutId = timeoutId + 1 } + + modify $ \s -> s { lastReceivedMessage = Just x } + + if pred x + then do + shouldLog <- asks $ logMessages . config + liftIO $ when shouldLog $ do + setSGR [SetColor Foreground Dull Magenta] + putStrLn $ "<-- " ++ B.unpack (encodeMsgPretty x) + setSGR [Reset] + return x + else empty -request :: forall m a b. (Monad m, FromJSON a, FromJSON b) => ConduitParser FromServerMessage m (RequestMessage ServerMethod a b) -request = do - let parser = decode . encodeMsg :: FromServerMessage -> Maybe (RequestMessage ServerMethod a b) - x <- satisfy (isJust . parser) - return $ fromJust $ decode $ encodeMsg x +-- | Matches a message of type 'a'. +message :: forall a. (Typeable a, FromJSON a) => Session a +message = + let parser = decode . encodeMsg :: FromServerMessage -> Maybe a + in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $ + 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 :: Monad m => ConduitParser FromServerMessage m FromServerMessage -anyResponse = satisfy isServerResponse +anyResponse :: Session FromServerMessage +anyResponse = named "Any response" $ satisfy isServerResponse -response :: forall m a. (Monad m, FromJSON a) => ConduitParser FromServerMessage m (ResponseMessage a) -response = 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 (isJust . parser) - return $ fromJust $ decode $ encodeMsg x + x <- satisfy (maybe False (\z -> z ^. LSP.id == responseId lid) . parser) + return $ castMsg x + +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 }) +encodeMsgPretty :: FromServerMessage -> B.ByteString +encodeMsgPretty = encodePretty . 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 :: Session 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 :: Session PublishDiagnosticsNotification +publishDiagnosticsNotification = named "Publish diagnostics notification" $ do NotPublishDiagnostics diags <- satisfy test return diags where test (NotPublishDiagnostics _) = True test _ = False - -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