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:
, FileMap
, emptyFileMap
, rootDir
+ , cleanupFiles
)
where
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
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
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
(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
-- restore directory
setCurrentDirectory prevDir
+ -- cleanup temp files
+ removeFile mappedClientRecFp
+ cleanupFiles
+
return result
-- | The internal monad for tests that can fail or pass,
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)
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
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 =
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)
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
--- /dev/null
+{-# 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))
projects / lsp-test.git / commitdiff