From 13928a9c66b4a352ae784660877d4fae57ac81d9 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 6 Jun 2018 00:01:55 -0400 Subject: [PATCH] Update recorded playback to build upon new session --- .travis.yml | 1 + example/Recorded.hs | 8 +- src/Language/Haskell/LSP/Test.hs | 88 ++++--- src/Language/Haskell/LSP/Test/Files.hs | 26 ++- src/Language/Haskell/LSP/Test/Recorded.hs | 273 +++++++++------------- test/Test.hs | 7 +- test/recordings/renamePass/session.log | 2 +- 7 files changed, 193 insertions(+), 212 deletions(-) diff --git a/.travis.yml b/.travis.yml index 8305980..22b64e9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -16,6 +16,7 @@ before_install: install: - git clone https://github.com/haskell/haskell-ide-engine.git --recursive - cd haskell-ide-engine + - git checkout c34c08eeced8173983601e98304258075f3057e1 - stack --no-terminal --skip-ghc-check install -j1 - stack exec hoogle generate - cd .. diff --git a/example/Recorded.hs b/example/Recorded.hs index 5d7cac1..e9b1621 100644 --- a/example/Recorded.hs +++ b/example/Recorded.hs @@ -3,10 +3,4 @@ import System.Directory import System.Environment import Control.Monad.IO.Class -main = do - sessionFile <- (head <$> getArgs) >>= canonicalizePath - replay sessionFile $ do - x <- sendNextRequest - liftIO $ print x - y <- sendNextRequest - liftIO $ print y \ No newline at end of file +main = undefined \ No newline at end of file diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs index a914a68..22a6746 100644 --- a/src/Language/Haskell/LSP/Test.hs +++ b/src/Language/Haskell/LSP/Test.hs @@ -15,10 +15,14 @@ module Language.Haskell.LSP.Test ( -- * Sessions runSession + , runSessionWithHandler , Session -- * Sending , sendRequest , sendNotification + , sendRequest' + , sendNotification' + , sendResponse' -- * Receving , getMessage -- * Utilities @@ -26,6 +30,7 @@ module Language.Haskell.LSP.Test , getDocUri ) where +import Control.Monad import Control.Monad.Trans.Class import Control.Monad.IO.Class import Control.Monad.Trans.Reader @@ -50,7 +55,6 @@ data SessionContext = SessionContext { messageSema :: MVar B.ByteString, serverIn :: Handle, - serverOut :: Handle, rootDir :: FilePath } @@ -78,31 +82,19 @@ runSession :: FilePath -- ^ The filepath to the root directory for the session. -> Session a -- ^ The session to run. -> 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 } - - hSetBuffering serverIn NoBuffering - hSetBuffering serverOut NoBuffering - pid <- getProcessID - messageSema <- newEmptyMVar + absRootDir <- canonicalizePath rootDir - let initializeParams :: InitializeParams - initializeParams = InitializeParams (Just pid) + let 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) - -- | The session wrapped around initialize and shutdown calls - fullSession = do + runSessionWithHandler listenServer rootDir $ do + + -- Wrap the session around initialize and shutdown calls sendRequest (Proxy :: Proxy InitializeRequest) Initialize initializeParams (ResponseMessage _ _ (Just (InitializeResponseCapabilities _)) e) <- getMessage liftIO $ maybe (return ()) (putStrLn . ("Error when initializing: " ++) . show ) e @@ -114,20 +106,40 @@ runSession rootDir session = do sendNotification Exit ExitParams - forkIO $ listenServer context - _ <- runReaderT (runStateT fullSession initState) context +runSessionWithHandler :: (Handle -> Session ()) + -> FilePath + -> Session a + -> IO a +runSessionWithHandler serverHandler 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 } + + hSetBuffering serverIn NoBuffering + hSetBuffering serverOut NoBuffering + + messageSema <- newEmptyMVar + + let context = SessionContext messageSema serverIn absRootDir + initState = SessionState (IdInt 9) + + forkIO $ void $ runReaderT (runStateT (serverHandler serverOut) initState) context + (result, _) <- runReaderT (runStateT session initState) context terminateProcess serverProc - return () + return result -- | 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) +listenServer :: Handle -> Session () +listenServer serverOut = do + context <- lift ask + msgBytes <- liftIO $ getNextMessage serverOut - case decode msgBytes :: Maybe LogMessageNotification of + liftIO $ 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 @@ -135,7 +147,7 @@ listenServer context = do -- Give everything else for getMessage to handle _ -> putMVar (messageSema context) msgBytes - listenServer context + listenServer serverOut -- | Sends a request to the server. -- @@ -151,29 +163,39 @@ sendRequest -> params -- ^ The request parameters. -> Session LspId -- ^ The id of the request that was sent. 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 + let req = RequestMessage "2.0" id method params :: RequestMessage ClientMethod params resp - liftIO $ B.hPut h $ addHeader (encode msg) + sendRequest' req return id where nextId (IdInt i) = IdInt (i + 1) nextId (IdString s) = IdString $ T.pack $ show $ read (T.unpack s) + 1 +sendRequest' :: (ToJSON a, ToJSON b, ToJSON c) => RequestMessage a b c -> Session () +sendRequest' = sendMessage + -- | Sends a notification to the server. sendNotification :: ToJSON a => ClientMethod -- ^ The notification method. -> a -- ^ The notification parameters. -> Session () -sendNotification method params = do - h <- serverIn <$> lift ask +sendNotification method params = + let notif = NotificationMessage "2.0" method params + in sendNotification' notif + +sendNotification' :: (ToJSON a, ToJSON b) => NotificationMessage a b -> Session () +sendNotification' = sendMessage - let msg = NotificationMessage "2.0" method params +sendResponse' :: ToJSON a => ResponseMessage a -> Session () +sendResponse' = sendMessage + +sendMessage :: ToJSON a => a -> Session () +sendMessage msg = do + h <- serverIn <$> lift ask liftIO $ B.hPut h $ addHeader (encode msg) -- | Reads in a message from the server. diff --git a/src/Language/Haskell/LSP/Test/Files.hs b/src/Language/Haskell/LSP/Test/Files.hs index 59d51ce..f82df65 100644 --- a/src/Language/Haskell/LSP/Test/Files.hs +++ b/src/Language/Haskell/LSP/Test/Files.hs @@ -51,17 +51,33 @@ mapUris f event = fromClientMsg (NotDidSaveTextDocument n) = NotDidSaveTextDocument $ swapUri (params . textDocument) n fromClientMsg (NotDidCloseTextDocument n) = NotDidCloseTextDocument $ swapUri (params . textDocument) n fromClientMsg (ReqInitialize r) = ReqInitialize $ params .~ (transformInit (r ^. params)) $ r + fromClientMsg (ReqDocumentSymbols r) = ReqDocumentSymbols $ swapUri (params . textDocument) r + fromClientMsg (ReqRename r) = ReqRename $ swapUri (params . textDocument) r fromClientMsg x = x fromServerMsg :: FromServerMessage -> FromServerMessage fromServerMsg (ReqApplyWorkspaceEdit r) = - let newDocChanges = fmap (fmap (swapUri textDocument)) $ r ^. params . edit . documentChanges - r1 = (params . edit . documentChanges) .~ newDocChanges $ r - newChanges = fmap (swapKeys f) $ r1 ^. params . edit . changes - r2 = (params . edit . changes) .~ newChanges $ r1 - in ReqApplyWorkspaceEdit r2 + ReqApplyWorkspaceEdit $ params . edit .~ swapWorkspaceEdit (r ^. params . edit) $ r + + fromServerMsg (NotPublishDiagnostics n) = NotPublishDiagnostics $ swapUri params n + + fromServerMsg (RspDocumentSymbols r) = + let newSymbols = fmap (fmap (swapUri location)) $ r ^. result + in RspDocumentSymbols $ result .~ newSymbols $ r + + fromServerMsg (RspRename r) = + let oldResult = r ^. result :: Maybe WorkspaceEdit + newResult = fmap swapWorkspaceEdit oldResult + in RspRename $ result .~ newResult $ r + fromServerMsg x = x + swapWorkspaceEdit :: WorkspaceEdit -> WorkspaceEdit + swapWorkspaceEdit e = + let newDocChanges = fmap (fmap (swapUri textDocument)) $ e ^. documentChanges + newChanges = fmap (swapKeys f) $ e ^. changes + in WorkspaceEdit newChanges newDocChanges + swapKeys :: (Uri -> Uri) -> HM.HashMap Uri b -> HM.HashMap Uri b swapKeys f = HM.foldlWithKey' (\acc k v -> HM.insert (f k) v acc) HM.empty diff --git a/src/Language/Haskell/LSP/Test/Recorded.hs b/src/Language/Haskell/LSP/Test/Recorded.hs index 2fae088..c028478 100644 --- a/src/Language/Haskell/LSP/Test/Recorded.hs +++ b/src/Language/Haskell/LSP/Test/Recorded.hs @@ -4,62 +4,36 @@ -- | A testing tool for replaying recorded client logs back to a server, -- and validating that the server output matches up with another log. module Language.Haskell.LSP.Test.Recorded - ( replay, - sendNextRequest + ( replaySession ) where +import Prelude hiding (id) import Control.Concurrent -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.State import Control.Monad.IO.Class import qualified Data.ByteString.Lazy.Char8 as B import Language.Haskell.LSP.Capture import Language.Haskell.LSP.Messages -import qualified Language.Haskell.LSP.Types as LSP +import Language.Haskell.LSP.Types hiding (error) import Data.Aeson +import Data.List import Data.Maybe import Control.Lens import Control.Monad import System.IO -import System.Directory import System.FilePath -import System.Process +import Language.Haskell.LSP.Test import Language.Haskell.LSP.Test.Files import Language.Haskell.LSP.Test.Parsing -data SessionContext = SessionContext - { - reqSema :: MVar FromServerMessage, - rspSema :: MVar LSP.LspId, - serverIn :: Handle - } -type Session = StateT [FromClientMessage] (ReaderT SessionContext IO) -- | Replays a recorded client output and -- makes sure it matches up with an expected response. -replay :: FilePath -- ^ The recorded session directory. - -> Session a - -> IO () -replay sessionDir session = do +replaySession :: FilePath -- ^ The recorded session directory. + -> IO Bool +replaySession sessionDir = do - let sessionFp = sessionDir "session.log" - - (Just serverIn, Just serverOut, _, serverProc) <- createProcess - (proc "hie" ["--lsp", "-d", "-l", "/tmp/test-hie.log"]) { std_in = CreatePipe - , std_out = CreatePipe - } - - hSetBuffering serverIn NoBuffering - hSetBuffering serverOut NoBuffering - - -- whether to send the next request - reqSema <- newEmptyMVar - -- whether to send the next response - rspSema <- newEmptyMVar - - entries <- B.lines <$> B.readFile sessionFp + entries <- B.lines <$> B.readFile (sessionDir "session.log") -- decode session let unswappedEvents = map (fromJust . decode) entries @@ -67,15 +41,18 @@ replay sessionDir session = do events <- swapFiles sessionDir unswappedEvents let clientEvents = map (\(FromClient _ msg) -> msg) $ filter isClientMsg events + serverEvents = map (\(FromServer _ msg) -> msg) $ filter isServerMsg events requestMap = getRequestMap clientEvents - context = (SessionContext rspSema reqSema serverIn) - -- listen to server - forkIO $ listenServer serverOut requestMap context - runReaderT (runStateT session clientEvents) context + reqSema <- newEmptyMVar + rspSema <- newEmptyMVar + passVar <- newEmptyMVar :: IO (MVar Bool) + + forkIO $ runSessionWithHandler (listenServer serverEvents requestMap reqSema rspSema passVar) sessionDir $ + sendMessages clientEvents reqSema rspSema - terminateProcess serverProc + takeMVar passVar where isClientMsg (FromClient _ _) = True @@ -84,10 +61,9 @@ replay sessionDir session = do isServerMsg (FromServer _ _) = True isServerMsg _ = False -sendNextRequest :: Session FromServerMessage -sendNextRequest = do - (nextMsg:remainingMsgs) <- get - put remainingMsgs +sendMessages :: [FromClientMessage] -> MVar LspId -> MVar LspIdRsp -> Session () +sendMessages [] _ _ = return () +sendMessages (nextMsg:remainingMsgs) reqSema rspSema = case nextMsg of ReqInitialize m -> request m ReqShutdown m -> request m @@ -123,155 +99,138 @@ sendNextRequest = do NotWillSaveTextDocument m -> notification m NotDidSaveTextDocument m -> notification m NotDidChangeWatchedFiles m -> notification m - UnknownFromClientMessage m -> - error $ "Unknown message was recorded from the client" ++ show m + UnknownFromClientMessage m -> liftIO $ error $ "Unknown message was recorded from the client" ++ show m where -- TODO: May need to prevent premature exit notification being sent - notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do - context <- lift ask + notification msg@(NotificationMessage _ Exit _) = do + liftIO $ putStrLn "Will send exit notification soon" + liftIO $ threadDelay 10000000 + sendNotification' msg - liftIO $ do - putStrLn "Will send exit notification soon" - threadDelay 10000000 - B.hPut (serverIn context) $ addHeader (encode msg) + liftIO $ error "Done" - error "Done" - - notification msg@(LSP.NotificationMessage _ m _) = do - context <- lift ask - - liftIO $ B.hPut (serverIn context) $ addHeader (encode msg) + notification msg@(NotificationMessage _ m _) = do + sendNotification' msg liftIO $ putStrLn $ "Sent a notification " ++ show m - sendNextRequest - - request msg@(LSP.RequestMessage _ id m _) = do - context <- lift ask - - liftIO $ do + sendMessages remainingMsgs reqSema rspSema - print $ addHeader $ encode msg + request msg@(RequestMessage _ id m _) = do + liftIO $ print $ addHeader $ encode msg - B.hPut (serverIn context) $ addHeader (encode msg) - putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response" + sendRequest' msg + liftIO $ putStrLn $ "Sent a request id " ++ show id ++ ": " ++ show m ++ "\nWaiting for a response" - rsp <- takeMVar (reqSema context) - -- when (LSP.responseId id /= rsp ^. LSP.id) $ - -- error $ "Expected id " ++ show id ++ ", got " ++ show (rsp ^. LSP.id) + rsp <- liftIO $ takeMVar rspSema + when (responseId id /= rsp) $ + error $ "Expected id " ++ show id ++ ", got " ++ show rsp - return rsp + sendMessages remainingMsgs reqSema rspSema - response msg@(LSP.ResponseMessage _ id _ _) = do - context <- lift ask - - liftIO $ do - putStrLn $ "Waiting for request id " ++ show id ++ " from the server" - reqId <- takeMVar (rspSema context) - if LSP.responseId reqId /= id + response msg@(ResponseMessage _ id _ _) = do + liftIO $ putStrLn $ "Waiting for request id " ++ show id ++ " from the server" + reqId <- liftIO $ takeMVar reqSema + if responseId reqId /= id then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId else do - B.hPut (serverIn context) $ addHeader (encode msg) - putStrLn $ "Sent response to request id " ++ show id - - sendNextRequest + sendResponse' msg + liftIO $ putStrLn $ "Sent response to request id " ++ show id + sendMessages remainingMsgs reqSema rspSema --- | Listens to the server output, makes sure it matches the record and --- signals any semaphores -listenServer :: Handle -> RequestMap -> SessionContext -> IO () -listenServer h reqMap context = do - msgBytes <- getNextMessage h +isNotification :: FromServerMessage -> Bool +isNotification (NotPublishDiagnostics _) = True +isNotification (NotLogMessage _) = True +isNotification (NotShowMessage _) = True +isNotification (NotCancelRequestFromServer _) = True +isNotification _ = False +listenServer :: [FromServerMessage] -> RequestMap -> MVar LspId -> MVar LspIdRsp -> MVar Bool -> Handle -> Session () +listenServer [] _ _ _ passVar _ = liftIO $ putMVar passVar True +listenServer expectedMsgs reqMap reqSema rspSema passVar serverOut = do + msgBytes <- liftIO $ getNextMessage serverOut let msg = decodeFromServerMsg reqMap msgBytes - print msg - case msg of ReqRegisterCapability m -> request m ReqApplyWorkspaceEdit m -> request m ReqShowMessage m -> request m ReqUnregisterCapability m -> request 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 + 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 NotPublishDiagnostics m -> notification m NotLogMessage m -> notification m NotShowMessage m -> notification m NotTelemetry m -> notification m NotCancelRequestFromServer m -> notification m - listenServer h reqMap context + if inRightOrder msg expectedMsgs + then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passVar serverOut + else liftIO $ do + putStrLn "Out of order" + putStrLn "Got:" + print msg + putStrLn "Expected one of:" + mapM_ print $ takeWhile (not . isNotification) expectedMsgs + print $ head $ dropWhile (not . isNotification) expectedMsgs + putMVar passVar False where - response :: Show a => LSP.ResponseMessage a -> FromServerMessage -> IO () - response res wrappedMsg = do - putStrLn $ "Got response for id " ++ show (res ^. LSP.id) + response :: Show a => ResponseMessage a -> Session () + response res = do + liftIO $ putStrLn $ "Got response for id " ++ show (res ^. id) + + liftIO $ print res - putMVar (reqSema context) wrappedMsg -- send back the response for the request we're waiting on + liftIO $ putMVar rspSema (res ^. id) -- unblock the handler waiting to send a request - request :: Show a => LSP.RequestMessage LSP.ServerMethod a b -> IO () + request :: (Show a, Show b) => RequestMessage ServerMethod a b -> Session () request req = do - putStrLn + liftIO + $ putStrLn $ "Got request for id " - ++ show (req ^. LSP.id) + ++ show (req ^. id) ++ " " - ++ show (req ^. LSP.method) + ++ show (req ^. method) - putMVar (rspSema context) (req ^. LSP.id) -- unblock the handler waiting for a response + liftIO $ print req - notification :: Show a => LSP.NotificationMessage LSP.ServerMethod a -> IO () - notification n = putStrLn $ "Got notification " ++ show (n ^. LSP.method) + liftIO $ putMVar reqSema (req ^. id) -- unblock the handler waiting for a response - -- lift - -- $ putStrLn - -- $ show (length (filter isNotification expectedMsgs) - 1) - -- ++ " notifications remaining" + notification :: Show a => NotificationMessage ServerMethod a -> Session () + notification n = do + liftIO $ putStrLn $ "Got notification " ++ show (n ^. method) + liftIO $ print n - -- checkOrder msg = unless (inRightOrder msg expectedMsgs) $ failSession - -- ( "Out of order\nExpected\n" - -- ++ show firstExpected - -- ++ "\nGot\n" - -- ++ show msg - -- ++ "\n" - -- ) + liftIO + $ putStrLn + $ show (length (filter isNotification expectedMsgs) - 1) + ++ " notifications remaining" - -- markReceived :: FromServerMessage -> Session [FromServerMessage] - -- markReceived msg = - -- let new = delete msg expectedMsgs - -- in if new == expectedMsgs - -- then failSession ("Unexpected message: " ++ show msg) >> return new - -- else return new - -- firstExpected = head $ filter (not . isNotification) expectedMsgs - -isNotification :: FromServerMessage -> Bool -isNotification (NotPublishDiagnostics _) = True -isNotification (NotLogMessage _) = True -isNotification (NotShowMessage _) = True -isNotification (NotCancelRequestFromServer _) = True -isNotification _ = False -- TODO: QuickCheck tests? -- | Checks wether or not the message appears in the right order @@ -292,19 +251,3 @@ inRightOrder received (expected : msgs) | received == expected = True | isNotification expected = inRightOrder received msgs | otherwise = False \ No newline at end of file - --- | The internal monad for tests that can fail or pass, --- ending execution early. --- type Session = ReaderT (MVar Bool) IO - --- -- TODO: Make return type polymoprhic more like error --- failSession :: String -> Session () --- failSession reason = do --- lift $ putStrLn reason --- passVar <- ask --- lift $ putMVar passVar False - --- passSession :: Session () --- passSession = do --- passVar <- ask --- lift $ putMVar passVar True \ No newline at end of file diff --git a/test/Test.hs b/test/Test.hs index 604ea1c..2bd8f4e 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -5,9 +5,10 @@ import Data.Proxy import Control.Monad.IO.Class import Control.Lens hiding (List) import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Test.Recorded import Language.Haskell.LSP.TH.DataTypesJSON -main = hspec $ +main = hspec $ do describe "manual session validation" $ it "passes a test" $ runSession "test/recordings/renamePass" $ do @@ -32,3 +33,7 @@ main = hspec $ mainSymbol ^. kind `shouldBe` SkFunction mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4) mainSymbol ^. containerName `shouldBe` Nothing + + describe "replay session" $ + it "passes a test" $ + replaySession "test/recordings/renamePass" `shouldReturn` True \ No newline at end of file diff --git a/test/recordings/renamePass/session.log b/test/recordings/renamePass/session.log index 0e9be02..1542063 100644 --- a/test/recordings/renamePass/session.log +++ b/test/recordings/renamePass/session.log @@ -4,7 +4,7 @@ {"tag":"FromClient","contents":["2018-06-03T04:08:39.325807Z",{"tag":"NotDidChangeConfiguration","contents":{"jsonrpc":"2.0","params":{"settings":{}},"method":"workspace/didChangeConfiguration"}}]} {"tag":"FromClient","contents":["2018-06-03T04:08:39.326177Z",{"tag":"NotDidOpenTextDocument","contents":{"jsonrpc":"2.0","params":{"textDocument":{"languageId":"haskell","text":"module Main where\n\nmain :: IO ()\nmain = do\n let initialList = []\n interactWithUser initialList\n\ntype Item = String\ntype Items = [Item]\n\ndata Command = Quit\n | DisplayItems\n | AddItem String\n | RemoveItem Int\n | Help\n\ntype Error = String\n\nparseCommand :: String -> Either Error Command\nparseCommand line = case words line of\n [\"quit\"] -> Right Quit\n [\"items\"] -> Right DisplayItems\n \"add\" : item -> Right $ AddItem $ unwords item\n \"remove\" : i -> Right $ RemoveItem $ read $ unwords i\n [\"help\"] -> Right Help\n _ -> Left \"Unknown command\"\n\naddItem :: Item -> Items -> Items\naddItem = (:)\n\ndisplayItems :: Items -> String\ndisplayItems = unlines . map (\"- \" ++)\n\nremoveItem :: Int -> Items -> Either Error Items\nremoveItem i items\n | i < 0 || i >= length items = Left \"Out of range\"\n | otherwise = Right result\n where (front, back) = splitAt (i + 1) items\n result = init front ++ back\n\ninteractWithUser :: Items -> IO ()\ninteractWithUser items = do\n line <- getLine\n case parseCommand line of\n Right DisplayItems -> do\n putStrLn $ displayItems items\n interactWithUser items\n\n Right (AddItem item) -> do\n let newItems = addItem item items\n putStrLn \"Added\"\n interactWithUser newItems\n\n Right (RemoveItem i) ->\n case removeItem i items of\n Right newItems -> do\n putStrLn $ \"Removed \" ++ items !! i\n interactWithUser newItems\n Left err -> do\n putStrLn err\n interactWithUser items\n\n\n Right Quit -> return ()\n\n Right Help -> do\n putStrLn \"Commands:\"\n putStrLn \"help\"\n putStrLn \"items\"\n putStrLn \"add\"\n putStrLn \"quit\"\n interactWithUser items\n\n Left err -> do\n putStrLn $ \"Error: \" ++ err\n interactWithUser items\n","uri":"file:///Users/luke/Desktop/simple.hs","version":0}},"method":"textDocument/didOpen"}}]} {"tag":"FromServer","contents":["2018-06-03T04:08:39.327288Z",{"tag":"NotLogMessage","contents":{"jsonrpc":"2.0","params":{"type":1,"message":"haskell-lsp:didChangeConfiguration error. NotificationMessage {_jsonrpc = \"2.0\", _method = WorkspaceDidChangeConfiguration, _params = DidChangeConfigurationParams {_settings = Object (fromList [])}} \"key \\\"languageServerHaskell\\\" not present\""},"method":"window/logMessage"}}]} -{"tag":"FromServer","contents":["2018-06-03T04:08:39.327577Z",{"tag":"NotLogMessage","contents":{"jsonrpc":"2.0","params":{"type":4,"message":"Using hie version: Version 0.2.0.0, Git revision d4fe878a545c2d1b9247c1ddf5e6174eeed066cb (1431 commits) x86_64 ghc-8.4.2"},"method":"window/logMessage"}}]} +{"tag":"FromServer","contents":["2018-06-03T04:08:39.327577Z",{"tag":"NotLogMessage","contents":{"jsonrpc":"2.0","params":{"type":4,"message":"Using hie version: Version 0.2.0.0, Git revision c34c08eeced8173983601e98304258075f3057e1 (1459 commits) x86_64 ghc-8.4.3"},"method":"window/logMessage"}}]} {"tag":"FromServer","contents":["2018-06-03T04:08:39.328266Z",{"tag":"NotLogMessage","contents":{"jsonrpc":"2.0","params":{"type":4,"message":"Using hoogle db at: /Users/luke/.hoogle/default-haskell-5.0.17.hoo"},"method":"window/logMessage"}}]} {"tag":"FromServer","contents":["2018-06-03T04:08:39.524239Z",{"tag":"NotPublishDiagnostics","contents":{"jsonrpc":"2.0","params":{"uri":"file:///Users/luke/Desktop/simple.hs","diagnostics":[]},"method":"textDocument/publishDiagnostics"}}]} {"tag":"FromServer","contents":["2018-06-03T04:08:39.714012Z",{"tag":"NotPublishDiagnostics","contents":{"jsonrpc":"2.0","params":{"uri":"file:///Users/luke/Desktop/simple.hs","diagnostics":[]},"method":"textDocument/publishDiagnostics"}}]} -- 2.30.2