Switch to conduit based parser

diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal
index 7dcbc716ea6338680fb39e1f79c63af24f8c16e7..22b43aa4b3e2bb761eeb28b02a712e7685533360 100644 (file)
--- 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 495714c02e6bd3c28d09b0fd97eff1a7b7e766a3..4de02fe1324b184835fe09b3d8ba5e8c63997d67 100644 (file)
--- 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 b5f5b6b4a740a3d17642cd185293f3877ad469a3..53485f19c832ed0cdaab269fbc758aec16cbb1c8 100644 (file)
--- 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 8c9e1d07593b5c833780afbcf1b3a65af796a86b..72fb0d6e2541706dee6ec2c7d3a214961918c8c9 100644 (file)
--- 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