From df782ad008b840c0860173821226542e2e70f2e9 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 5 Jun 2018 19:21:59 -0400 Subject: [PATCH] Add manual session testing --- example/Main.hs | 27 +-- haskell-lsp-test.cabal | 2 - src/Capabilities.hs | 43 ---- src/Language/Haskell/LSP/Test.hs | 238 +++++++++++++--------- src/Language/Haskell/LSP/Test/Recorded.hs | 108 +++++----- test/Test.hs | 44 ++-- 6 files changed, 238 insertions(+), 224 deletions(-) delete mode 100644 src/Capabilities.hs diff --git a/example/Main.hs b/example/Main.hs index 4dd268c..5aaa2d1 100644 --- a/example/Main.hs +++ b/example/Main.hs @@ -1,16 +1,17 @@ import Language.Haskell.LSP.Test -import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP -import qualified Data.Text.IO as T -import Control.Lens -import Control.Monad +import Language.Haskell.LSP.TH.DataTypesJSON +import Data.Proxy + import Control.Monad.IO.Class -import System.Directory -import System.Environment -main = do - files <- getArgs - forM_ files $ \fp -> manualSession $ do - file <- liftIO $ canonicalizePath fp - openDocument file - symbols <- documentSymbols file - liftIO $ mapM_ T.putStrLn (symbols ^.. traverse . LSP.name) +main = runSession "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) + + syms <- getMessage :: Session DocumentSymbolsResponse + liftIO $ print syms \ No newline at end of file diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index a61a18d..2cd5ce3 100644 --- a/haskell-lsp-test.cabal +++ b/haskell-lsp-test.cabal @@ -19,7 +19,6 @@ library , Language.Haskell.LSP.Test.Recorded default-language: Haskell2010 build-depends: base >= 4.7 && < 5 - , haskell-lsp-client , haskell-lsp-types , haskell-lsp , data-default @@ -38,7 +37,6 @@ library else build-depends: unix other-modules: Compat - Capabilities Language.Haskell.LSP.Test.Files Language.Haskell.LSP.Test.Parsing ghc-options: -W diff --git a/src/Capabilities.hs b/src/Capabilities.hs deleted file mode 100644 index f1cc6ee..0000000 --- a/src/Capabilities.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Capabilities where - -import Language.Haskell.LSP.TH.ClientCapabilities - -capabilities :: ClientCapabilities -capabilities = ClientCapabilities (Just workspaceCapabilities) - (Just textDocumentCapabilities) - Nothing - where - workspaceCapabilities = WorkspaceClientCapabilities - (Just False) - (Just (WorkspaceEditClientCapabilities (Just False))) - (Just (DidChangeConfigurationClientCapabilities (Just False))) - (Just (DidChangeWatchedFilesClientCapabilities (Just False))) - (Just (SymbolClientCapabilities (Just False))) - (Just (ExecuteClientCapabilities (Just False))) - textDocumentCapabilities = TextDocumentClientCapabilities - (Just - (SynchronizationTextDocumentClientCapabilities (Just False) - (Just False) - (Just False) - (Just False) - ) - ) - (Just - (CompletionClientCapabilities - (Just False) - (Just (CompletionItemClientCapabilities (Just False))) - ) - ) - (Just (HoverClientCapabilities (Just False))) - (Just (SignatureHelpClientCapabilities (Just False))) - (Just (ReferencesClientCapabilities (Just False))) - (Just (DocumentHighlightClientCapabilities (Just False))) - (Just (DocumentSymbolClientCapabilities (Just False))) - (Just (FormattingClientCapabilities (Just False))) - (Just (RangeFormattingClientCapabilities (Just False))) - (Just (OnTypeFormattingClientCapabilities (Just False))) - (Just (DefinitionClientCapabilities (Just False))) - (Just (CodeActionClientCapabilities (Just False))) - (Just (CodeLensClientCapabilities (Just False))) - (Just (DocumentLinkClientCapabilities (Just False))) - (Just (RenameClientCapabilities (Just False))) diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index 5883271..f8f8394 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -1,122 +1,170 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ExistentialQuantification #-} + module Language.Haskell.LSP.Test ( -- * Sessions - manualSession - -- * Documents - , openDocument - , documentSymbols + runSession + , Session + -- * Sending + , sendRequest + , sendNotification + -- * Receving + , getMessage + -- * Utilities + , getDocItem + , getDocUri ) where -import Control.Lens +import Control.Monad.Trans.Class import Control.Monad.IO.Class import Control.Monad.Trans.Reader +import Control.Monad.Trans.State +import Control.Concurrent 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.Maybe import Data.Proxy import System.Process -import qualified Language.Haskell.LSP.Client as Client -import Language.Haskell.LSP.Messages -import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP -import Language.Haskell.LSP.Test.Recorded -import Capabilities +import Language.Haskell.LSP.Types hiding (error, id) import Compat - -type Session = ReaderT Client.Client IO - -manualSession :: Session a -> IO () -manualSession f = do - (Just hin, Just hout, _, serverProc) <- createProcess (proc "hie" ["--lsp", "-l", "/tmp/hie.log"]) +import System.IO +import System.Directory +import System.FilePath +import Language.Haskell.LSP.Test.Parsing + +data SessionContext = SessionContext + { + messageSema :: MVar B.ByteString, + serverIn :: Handle, + serverOut :: Handle, + rootDir :: FilePath + } + +newtype SessionState = SessionState + { + curReqId :: LspId + } +type Session = StateT SessionState (ReaderT SessionContext IO) + +runSession :: FilePath -> Session a -> IO () +runSession rootDir session = do + + absRootDir <- canonicalizePath rootDir + + (Just serverIn, Just serverOut, Nothing, serverProc) <- createProcess + (proc "hie" ["--lsp", "-d", "-l", "/tmp/hie-test.log"]) { std_in = CreatePipe, std_out = CreatePipe } - client <- Client.start $ Client.Config hin hout notificationHandler requestHandler + + hSetBuffering serverIn NoBuffering + hSetBuffering serverOut NoBuffering pid <- getProcessID + messageSema <- newEmptyMVar - let initializeParams :: LSP.InitializeParams - initializeParams = LSP.InitializeParams (Just pid) - Nothing - Nothing - Nothing - capabilities + let initializeParams :: InitializeParams + initializeParams = InitializeParams (Just pid) + (Just $ T.pack absRootDir) + (Just $ filePathToUri absRootDir) Nothing + def + (Just TraceOff) + context = SessionContext messageSema serverIn serverOut absRootDir + initState = SessionState (IdInt 9) - Client.sendClientRequest client - (Proxy :: Proxy LSP.InitializeRequest) - LSP.Initialize initializeParams - Client.sendClientNotification client - LSP.Initialized - (Just LSP.InitializedParams) + -- | The session wrapped around initialize and shutdown calls + fullSession = do + sendRequest (Proxy :: Proxy InitializeRequest) Initialize initializeParams + (ResponseMessage _ _ (Just (InitializeResponseCapabilities _)) e) <- getMessage + liftIO $ maybe (return ()) (putStrLn . ("Error when initializing: " ++) . show ) e - putStrLn "Session started" + sendNotification Initialized InitializedParams - runReaderT f client + -- Run the actual thing + session - Client.sendClientRequest client - (Proxy :: Proxy LSP.ShutdownRequest) - LSP.Shutdown Nothing - Client.sendClientNotification client - LSP.Exit - (Just LSP.ExitParams) + sendNotification Exit ExitParams - Client.stop client + forkIO $ listenServer context + _ <- runReaderT (runStateT fullSession initState) context - -- todo: this interrupts the test server process as well? - -- interruptProcessGroupOf serverProc - -- waitForProcess serverProc terminateProcess serverProc - putStrLn "Session ended" - -openDocument :: FilePath -> Session () -openDocument path = do - text <- liftIO $ T.readFile path - - let uri = LSP.filePathToUri path - - client <- ask - liftIO $ Client.sendClientNotification client LSP.TextDocumentDidOpen (Just (LSP.DidOpenTextDocumentParams (LSP.TextDocumentItem uri "haskell" 1 text))) - -documentSymbols :: FilePath -> Session (LSP.List LSP.SymbolInformation) -documentSymbols path = do - let uri = LSP.filePathToUri path - - client <- ask - - liftIO $ do - res <- Client.sendClientRequest client - (Proxy :: Proxy LSP.DocumentSymbolRequest) - LSP.TextDocumentDocumentSymbol (LSP.DocumentSymbolParams (LSP.TextDocumentIdentifier uri)) - return $ case res of - Just (Right syms) -> syms - _ -> error "Failed to get document symbols" - -notificationHandler :: Client.NotificationMessageHandler -notificationHandler = Client.NotificationMessageHandler - (\(LSP.NotificationMessage _ _ (LSP.ShowMessageParams _ msg)) -> print msg) - (\(LSP.NotificationMessage _ _ (LSP.LogMessageParams _ msg)) -> print msg) - (\(LSP.NotificationMessage _ _ json) -> putStrLn $ "Telemetry: " ++ show json) - (\(LSP.NotificationMessage _ _ (LSP.PublishDiagnosticsParams uri diags)) -> - putStrLn $ "Diagnostics at " ++ showUri uri ++ ": " ++ showDiags diags) - - where showDiags :: LSP.List LSP.Diagnostic -> String - showDiags (LSP.List diags) = unlines $ map (T.unpack . (^. LSP.message)) diags - showUri :: LSP.Uri -> String - showUri = fromMaybe "unknown path" . LSP.uriToFilePath - - - -requestHandler :: Client.RequestMessageHandler -requestHandler = Client.RequestMessageHandler - (\m -> emptyRsp m <$ print m) - (\m -> emptyRsp m <$ print m) - (\m -> emptyRsp m <$ print m) - (\m -> emptyRsp m <$ print m) - where emptyRsp :: LSP.RequestMessage m req rsp -> LSP.ResponseMessage a - emptyRsp m = LSP.ResponseMessage (m ^. LSP.jsonrpc) - (lspIdToRspId $ m ^. LSP.id) - Nothing - Nothing - - lspIdToRspId (LSP.IdInt i) = LSP.IdRspInt i - lspIdToRspId (LSP.IdString i) = LSP.IdRspString i + return () + +-- | Listens to the server output, makes sure it matches the record and +-- signals any semaphores +listenServer :: SessionContext -> IO () +listenServer context = do + msgBytes <- getNextMessage (serverOut context) + + case decode msgBytes :: Maybe LogMessageNotification of + -- Just print log and show messages + Just (NotificationMessage _ WindowLogMessage (LogMessageParams _ msg)) -> T.putStrLn msg + _ -> case decode msgBytes :: Maybe ShowMessageNotification of + Just (NotificationMessage _ WindowShowMessage (ShowMessageParams _ msg)) -> T.putStrLn msg + -- Give everything else for getMessage to handle + _ -> putMVar (messageSema context) msgBytes + + listenServer context + +-- | Sends a request to the server. +sendRequest + :: forall params resp. (ToJSON params, ToJSON resp, FromJSON resp) + => Proxy (RequestMessage ClientMethod params resp) + -> ClientMethod + -> params + -> Session LspId +sendRequest _ method params = do + h <- serverIn <$> lift ask + + id <- curReqId <$> get + get >>= \c -> put c { curReqId = nextId id } + + let msg = RequestMessage "2.0" id method params :: RequestMessage ClientMethod params resp + + liftIO $ B.hPut h $ addHeader (encode msg) + + return id + + where nextId (IdInt i) = IdInt (i + 1) + nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1 + +-- | Sends a notification to the server. +sendNotification :: ToJSON a => ClientMethod -> a -> Session () +sendNotification method params = do + h <- serverIn <$> lift ask + + let msg = NotificationMessage "2.0" method params + liftIO $ B.hPut h $ addHeader (encode msg) + +-- | Reads in a message from the server. +getMessage :: FromJSON a => Session a +getMessage = do + sema <- messageSema <$> lift ask + bytes <- liftIO $ takeMVar sema + return $ fromMaybe (error $ "Wrong type! Got: " ++ show bytes) (decode bytes) + +-- | Reads in a text document as the first version. +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 + let fp = rootDir context file + contents <- liftIO $ T.readFile fp + return $ TextDocumentItem (filePathToUri fp) (T.pack languageId) 0 contents + +-- | Gets the Uri for the file corrected to the session directory. +getDocUri :: FilePath -> Session Uri +getDocUri file = do + context <- lift ask + let fp = rootDir context file + return $ filePathToUri fp \ No newline at end of file diff --git a/src/Language/Haskell/LSP/Test/Recorded.hs b/src/Language/Haskell/LSP/Test/Recorded.hs index 9c89a78..2fae088 100644 --- a/src/Language/Haskell/LSP/Test/Recorded.hs +++ b/src/Language/Haskell/LSP/Test/Recorded.hs @@ -31,8 +31,8 @@ import Language.Haskell.LSP.Test.Parsing data SessionContext = SessionContext { - reqSema :: MVar LSP.LspId, - rspSema :: MVar LSP.LspIdRsp, + reqSema :: MVar FromServerMessage, + rspSema :: MVar LSP.LspId, serverIn :: Handle } type Session = StateT [FromClientMessage] (ReaderT SessionContext IO) @@ -46,11 +46,8 @@ replay sessionDir session = do let sessionFp = sessionDir "session.log" - -- need to keep hold of current directory since haskell-lsp changes it - prevRootDir <- getCurrentDirectory - (Just serverIn, Just serverOut, _, serverProc) <- createProcess - (proc "hie" ["--lsp", "-l", "/tmp/hie.log"]) { std_in = CreatePipe + (proc "hie" ["--lsp", "-d", "-l", "/tmp/test-hie.log"]) { std_in = CreatePipe , std_out = CreatePipe } @@ -58,10 +55,9 @@ replay sessionDir session = do hSetBuffering serverOut NoBuffering -- whether to send the next request - reqSema <- newEmptyMVar :: IO (MVar LSP.LspIdRsp) + reqSema <- newEmptyMVar -- whether to send the next response - rspSema <- newEmptyMVar :: IO (MVar LSP.LspId) - let semas = (reqSema, rspSema) + rspSema <- newEmptyMVar entries <- B.lines <$> B.readFile sessionFp @@ -72,17 +68,15 @@ replay sessionDir session = do let clientEvents = map (\(FromClient _ msg) -> msg) $ filter isClientMsg events requestMap = getRequestMap clientEvents + context = (SessionContext rspSema reqSema serverIn) -- listen to server - forkIO $ listenServer serverOut requestMap semas + forkIO $ listenServer serverOut requestMap context - runReaderT (runStateT session clientEvents) (SessionContext rspSema reqSema serverIn) + runReaderT (runStateT session clientEvents) context terminateProcess serverProc - -- restore directory - setCurrentDirectory prevRootDir - where isClientMsg (FromClient _ _) = True isClientMsg _ = False @@ -90,7 +84,7 @@ replay sessionDir session = do isServerMsg (FromServer _ _) = True isServerMsg _ = False -sendNextRequest :: Session () +sendNextRequest :: Session FromServerMessage sendNextRequest = do (nextMsg:remainingMsgs) <- get put remainingMsgs @@ -141,6 +135,8 @@ sendNextRequest = do threadDelay 10000000 B.hPut (serverIn context) $ addHeader (encode msg) + error "Done" + notification msg@(LSP.NotificationMessage _ m _) = do context <- lift ask @@ -154,21 +150,24 @@ sendNextRequest = do context <- lift ask liftIO $ do - when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000 + + print $ addHeader $ encode msg B.hPut (serverIn context) $ addHeader (encode msg) putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response" - rspId <- takeMVar (rspSema context) - when (LSP.responseId id /= rspId) $ - error $ "Expected id " ++ show id ++ ", got " ++ show rspId + rsp <- takeMVar (reqSema context) + -- when (LSP.responseId id /= rsp ^. LSP.id) $ + -- error $ "Expected id " ++ show id ++ ", got " ++ show (rsp ^. LSP.id) + + return rsp response msg@(LSP.ResponseMessage _ id _ _) = do context <- lift ask liftIO $ do putStrLn $ "Waiting for request id " ++ show id ++ " from the server" - reqId <- takeMVar (reqSema context) + reqId <- takeMVar (rspSema context) if LSP.responseId reqId /= id then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId else do @@ -180,8 +179,9 @@ sendNextRequest = do -- | Listens to the server output, makes sure it matches the record and -- signals any semaphores -listenServer :: Handle -> RequestMap -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> IO () -listenServer h reqMap semas@(reqSema, rspSema) = do +listenServer :: Handle -> RequestMap -> SessionContext -> IO () +listenServer h reqMap context = do + msgBytes <- getNextMessage h let msg = decodeFromServerMsg reqMap msgBytes @@ -193,45 +193,43 @@ listenServer h reqMap semas@(reqSema, rspSema) = do ReqApplyWorkspaceEdit m -> request m ReqShowMessage m -> request m ReqUnregisterCapability m -> request m - RspInitialize m -> response m - RspShutdown m -> response m - RspHover m -> response m - RspCompletion m -> response m - RspCompletionItemResolve m -> response m - RspSignatureHelp m -> response m - RspDefinition m -> response m - RspFindReferences m -> response m - RspDocumentHighlights m -> response m - RspDocumentSymbols m -> response m - RspWorkspaceSymbols m -> response m - RspCodeAction m -> response m - RspCodeLens m -> response m - RspCodeLensResolve m -> response m - RspDocumentFormatting m -> response m - RspDocumentRangeFormatting m -> response m - RspDocumentOnTypeFormatting m -> response m - RspRename m -> response m - RspExecuteCommand m -> response m - RspError m -> response m - RspDocumentLink m -> response m - RspDocumentLinkResolve m -> response m - RspWillSaveWaitUntil m -> response m + RspInitialize m -> response m msg + RspShutdown m -> response m msg + RspHover m -> response m msg + RspCompletion m -> response m msg + RspCompletionItemResolve m -> response m msg + RspSignatureHelp m -> response m msg + RspDefinition m -> response m msg + RspFindReferences m -> response m msg + RspDocumentHighlights m -> response m msg + RspDocumentSymbols m -> response m msg + RspWorkspaceSymbols m -> response m msg + RspCodeAction m -> response m msg + RspCodeLens m -> response m msg + RspCodeLensResolve m -> response m msg + RspDocumentFormatting m -> response m msg + RspDocumentRangeFormatting m -> response m msg + RspDocumentOnTypeFormatting m -> response m msg + RspRename m -> response m msg + RspExecuteCommand m -> response m msg + RspError m -> response m msg + RspDocumentLink m -> response m msg + RspDocumentLinkResolve m -> response m msg + RspWillSaveWaitUntil m -> response m msg NotPublishDiagnostics m -> notification m NotLogMessage m -> notification m NotShowMessage m -> notification m NotTelemetry m -> notification m NotCancelRequestFromServer m -> notification m - listenServer h reqMap semas + listenServer h reqMap context where - response :: Show a => LSP.ResponseMessage a -> IO () - response res = do + response :: Show a => LSP.ResponseMessage a -> FromServerMessage -> IO () + response res wrappedMsg = do putStrLn $ "Got response for id " ++ show (res ^. LSP.id) - print res - - putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request + putMVar (reqSema context) wrappedMsg -- send back the response for the request we're waiting on request :: Show a => LSP.RequestMessage LSP.ServerMethod a b -> IO () request req = do @@ -241,14 +239,10 @@ listenServer h reqMap semas@(reqSema, rspSema) = do ++ " " ++ show (req ^. LSP.method) - print req - - putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response + putMVar (rspSema context) (req ^. LSP.id) -- unblock the handler waiting for a response notification :: Show a => LSP.NotificationMessage LSP.ServerMethod a -> IO () - notification n = do - putStrLn $ "Got notification " ++ show (n ^. LSP.method) - print n + notification n = putStrLn $ "Got notification " ++ show (n ^. LSP.method) -- lift -- $ putStrLn diff --git a/test/Test.hs b/test/Test.hs index 7c7f272..604ea1c 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -1,18 +1,34 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} import Test.Hspec -import System.IO -import System.Directory -import Control.Lens +import Data.Proxy import Control.Monad.IO.Class -import Language.Haskell.LSP.Test.Recorded --- import Language.Haskell.LSP.Test.Parsing --- import Language.Haskell.LSP.Test.Files -import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP +import Control.Lens hiding (List) +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.TH.DataTypesJSON main = hspec $ - describe "replay" $ - it "passes a replay" $ - replaySession "test/recordings/renamePass" $ do - x <- sendNextRequest - liftIO $ print x - y <- sendNextRequest - liftIO $ print y \ No newline at end of file + describe "manual session validation" $ + it "passes a test" $ + runSession "test/recordings/renamePass" $ do + docItem <- getDocItem "Desktop/simple.hs" "haskell" + docId <- TextDocumentIdentifier <$> getDocUri "Desktop/simple.hs" + + sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem) + + (NotificationMessage _ TextDocumentPublishDiagnostics (PublishDiagnosticsParams _ (List diags))) <- + getMessage :: Session PublishDiagnosticsNotification + + liftIO $ diags `shouldBe` [] + + sendRequest (Proxy :: Proxy DocumentSymbolRequest) + TextDocumentDocumentSymbol + (DocumentSymbolParams docId) + + (ResponseMessage _ _ (Just (List symbols)) Nothing) <- getMessage :: Session DocumentSymbolsResponse + liftIO $ do + let mainSymbol = head symbols + mainSymbol ^. name `shouldBe` "main" + mainSymbol ^. kind `shouldBe` SkFunction + mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4) + mainSymbol ^. containerName `shouldBe` Nothing -- 2.30.2