From: Luke Lau Date: Sun, 27 May 2018 20:44:17 +0000 (-0400) Subject: Swap out the rootUri and rootPath params in initialize request X-Git-Tag: 0.1.0.0~102 X-Git-Url: http://git.lukelau.me/?p=lsp-test.git;a=commitdiff_plain;h=37aa4a22ec691b45bbd1cd0dd23d70e90a0c4e40 Swap out the rootUri and rootPath params in initialize request --- diff --git a/.travis.yml b/.travis.yml index 03adf0b..9591db7 100644 --- a/.travis.yml +++ b/.travis.yml @@ -16,7 +16,9 @@ before_install: install: - git clone https://github.com/haskell/haskell-ide-engine.git --recursive - cd haskell-ide-engine + - git checkout fd793acac1a40ee121676508612234eaa1f58ac8 - stack install + - stack exec hoogle generate - cd .. script: diff --git a/src/Language/Haskell/LSP/Test/Files.hs b/src/Language/Haskell/LSP/Test/Files.hs index 6557b88..642005c 100644 --- a/src/Language/Haskell/LSP/Test/Files.hs +++ b/src/Language/Haskell/LSP/Test/Files.hs @@ -6,6 +6,7 @@ module Language.Haskell.LSP.Test.Files , FileMap , emptyFileMap , rootDir + , cleanupFiles ) where @@ -53,6 +54,9 @@ buildFileMap uris recBaseDir curBaseDir oldMap = tmpUri <- filePathToUri <$> canonicalizePath tmpFp return $ Map.insert uri tmpUri map +cleanupFiles :: IO () +cleanupFiles = removeDirectoryRecursive =<< ( "lsp-test") <$> getTemporaryDirectory + swapFiles :: FileMap -> FilePath -> FilePath -> [B.ByteString] -> IO ([B.ByteString], FileMap) swapFiles fileMap recBaseDir curBaseDir msgs = do @@ -62,7 +66,18 @@ swapFiles fileMap recBaseDir curBaseDir msgs = do let newMsgs = map (swapUris newMap) msgs - return (newMsgs, newMap) + case decode (head newMsgs) :: Maybe InitializeRequest of + -- If there is an initialize request we will need to swap + -- the rootUri and rootPath + Just req -> do + cd <- getCurrentDirectory + let newRoot = cd curBaseDir + newRootUri = params . rootUri .~ Just (filePathToUri newRoot) $ req + newRootPath = params . rootPath .~ Just (T.pack newRoot) $ newRootUri + newReq = encode newRootPath + return (newReq:(tail newMsgs), newMap) + + Nothing -> return (newMsgs, newMap) rootDir :: [B.ByteString] -> FilePath rootDir msgs = case decode (head msgs) :: Maybe InitializeRequest of @@ -75,7 +90,7 @@ extractUris :: B.ByteString -> Set.Set Uri extractUris msgs = case decode msgs :: Maybe Object of Just obj -> HashMap.foldlWithKey' gather Set.empty obj - Nothing -> error "nooo" + Nothing -> error "Couldn't decode message" where gather :: Set.Set Uri -> T.Text -> Value -> Set.Set Uri gather uris "uri" (String s) = Set.insert (Uri s) uris gather uris _ (Object o) = HashMap.foldlWithKey' gather uris o diff --git a/src/Language/Haskell/LSP/Test/Recorded.hs b/src/Language/Haskell/LSP/Test/Recorded.hs index c92664c..a52c313 100644 --- a/src/Language/Haskell/LSP/Test/Recorded.hs +++ b/src/Language/Haskell/LSP/Test/Recorded.hs @@ -64,7 +64,7 @@ replay cfp sfp curRootDir = do (clientMsgs, fileMap) <- swapFiles emptyFileMap recRootDir curRootDir unswappedClientMsgs tmpDir <- getTemporaryDirectory - (_, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped" + (mappedClientRecFp, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped" mapM_ (B.hPut mappedClientRecIn . addHeader) clientMsgs hSeek mappedClientRecIn AbsoluteSeek 0 @@ -92,6 +92,10 @@ replay cfp sfp curRootDir = do -- restore directory setCurrentDirectory prevDir + -- cleanup temp files + removeFile mappedClientRecFp + cleanupFiles + return result -- | The internal monad for tests that can fail or pass, @@ -127,18 +131,7 @@ listenServer expectedMsgs h semas@(reqSema, rspSema) = do listenServer newExpectedMsgs h semas - where jsonEqual :: (FromJSON a, Eq a) => a -> B.ByteString -> Bool - jsonEqual x y = Just x == decode y - - deleteFirstJson _ [] = [] - deleteFirstJson msg (x:xs) - | jsonEqual msg x = xs - | otherwise = x:deleteFirstJson msg xs - - -- firstExpected :: Show a => a - firstExpected = head $ filter (not . isNotification) expectedMsgs - - response :: LSP.ResponseMessage Value -> Session [B.ByteString] + where response :: LSP.ResponseMessage Value -> Session [B.ByteString] response res = do lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id) @@ -148,7 +141,7 @@ listenServer expectedMsgs h semas@(reqSema, rspSema) = do lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request - return $ deleteFirstJson res expectedMsgs + markReceived res request :: LSP.RequestMessage LSP.ServerMethod Value Value -> Session [B.ByteString] request req = do @@ -160,19 +153,38 @@ listenServer expectedMsgs h semas@(reqSema, rspSema) = do lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response - return $ deleteFirstJson req expectedMsgs + markReceived req notification :: LSP.NotificationMessage LSP.ServerMethod Value -> Session [B.ByteString] notification n = do lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method) lift $ print n - return $ deleteFirstJson n expectedMsgs + + lift $ putStrLn $ (show ((length $ filter isNotification expectedMsgs) - 1)) ++ " notifications remaining" + + if n ^. LSP.method == LSP.WindowLogMessage + then return expectedMsgs + else markReceived n checkOrder msg = unless (inRightOrder msg expectedMsgs) $ do - let expected = decode firstExpected - _ = expected == Just msg -- make expected type same as res + let (Just expected) = decode firstExpected + _ = expected == msg -- make expected type same as res failSession ("Out of order\nExpected\n" ++ show expected ++ "\nGot\n" ++ show msg ++ "\n") + markReceived msg = do + let new = deleteFirstJson msg expectedMsgs + in if (new == expectedMsgs) + then failSession ("Unexpected message: " ++ show msg) >> return new + else return new + + deleteFirstJson _ [] = [] + deleteFirstJson msg (x:xs) + | (Just msg) == (decode x) = xs + | otherwise = x:deleteFirstJson msg xs + + firstExpected = head $ filter (not . isNotification) expectedMsgs + + isNotification :: B.ByteString -> Bool isNotification msg = @@ -240,10 +252,10 @@ handlers serverH (reqSema, rspSema) = def where -- TODO: May need to prevent premature exit notification being sent - -- notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do - -- putStrLn "Will send exit notification soon" - -- threadDelay 10000000 - -- B.hPut serverH $ addHeader (encode msg) + notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do + putStrLn "Will send exit notification soon" + threadDelay 10000000 + B.hPut serverH $ addHeader (encode msg) notification msg@(LSP.NotificationMessage _ m _) = do B.hPut serverH $ addHeader (encode msg) diff --git a/test/Test.hs b/test/Test.hs index 2851427..e24b1e1 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -1,14 +1,15 @@ import Test.Hspec import Language.Haskell.LSP.Test.Recorded -main = hspec $ do +main = hspec $ describe "Replay" $ do - it "passes a test" $ do + it "passes a test" $ replay "test/recordings/renamePass/client.log" "test/recordings/renamePass/server.log" "test/recordings/renamePass" `shouldReturn` True - -- it "fails a test" $ - -- replay "test/recordings/documentSymbolFail/client.log" - -- "test/recordings/documentSymbolFail/server.log" - -- `shouldReturn` False + it "fails a test" $ + replay "test/recordings/documentSymbolFail/client.log" + "test/recordings/documentSymbolFail/server.log" + "test/recordings/documentSymbolFail" + `shouldReturn` False diff --git a/test/recordings/documentSymbolFail/example/Main.hs b/test/recordings/documentSymbolFail/example/Main.hs new file mode 100644 index 0000000..ca9f849 --- /dev/null +++ b/test/recordings/documentSymbolFail/example/Main.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +module Main where + +import qualified Language.Haskell.LSP.TH.DataTypesJSON as LSP +import qualified Language.Haskell.LSP.TH.ClientCapabilities as LSP +import qualified LSP.Client as Client +import Data.Proxy +import qualified Data.Text.IO as T +import Control.Concurrent +import System.Process +import Control.Lens +import System.IO +import System.Exit +import System.Environment +import System.Directory +import Control.Monad + +import qualified Compat + +main :: IO () +main = do + progName <- getProgName + args <- getArgs + + when (length args /= 1) $ do + hPutStrLn stderr ("This program expects one argument: " ++ progName ++ " FILEPATH") + exitFailure + + let [path] = args + + exists <- doesFileExist path + unless exists $ do + hPutStrLn stderr ("File does not exist: " ++ path) + exitFailure + + file <- canonicalizePath path + + pid <- Compat.getPID + + let caps = LSP.ClientCapabilities (Just workspaceCaps) (Just textDocumentCaps) Nothing + workspaceCaps = LSP.WorkspaceClientCapabilities + (Just False) + (Just (LSP.WorkspaceEditClientCapabilities (Just False))) + (Just (LSP.DidChangeConfigurationClientCapabilities (Just False))) + (Just (LSP.DidChangeWatchedFilesClientCapabilities (Just False))) + (Just (LSP.SymbolClientCapabilities (Just False))) + (Just (LSP.ExecuteClientCapabilities (Just False))) + textDocumentCaps = LSP.TextDocumentClientCapabilities + (Just (LSP.SynchronizationTextDocumentClientCapabilities + (Just False) + (Just False) + (Just False) + (Just False))) + (Just (LSP.CompletionClientCapabilities + (Just False) + (Just (LSP.CompletionItemClientCapabilities (Just False))))) + (Just (LSP.HoverClientCapabilities (Just False))) + (Just (LSP.SignatureHelpClientCapabilities (Just False))) + (Just (LSP.ReferencesClientCapabilities (Just False))) + (Just (LSP.DocumentHighlightClientCapabilities (Just False))) + (Just (LSP.DocumentSymbolClientCapabilities (Just False))) + (Just (LSP.FormattingClientCapabilities (Just False))) + (Just (LSP.RangeFormattingClientCapabilities (Just False))) + (Just (LSP.OnTypeFormattingClientCapabilities (Just False))) + (Just (LSP.DefinitionClientCapabilities (Just False))) + (Just (LSP.CodeActionClientCapabilities (Just False))) + (Just (LSP.CodeLensClientCapabilities (Just False))) + (Just (LSP.DocumentLinkClientCapabilities (Just False))) + (Just (LSP.RenameClientCapabilities (Just False))) + + initializeParams :: LSP.InitializeParams + initializeParams = LSP.InitializeParams (Just pid) Nothing Nothing Nothing caps Nothing + + + (Just inp, Just out, _, _) <- createProcess (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "--debug"]) + {std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe} + + client <- Client.start (Client.Config inp out testNotificationMessageHandler testRequestMessageHandler) + + Client.sendClientRequest client (Proxy :: Proxy LSP.InitializeRequest) LSP.Initialize initializeParams + + Client.sendClientNotification client LSP.Initialized (Just LSP.InitializedParams) + + txt <- T.readFile file + + let uri = LSP.filePathToUri file + + Client.sendClientNotification client LSP.TextDocumentDidOpen (Just (LSP.DidOpenTextDocumentParams (LSP.TextDocumentItem uri "haskell" 1 txt))) + + Client.sendClientRequest + client + (Proxy :: Proxy LSP.DefinitionRequest) + LSP.TextDocumentDefinition + (LSP.TextDocumentPositionParams (LSP.TextDocumentIdentifier uri) (LSP.Position 88 36)) >>= \case + Just (Right pos) -> print pos + _ -> putStrLn "Server couldn't give us defnition position" + + Client.sendClientRequest client (Proxy :: Proxy LSP.DocumentSymbolRequest) LSP.TextDocumentDocumentSymbol (LSP.DocumentSymbolParams (LSP.TextDocumentIdentifier uri)) + >>= \case + Just (Right as) -> mapM_ T.putStrLn (as ^.. traverse . LSP.name) + _ -> putStrLn "Server couldn't give us document symbol information" + + Client.sendClientRequest client (Proxy :: Proxy LSP.ShutdownRequest) LSP.Shutdown Nothing + Client.sendClientNotification client LSP.Exit (Just LSP.ExitParams) + + Client.stop client + +testRequestMessageHandler :: Client.RequestMessageHandler +testRequestMessageHandler = Client.RequestMessageHandler + (\m -> emptyResponse m <$ print m) + (\m -> emptyResponse m <$ print m) + (\m -> emptyResponse m <$ print m) + (\m -> emptyResponse m <$ print m) + where + toRspId (LSP.IdInt i) = LSP.IdRspInt i + toRspId (LSP.IdString t) = LSP.IdRspString t + + emptyResponse :: LSP.RequestMessage m req resp -> LSP.ResponseMessage a + emptyResponse m = LSP.ResponseMessage (m ^. LSP.jsonrpc) (toRspId (m ^. LSP.id)) Nothing Nothing + +testNotificationMessageHandler :: Client.NotificationMessageHandler +testNotificationMessageHandler = Client.NotificationMessageHandler + (T.putStrLn . view (LSP.params . LSP.message)) + (T.putStrLn . view (LSP.params . LSP.message)) + (print . view LSP.params) + (mapM_ T.putStrLn . (^.. LSP.params . LSP.diagnostics . traverse . LSP.message))