From: Luke Lau Date: Mon, 11 Jun 2018 14:31:29 +0000 (-0400) Subject: Merge branch 'master' of https://github.com/Bubba/haskell-lsp-test X-Git-Url: http://git.lukelau.me/?a=commitdiff_plain;h=bc52b000bf018360efbfa0fcd289329c70d2c77e;hp=-c;p=opengl.git Merge branch 'master' of https://github.com/Bubba/haskell-lsp-test --- bc52b000bf018360efbfa0fcd289329c70d2c77e diff --combined example/Main.hs index 0c8ae9f,1697ca5..fc453db --- a/example/Main.hs +++ b/example/Main.hs @@@ -4,15 -4,15 +4,15 @@@ import Data.Prox import Control.Monad.IO.Class -main = runSession "test/recordings/renamePass" $ do +main = runSession "hie" "test/recordings/renamePass" $ do docItem <- getDocItem "Desktop/simple.hs" "haskell" docId <- TextDocumentIdentifier <$> getDocUri "Desktop/simple.hs" sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem) - sendRequest (Proxy :: Proxy DocumentSymbolRequest) TextDocumentDocumentSymbol (DocumentSymbolParams docId) + sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams docId) skipMany loggingNotification - response >>= liftIO . print + anyResponse >>= liftIO . print diff --combined src/Language/Haskell/LSP/Test.hs index 087143f,fb928a4..79b7b1e --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@@ -24,8 -24,11 +24,11 @@@ module Language.Haskell.LSP.Tes , sendNotification' , sendResponse -- * Receving + , anyRequest , request + , anyResponse , response + , anyNotification , notification , loggingNotification , publishDiagnosticsNotification @@@ -61,17 -64,15 +64,15 @@@ import Control.Applicative.Combinator import Control.Monad import Control.Monad.IO.Class import Control.Concurrent - import Control.Lens + import Control.Lens hiding ((.=)) import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B import Data.Default - import Data.Proxy import System.Process import Language.Haskell.LSP.Types - import qualified Language.Haskell.LSP.Types as LSP (error) - import Language.Haskell.LSP.Messages + import qualified Language.Haskell.LSP.Types as LSP (error, id) import Language.Haskell.LSP.Test.Compat import System.IO import System.Directory @@@ -80,11 -81,10 +81,11 @@@ import Language.Haskell.LSP.Test.Decodi import Language.Haskell.LSP.Test.Parsing -- | Starts a new session. -runSession :: FilePath -- ^ The filepath to the root directory for the session. +runSession :: FilePath -- ^ The filepath to the server executable. + -> FilePath -- ^ The filepath to the root directory for the session. -> Session a -- ^ The session to run. -> IO () -runSession rootDir session = do +runSession serverExe rootDir session = do pid <- getProcessID absRootDir <- canonicalizePath rootDir @@@ -95,11 -95,11 +96,11 @@@ def (Just TraceOff) - runSessionWithHandler listenServer rootDir $ do + runSessionWithHandler listenServer serverExe rootDir $ do -- Wrap the session around initialize and shutdown calls - sendRequest (Proxy :: Proxy InitializeRequest) Initialize initializeParams - RspInitialize initRsp <- response + sendRequest Initialize initializeParams + initRsp <- response :: Session InitializeResponse liftIO $ maybe (return ()) (putStrLn . ("Error while initializing: " ++) . show ) (initRsp ^. LSP.error) sendNotification Initialized InitializedParams @@@ -112,15 -112,14 +113,15 @@@ -- | 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 -> FilePath -> Session a -> IO a -runSessionWithHandler serverHandler rootDir session = do +runSessionWithHandler serverHandler serverExe rootDir session = do absRootDir <- canonicalizePath rootDir (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess - (proc "hie" ["--lsp", "-d", "-l", "/tmp/hie-test.log"]) + (proc serverExe ["--lsp", "-d", "-l", "/tmp/hie-test.log"]) { std_in = CreatePipe, std_out = CreatePipe } hSetBuffering serverIn NoBuffering @@@ -133,10 -132,11 +134,11 @@@ let context = SessionContext serverIn absRootDir messageChan reqMap initState = SessionState (IdInt 9) - forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut) + threadId <- forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut) (result, _) <- runSession' messageChan context initState session terminateProcess serverProc + killThread threadId return result @@@ -161,29 -161,45 +163,45 @@@ listenServer serverOut = d -- (DocumentSymbolParams docId) -- @ sendRequest - :: forall params resp. (ToJSON params, ToJSON resp, FromJSON resp) - => Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request. - -> ClientMethod -- ^ The request method. + :: (ToJSON params) + => --Proxy (RequestMessage ClientMethod params resp) -- ^ A proxy to provide more type information about the request. + ClientMethod -- ^ The request method. -> params -- ^ The request parameters. -> Session LspId -- ^ The id of the request that was sent. - sendRequest _ method params = do + sendRequest method params = do id <- curReqId <$> get modify $ \c -> c { curReqId = nextId id } - let req = RequestMessage "2.0" id method params :: RequestMessage ClientMethod params resp + let req = RequestMessage' "2.0" id method params - sendRequest' req + -- Update the request map + reqMap <- requestMap <$> ask + liftIO $ modifyMVar_ reqMap $ + \r -> return $ updateRequestMap r id method + + sendMessage req return id where nextId (IdInt i) = IdInt (i + 1) nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1 + -- | A custom type for request message that doesn't + -- need a response type, allows us to infer the request + -- message type without using proxies. + data RequestMessage' a = RequestMessage' T.Text LspId ClientMethod a + + instance ToJSON a => ToJSON (RequestMessage' a) where + toJSON (RequestMessage' rpc id method params) = + object ["jsonrpc" .= rpc, "id" .= id, "method" .= method, "params" .= params] + + sendRequest' :: (ToJSON a, ToJSON b) => RequestMessage ClientMethod a b -> Session () sendRequest' req = do -- Update the request map reqMap <- requestMap <$> ask - liftIO $ modifyMVar_ reqMap (return . flip updateRequestMap req) + liftIO $ modifyMVar_ reqMap $ + \r -> return $ updateRequestMap r (req ^. LSP.id) (req ^. method) sendMessage req diff --combined src/Language/Haskell/LSP/Test/Replay.hs index 4802c9a,2d5e4e6..dfa364b --- a/src/Language/Haskell/LSP/Test/Replay.hs +++ b/src/Language/Haskell/LSP/Test/Replay.hs @@@ -29,10 -29,9 +29,10 @@@ import Language.Haskell.LSP.T -- makes sure it matches up with an expected response. -- The session directory should have a captured session file in it -- named "session.log". -replaySession :: FilePath -- ^ The recorded session directory. +replaySession :: FilePath -- ^ The filepath to the server executable. + -> FilePath -- ^ The recorded session directory. -> IO Bool -replaySession sessionDir = do +replaySession serverExe sessionDir = do entries <- B.lines <$> B.readFile (sessionDir "session.log") @@@ -51,10 -50,14 +51,15 @@@ rspSema <- newEmptyMVar passVar <- newEmptyMVar :: IO (MVar Bool) - forkIO $ runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar) serverExe sessionDir $ - sendMessages clientMsgs reqSema rspSema + threadId <- forkIO $ + runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar) ++ serverExe + sessionDir + (sendMessages clientMsgs reqSema rspSema) - takeMVar passVar + result <- takeMVar passVar + killThread threadId + return result where isClientMsg (FromClient _ _) = True diff --combined test/Test.hs index c7e6713,ca135c7..426dd6b --- a/test/Test.hs +++ b/test/Test.hs @@@ -2,32 -2,28 +2,28 @@@ {-# LANGUAGE OverloadedStrings #-} import Test.Hspec import Data.Maybe - import Data.Proxy import Control.Monad.IO.Class import Control.Lens hiding (List) 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" $ do + describe "manual session" $ do it "passes a test" $ - runSession "test/recordings/renamePass" $ do + runSession "hie" "test/recordings/renamePass" $ do doc <- openDoc "Desktop/simple.hs" "haskell" skipMany loggingNotification - NotPublishDiagnostics diagsNot <- notification + diagsNot <- notification :: Session PublishDiagnosticsNotification liftIO $ diagsNot ^. params . diagnostics `shouldBe` List [] - sendRequest (Proxy :: Proxy DocumentSymbolRequest) - TextDocumentDocumentSymbol - (DocumentSymbolParams doc) + sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc) - RspDocumentSymbols rspSymbols <- response + rspSymbols <- response :: Session DocumentSymbolsResponse liftIO $ do let (List symbols) = fromJust (rspSymbols ^. result) @@@ -39,16 -35,16 +35,16 @@@ it "fails a test" $ -- TODO: Catch the exception in haskell-lsp-test and provide nicer output - let session = runSession "test/recordings/renamePass" $ do + let session = runSession "hie" "test/recordings/renamePass" $ do openDoc "Desktop/simple.hs" "haskell" skipMany loggingNotification - request + anyRequest in session `shouldThrow` anyException describe "replay session" $ do it "passes a test" $ - replaySession "test/recordings/renamePass" `shouldReturn` True + replaySession "hie" "test/recordings/renamePass" `shouldReturn` True it "fails a test" $ - replaySession "test/recordings/renameFail" `shouldReturn` False + replaySession "hie" "test/recordings/renameFail" `shouldReturn` False parsingSpec