Fix embarassing error with publishDiagnosticsNotification

Generalize message combinators

diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal
index 22b43aa4b3e2bb761eeb28b02a712e7685533360..cc2eb6f37a3f99b31dc8bb3cb874d907d8225f64 100644 (file)
--- a/haskell-lsp-test.cabal
+++ b/haskell-lsp-test.cabal
@@ -23,14 +23,14 @@ library
                      , haskell-lsp
                      , aeson
                      , bytestring
-                     , conduit-parse
                      , conduit
+                     , conduit-parse
                      , containers
                      , data-default
                      , directory
                      , filepath
                      , lens
-                     , parsers
+                     , parser-combinators
                      , process
                      , text
                      , transformers
@@ -57,6 +57,9 @@ test-suite tests
                      , directory
                      , haskell-lsp-test
                      , haskell-lsp
+                     , conduit
+                     , conduit-parse
+  other-modules:       ParsingTests
   default-language:    Haskell2010
 
 executable example

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index c16ae84f2a6a9864033246767f984ec2ae40fb37..2e0926a58539581e2053cc14d4fff750e8424f3f 100644 (file)
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -33,31 +33,21 @@ module Language.Haskell.LSP.Test
   , 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
+  , skipManyTill
+  , skipSomeTill
   , (<|>)
   , satisfy
   -- * Utilities
@@ -67,6 +57,7 @@ module Language.Haskell.LSP.Test
   ) where
 
 import Control.Applicative
+import Control.Applicative.Combinators
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Concurrent
@@ -87,7 +78,6 @@ import System.Directory
 import System.FilePath
 import Language.Haskell.LSP.Test.Decoding
 import Language.Haskell.LSP.Test.Parsing
-import Text.Parser.Combinators
 
 -- | Starts a new session.
 runSession :: FilePath -- ^ The filepath to the root directory for the session.

diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs
index 81e5cbed3d64b5ece0f330ea686c7f2b92cce110..fdd01c2a047b7d620ee606334ae96c9805a01ee3 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Parsing.hs
+++ b/src/Language/Haskell/LSP/Test/Parsing.hs
@@ -31,6 +31,7 @@ newtype SessionState = SessionState
   }
 
 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',
@@ -45,19 +46,19 @@ type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
 
 -- | Matches if the message is a notification.
-notification :: Session FromServerMessage
+notification :: Monad m => ConduitParser FromServerMessage m FromServerMessage
 notification = satisfy isServerNotification
 
 -- | Matches if the message is a request.
-request :: Session FromServerMessage
+request :: Monad m => ConduitParser FromServerMessage m FromServerMessage
 request = satisfy isServerRequest
 
 -- | Matches if the message is a response.
-response :: Session FromServerMessage
+response :: Monad m => ConduitParser FromServerMessage m FromServerMessage
 response = satisfy isServerResponse
 
 -- | Matches if the message is a log message notification or a show message notification/request.
-loggingNotification :: Session FromServerMessage
+loggingNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage
 loggingNotification = satisfy shouldSkip
   where
     shouldSkip (NotLogMessage _) = True
@@ -65,11 +66,11 @@ loggingNotification = satisfy shouldSkip
     shouldSkip (ReqShowMessage _) = True
     shouldSkip _ = False
 
-publishDiagnosticsNotification :: Session PublishDiagnosticsNotification
+publishDiagnosticsNotification :: Monad m => ConduitParser FromServerMessage m PublishDiagnosticsNotification
 publishDiagnosticsNotification = do
-  (NotPublishDiagnostics diags) <- satisfy test
+  NotPublishDiagnostics diags <- satisfy test
   return diags
-  where test (NotPublishDiagnostics _) = False
+  where test (NotPublishDiagnostics _) = True
         test _ = False
 
 satisfy :: Monad m => (a -> Bool) -> ConduitParser a m a

diff --git a/test/ParsingTests.hs b/test/ParsingTests.hs
new file mode 100644 (file)
index 0000000..7824ef3
--- /dev/null
+++ b/test/ParsingTests.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings #-}
+module ParsingTests where
+
+import Control.Lens hiding (List)
+import Language.Haskell.LSP.Messages
+import Language.Haskell.LSP.Test
+import Language.Haskell.LSP.Types
+import Data.Conduit
+import Data.Conduit.Parser
+import Test.Hspec
+
+parsingSpec :: Spec
+parsingSpec =
+  describe "diagnostics" $ do
+    let testDiag = NotPublishDiagnostics
+                   (NotificationMessage "2.0"
+                                       TextDocumentPublishDiagnostics
+                                       (PublishDiagnosticsParams (Uri "foo")
+                                                                 (List [])))
+    it "get picked up" $ do
+      let 
+          source = yield testDiag
+          session = do
+            diags <- publishDiagnosticsNotification
+            return $ diags ^. params . uri
+      runConduit (source .| runConduitParser session) `shouldReturn` Uri "foo"
+    it "get picked up after skipping others before" $ do
+      let testDiag = NotPublishDiagnostics
+                    (NotificationMessage "2.0"
+                                          TextDocumentPublishDiagnostics
+                                          (PublishDiagnosticsParams (Uri "foo")
+                                                                    (List [])))
+          notTestDiag = NotLogMessage (NotificationMessage "2.0" WindowLogMessage (LogMessageParams MtLog "foo"))
+          source = yield notTestDiag >> yield testDiag
+          session = do
+            diags <- skipManyTill notification publishDiagnosticsNotification
+            return $ diags ^. params . uri
+      runConduit (source .| runConduitParser session) `shouldReturn` Uri "foo"
\ No newline at end of file

diff --git a/test/Test.hs b/test/Test.hs
index 1fd58da97d33508f47683c03194ef191076e5553..652485e0af160279340ea8d6730dc37d33b075e9 100644 (file)
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -9,9 +9,10 @@ import           Language.Haskell.LSP.Test
 import           Language.Haskell.LSP.Test.Replay
 import           Language.Haskell.LSP.Types
 import           Language.Haskell.LSP.Messages
+import           ParsingTests
 
 main = hspec $ do
-  describe "manual session validation" $ 
+  describe "manual session validation" $ do
     it "passes a test" $
       runSession "test/recordings/renamePass" $ do
         doc <- openDoc "Desktop/simple.hs" "haskell"
@@ -36,8 +37,18 @@ main = hspec $ do
           mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4)
           mainSymbol ^. containerName `shouldBe` Nothing
     
+    it "fails a test" $
+      -- TODO: Catch the exception in haskell-lsp-test and provide nicer output
+      let session = runSession "test/recordings/renamePass" $ do
+                    openDoc "Desktop/simple.hs" "haskell"
+                    skipMany loggingNotification
+                    request
+        in session `shouldThrow` anyException
+  
   describe "replay session" $ do
     it "passes a test" $
       replaySession "test/recordings/renamePass" `shouldReturn` True
     it "fails a test" $
       replaySession "test/recordings/renameFail" `shouldReturn` False
+  
+  parsingSpec
\ No newline at end of file