From: Luke Lau Date: Fri, 8 Jun 2018 19:37:11 +0000 (-0400) Subject: Switch to conduit based parser X-Git-Tag: 0.1.0.0~85 X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=commitdiff_plain;h=d8ce5332e9ac2dc24bf1490f03bd30abb17196e8 Switch to conduit based parser --- diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index 7dcbc71..22b43aa 100644 --- a/haskell-lsp-test.cabal +++ b/haskell-lsp-test.cabal @@ -21,17 +21,19 @@ library build-depends: base >= 4.7 && < 5 , haskell-lsp-types , haskell-lsp - , data-default - , bytestring , aeson - , lens + , bytestring + , conduit-parse + , conduit + , containers + , data-default + , directory , filepath + , lens + , parsers + , process , text , transformers - , parsec - , process - , directory - , containers , unordered-containers if os(windows) build-depends: win32 diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 495714c..4de02fe 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -16,42 +16,59 @@ module Language.Haskell.LSP.Test -- * Sessions runSession , runSessionWithHandler - -- | 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 - -- @ , Session -- * Sending , sendRequest , sendNotification , sendRequest' , sendNotification' - , sendResponse' + , sendResponse -- * Receving , request , response , notification , loggingNotification - -- * Parsing + -- * Combinators + , choice + , option + , optional + , skipOptional + , between + , some , many + , sepBy + , sepBy1 + , sepByNonEmpty + , sepEndBy1 + , sepEndByNonEmpty + , sepEndBy + , endBy1 + , endByNonEmpty + , endBy + , count + , chainl + , chainr + , chainl1 + , chainr1 + , manyTill + , try + , () , skipMany + , skipSome + , unexpected + , notFollowedBy + , (<|>) + , satisfy -- * Utilities , getDocItem , getDocUri ) where +import Control.Applicative import Control.Monad -import Control.Monad.Trans.Class import Control.Monad.IO.Class -import Control.Monad.Trans.Reader import Control.Concurrent +import Control.Lens import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Aeson @@ -59,7 +76,8 @@ import qualified Data.ByteString.Lazy.Char8 as B import Data.Default import Data.Proxy import System.Process -import Language.Haskell.LSP.Types hiding (error, id) +import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types as LSP (error) import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Test.Compat import System.IO @@ -67,7 +85,7 @@ import System.Directory import System.FilePath import Language.Haskell.LSP.Test.Decoding import Language.Haskell.LSP.Test.Parsing -import Text.Parsec +import Text.Parser.Combinators -- | Starts a new session. runSession :: FilePath -- ^ The filepath to the root directory for the session. @@ -88,9 +106,8 @@ runSession rootDir session = do -- Wrap the session around initialize and shutdown calls sendRequest (Proxy :: Proxy InitializeRequest) Initialize initializeParams - -- (ResponseMessage _ _ (Just (InitializeResponseCapabilities _)) e) <- getMessage - -- liftIO $ maybe (return ()) (putStrLn . ("Error when initializing: " ++) . show ) e - (RspInitialize _ ) <- response + RspInitialize initRsp <- response + liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error) sendNotification Initialized InitializedParams @@ -99,6 +116,8 @@ runSession rootDir session = do sendNotification Exit ExitParams +-- | 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. runSessionWithHandler :: (Handle -> Session ()) -> FilePath -> Session a @@ -120,14 +139,12 @@ runSessionWithHandler serverHandler rootDir session = do let context = SessionContext serverIn absRootDir messageChan reqMap initState = SessionState (IdInt 9) - forkIO $ void $ runReaderT (runParserT (serverHandler serverOut) initState "" meaninglessChan) context - result <- runReaderT (runParserT session initState "" messageChan) context + forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut) + (result, _) <- runSession' messageChan context initState session terminateProcess serverProc - case result of - Right x -> return x - Left err -> error $ show err + return result -- | Listens to the server output, makes sure it matches the record and -- signals any semaphores @@ -135,7 +152,7 @@ listenServer :: Handle -> Session () listenServer serverOut = do msgBytes <- liftIO $ getNextMessage serverOut - context <- lift ask + context <- ask reqMap <- liftIO $ readMVar $ requestMap context liftIO $ writeChan (messageChan context) $ decodeFromServerMsg reqMap msgBytes @@ -156,8 +173,8 @@ sendRequest -> params -- ^ The request parameters. -> Session LspId -- ^ The id of the request that was sent. sendRequest _ method params = do - id <- curReqId <$> getState - modifyState $ \c -> c { curReqId = nextId id } + id <- curReqId <$> get + modify $ \c -> c { curReqId = nextId id } let req = RequestMessage "2.0" id method params :: RequestMessage ClientMethod params resp @@ -171,7 +188,7 @@ sendRequest _ method params = do sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session () sendRequest' req = do -- Update the request map - reqMap <- requestMap <$> lift ask + reqMap <- requestMap <$> ask liftIO $ modifyMVar_ reqMap (return . flip updateRequestMap req) sendMessage req @@ -188,12 +205,12 @@ sendNotification method params = sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session () sendNotification' = sendMessage -sendResponse' :: ToJSON a => ResponseMessage a -> Session () -sendResponse' = sendMessage +sendResponse :: ToJSON a => ResponseMessage a -> Session () +sendResponse = sendMessage sendMessage :: ToJSON a => a -> Session () sendMessage msg = do - h <- serverIn <$> lift ask + h <- serverIn <$> ask liftIO $ B.hPut h $ addHeader (encode msg) -- | Reads in a text document as the first version. @@ -201,7 +218,7 @@ 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 <- lift ask + context <- ask let fp = rootDir context file contents <- liftIO $ T.readFile fp return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents @@ -209,6 +226,6 @@ getDocItem file languageId = do -- | Gets the Uri for the file corrected to the session directory. getDocUri :: FilePath -> Session Uri getDocUri file = do - context <- lift ask + context <- ask let fp = rootDir context file return $ filePathToUri fp \ No newline at end of file diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index b5f5b6b..53485f1 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -3,16 +3,20 @@ {-# LANGUAGE FlexibleInstances #-} module Language.Haskell.LSP.Test.Parsing where +import Control.Applicative +import Control.Monad.Trans.Class import Control.Monad.IO.Class import Control.Monad.Trans.Reader -import qualified Data.ByteString.Lazy.Char8 as B +import Control.Monad.Trans.State import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import Language.Haskell.LSP.Test.Messages import Language.Haskell.LSP.Test.Decoding import System.IO -import Control.Concurrent -import Text.Parsec hiding (satisfy) +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Data.Conduit hiding (await) +import Data.Conduit.Parser data MessageParserState = MessageParserState @@ -29,17 +33,33 @@ newtype SessionState = SessionState curReqId :: LspId } -type Session = ParsecT (Chan FromServerMessage) SessionState (ReaderT SessionContext IO) +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 +-- | Matches if the message is a notification. notification :: Session FromServerMessage notification = satisfy isServerNotification +-- | Matches if the message is a request. request :: Session FromServerMessage request = satisfy isServerRequest +-- | Matches if the message is a response. response :: Session FromServerMessage response = satisfy isServerResponse +-- | Matches if the message is a log message notification or a show message notification/request. loggingNotification :: Session FromServerMessage loggingNotification = satisfy shouldSkip where @@ -48,16 +68,31 @@ loggingNotification = satisfy shouldSkip shouldSkip (ReqShowMessage _) = True shouldSkip _ = False -satisfy :: (Stream s m a, Eq a, Show a) => (a -> Bool) -> ParsecT s u m a -satisfy pred = tokenPrim show nextPos test - where nextPos x _ _ = x - test x = if pred x then Just x else Nothing +satisfy :: Monad m => (a -> Bool) -> ConduitParser a m a +satisfy pred = do + x <- await + if pred x + then return x + else empty -testLog = NotLogMessage (NotificationMessage "2.0" WindowLogMessage (LogMessageParams MtLog "Hello world")) +chanSource:: MonadIO m => Chan o -> ConduitT i o m b +chanSource c = do + x <- liftIO $ readChan c + yield x + chanSource c -testSymbols = RspDocumentSymbols (ResponseMessage "2.0" (IdRspInt 0) (Just (List [])) Nothing) +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 -instance (MonadIO m) => Stream (Chan a) m a where - uncons c = do - x <- liftIO $ readChan c - return $ Just (x, c) +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 \ No newline at end of file diff --git a/src/Language/Haskell/LSP/Test/Replay.hs b/src/Language/Haskell/LSP/Test/Replay.hs index 8c9e1d0..72fb0d6 100644 --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@ -46,7 +46,6 @@ replaySession sessionDir = do serverMsgs = filter (not . shouldSkip) $ map (\(FromServer _ msg) -> msg) serverEvents requestMap = getRequestMap clientMsgs - reqSema <- newEmptyMVar rspSema <- newEmptyMVar passVar <- newEmptyMVar :: IO (MVar Bool) @@ -99,7 +98,7 @@ sendMessages (nextMsg:remainingMsgs) reqSema rspSema = if responseId reqId /= id then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId else do - sendResponse' msg + sendResponse msg liftIO $ putStrLn $ "Sent response to request id " ++ show id sendMessages remainingMsgs reqSema rspSema