Try out Chan Stream instance

[opengl.git] / src / Language / Haskell / LSP / Test / Parsing.hs

diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs
index c29e0f3a2a44b69d875b823cea21d42a183c9fd5..9d2dd702c78d2065b53835e12cc11a4f3dd4b9be 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Parsing.hs
+++ b/src/Language/Haskell/LSP/Test/Parsing.hs
@@ -1,39 +1,51 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
 module Language.Haskell.LSP.Test.Parsing where
 
-import qualified Data.ByteString.Lazy.Char8    as B
-import System.IO
-
-getAllMessages :: Handle -> IO [B.ByteString]
-getAllMessages h = do
-  done <- hIsEOF h
-  if done
-    then return []
-    else do
-      msg <- getNextMessage h
-
-      (msg :) <$> getAllMessages h
-
--- | Fetches the next message bytes based on
--- the Content-Length header
-getNextMessage :: Handle -> IO B.ByteString
-getNextMessage h = do
-  headers <- getHeaders h
-  case read . init <$> lookup "Content-Length" headers of
-    Nothing   -> error "Couldn't read Content-Length header"
-    Just size -> B.hGet h size
-    
-addHeader :: B.ByteString -> B.ByteString
-addHeader content = B.concat
-  [ "Content-Length: "
-  , B.pack $ show $ B.length content
-  , "\r\n"
-  , "\r\n"
-  , content
-  ]
-
-getHeaders :: Handle -> IO [(String, String)]
-getHeaders h = do
-  l <- hGetLine h
-  let (name, val) = span (/= ':') l
-  if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h
+import Language.Haskell.LSP.Messages
+import Language.Haskell.LSP.Types
+import Language.Haskell.LSP.Test.Messages
+import Control.Concurrent
+import Text.Parsec hiding (satisfy)
+import Control.Monad
+
+data MessageParserState = MessageParserState
+
+type MessageParser = ParsecT (Chan FromServerMessage) MessageParserState IO
+
+notification :: MessageParser FromServerMessage
+notification = satisfy isServerNotification
+
+request :: MessageParser FromServerMessage
+request = satisfy isServerRequest
+
+response :: MessageParser FromServerMessage
+response = satisfy isServerResponse
+
+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
+
+testLog = NotLogMessage (NotificationMessage "2.0" WindowLogMessage (LogMessageParams MtLog "Hello world"))
+
+testSymbols = RspDocumentSymbols (ResponseMessage "2.0" (IdRspInt 0) (Just (List [])) Nothing)
+
+instance Stream (Chan a) IO a where
+  uncons c = do
+    x <- readChan c
+    return $ Just (x, c)
+
+test :: IO ()
+test = do
+  chan <- newChan
+  let parser = do
+        n <- count 2 notification
+        rsp <- response
+        return (n, rsp)
+  forkIO $ forM_ [testLog, testLog, testSymbols] $ \x -> do
+    writeChan chan x
+    threadDelay 1000000
+  x <- runParserT parser MessageParserState "" chan
+  print x
\ No newline at end of file