Start work adding the session monad for replays

diff --git a/.travis.yml b/.travis.yml
index 729bd20fdec694cada5f89850f4246129573a505..013f95c71019b185af55418ffdb6851dcc1e409f 100644 (file)
--- a/.travis.yml
+++ b/.travis.yml
@@ -16,7 +16,7 @@ before_install:
 install:
   - git clone https://github.com/Bubba/haskell-ide-engine.git --recursive
   - cd haskell-ide-engine
-  - git checkout 377157dad7641c2c63e8b554a46a4888dca48721
+  - git checkout d4fe878a545c2d1b9247c1ddf5e6174eeed066cb
   - stack --no-terminal --skip-ghc-check install -j1
   - stack exec hoogle generate
   - cd ..

diff --git a/dist/cabal-config-flags b/dist/cabal-config-flags
deleted file mode 100644 (file)
index 7c101f6..0000000
Binary files a/dist/cabal-config-flags and /dev/null differ

diff --git a/example/Main.hs b/example/Main.hs
index 8080991051ec609e297498b6d491ef14470c76af..4dd268c907d8c96b8af2bee7b7eff27de2b2b4ad 100644 (file)
--- a/example/Main.hs
+++ b/example/Main.hs
@@ -9,7 +9,7 @@ import System.Environment
 
 main = do
   files <- getArgs
-  forM_ files $ \fp -> session $ do
+  forM_ files $ \fp -> manualSession $ do
     file <- liftIO $ canonicalizePath fp
     openDocument file
     symbols <- documentSymbols file

diff --git a/example/Recorded.hs b/example/Recorded.hs
index ce61cb1acfad9afd9a1ea8b65e3d00c1c946062e..5d7cac1b946e0264a51e8aa27e1c4ad060fd888d 100644 (file)
--- a/example/Recorded.hs
+++ b/example/Recorded.hs
@@ -1,8 +1,12 @@
 import           Language.Haskell.LSP.Test.Recorded
 import           System.Directory
 import           System.Environment
+import           Control.Monad.IO.Class
 
 main = do
-  [session, dir] <- (take 2 <$> getArgs) >>= mapM canonicalizePath
-  passed <- replay session dir
-  putStrLn $ if passed then "Passed" else "Failed"
+  sessionFile <- (head <$> getArgs) >>= canonicalizePath
+  replay sessionFile $ do
+    x <- sendNextRequest
+    liftIO $ print x
+    y <- sendNextRequest
+    liftIO $ print y
\ No newline at end of file

diff --git a/src/Language/Haskell/LSP/Test.hs b/src/Language/Haskell/LSP/Test.hs
index 6ee8405e95cf8b48a686da53dce29d07961dbe18..5883271d89bc57ab997530baa57721ad47a91ca0 100644 (file)
--- a/src/Language/Haskell/LSP/Test.hs
+++ b/src/Language/Haskell/LSP/Test.hs
@@ -2,7 +2,7 @@
 module Language.Haskell.LSP.Test
   (
   -- * Sessions
-    session
+    manualSession
   -- * Documents
   , openDocument
   , documentSymbols
@@ -17,14 +17,16 @@ 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 Compat
 
 type Session = ReaderT Client.Client IO
 
-session :: Session a -> IO ()
-session f = do
+manualSession :: Session a -> IO ()
+manualSession f = do
   (Just hin, Just hout, _, serverProc) <- createProcess (proc "hie" ["--lsp", "-l", "/tmp/hie.log"])
     { std_in = CreatePipe, std_out = CreatePipe }
   client <- Client.start $ Client.Config hin hout notificationHandler requestHandler

diff --git a/src/Language/Haskell/LSP/Test/Recorded.hs b/src/Language/Haskell/LSP/Test/Recorded.hs
index 36a55fafd5adf579365b2c612b40ae1010e0dfd5..9c89a78d8d12710de7ded927f8723c7fdccad5e8 100644 (file)
--- a/src/Language/Haskell/LSP/Test/Recorded.hs
+++ b/src/Language/Haskell/LSP/Test/Recorded.hs
@@ -4,15 +4,17 @@
 -- | 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
+  ( replay,
+    sendNextRequest
   )
 where
 
 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           Data.List
 import           Language.Haskell.LSP.Capture
 import           Language.Haskell.LSP.Messages
 import qualified Language.Haskell.LSP.Types    as LSP
@@ -22,20 +24,30 @@ import           Control.Lens
 import           Control.Monad
 import           System.IO
 import           System.Directory
+import           System.FilePath
 import           System.Process
 import           Language.Haskell.LSP.Test.Files
 import           Language.Haskell.LSP.Test.Parsing
 
+data SessionContext = SessionContext
+  {
+    reqSema :: MVar LSP.LspId,
+    rspSema :: MVar LSP.LspIdRsp,
+    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 file.
-  -> FilePath -- ^ The root directory of the project
-  -> IO Bool
-replay sessionFp curRootDir = do
+replay :: FilePath -- ^ The recorded session directory.
+       -> Session a
+       -> IO ()
+replay sessionDir session = do
+
+  let sessionFp = sessionDir </> "session.log"
 
   -- need to keep hold of current directory since haskell-lsp changes it
-  prevDir <- getCurrentDirectory
+  prevRootDir <- getCurrentDirectory
 
   (Just serverIn, Just serverOut, _, serverProc) <- createProcess
     (proc "hie" ["--lsp", "-l", "/tmp/hie.log"]) { std_in  = CreatePipe
@@ -51,34 +63,26 @@ replay sessionFp curRootDir = do
   rspSema <- newEmptyMVar :: IO (MVar LSP.LspId)
   let semas = (reqSema, rspSema)
 
-  didPass <- newEmptyMVar
-
   entries <- B.lines <$> B.readFile sessionFp
 
   -- decode session
   let unswappedEvents = map (fromJust . decode) entries
 
-  events <- swapFiles curRootDir unswappedEvents
+  events <- swapFiles sessionDir unswappedEvents
 
-  let clientEvents =
-        map (\(FromClient _ msg) -> msg) $ filter isClientMsg events
-      serverEvents =
-        map (\(FromServer _ msg) -> msg) $ filter isServerMsg events
+  let clientEvents = map (\(FromClient _ msg) -> msg) $ filter isClientMsg events
       requestMap = getRequestMap clientEvents
 
   -- listen to server
-  forkIO $ runReaderT (listenServer serverEvents serverOut requestMap semas)
-                      didPass
+  forkIO $ listenServer serverOut requestMap semas
 
-  forM_ clientEvents (processClient serverIn rspSema reqSema)
+  runReaderT (runStateT session clientEvents) (SessionContext rspSema reqSema serverIn)
 
-  result <- takeMVar didPass
   terminateProcess serverProc
 
   -- restore directory
-  setCurrentDirectory prevDir
+  setCurrentDirectory prevRootDir
   
-  return result
   where
     isClientMsg (FromClient _ _) = True
     isClientMsg _                = False
@@ -86,9 +90,11 @@ replay sessionFp curRootDir = do
     isServerMsg (FromServer _ _) = True
     isServerMsg _                = False
 
-processClient
-  :: Handle -> MVar LSP.LspId -> MVar LSP.LspIdRsp -> FromClientMessage -> IO ()
-processClient serverH rspSema reqSema msg = case msg of
+sendNextRequest :: Session ()
+sendNextRequest = do
+  (nextMsg:remainingMsgs) <- get
+  put remainingMsgs
+  case nextMsg of
     ReqInitialize               m -> request m
     ReqShutdown                 m -> request m
     ReqHover                    m -> request m
@@ -128,182 +134,143 @@ processClient serverH rspSema reqSema msg = case msg of
  where
   -- TODO: May need to prevent premature exit notification being sent
   notification msg@(LSP.NotificationMessage _ LSP.Exit _) = do
+    context <- lift ask
+
+    liftIO $ do
       putStrLn "Will send exit notification soon"
       threadDelay 10000000
-    B.hPut serverH $ addHeader (encode msg)
+      B.hPut (serverIn context) $ addHeader (encode msg)
+
   notification msg@(LSP.NotificationMessage _ m _) = do
-    B.hPut serverH $ addHeader (encode msg)
+    context <- lift ask
+
+    liftIO $ B.hPut (serverIn context) $ addHeader (encode msg)
 
-    putStrLn $ "Sent a notification " ++ show m
+    liftIO $ putStrLn $ "Sent a notification " ++ show m
+    
+    sendNextRequest
 
   request msg@(LSP.RequestMessage _ id m _) = do
+    context <- lift ask
 
+    liftIO $ do
       when (m == LSP.TextDocumentDocumentSymbol) $ threadDelay 5000000
 
-    B.hPut serverH $ addHeader (encode msg)
-    putStrLn
-      $  "Sent a request id "
-      ++ show id
-      ++ ": "
-      ++ show m
-      ++ "\nWaiting for a response"
-
-    rspId <- takeMVar reqSema
-    when (LSP.responseId id /= rspId)
-      $  error
-      $  "Expected id "
-      ++ show id
-      ++ ", got "
-      ++ show rspId
+      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
 
   response msg@(LSP.ResponseMessage _ id _ _) = do
+    context <- lift ask
+
+    liftIO $ do
       putStrLn $ "Waiting for request id " ++ show id ++ " from the server"
-    reqId <- takeMVar rspSema
+      reqId <- takeMVar (reqSema context)
       if LSP.responseId reqId /= id
         then error $ "Expected id " ++ show reqId ++ ", got " ++ show reqId
         else do
-        B.hPut serverH $ addHeader (encode msg)
+          B.hPut (serverIn context) $ addHeader (encode msg)
           putStrLn $ "Sent response to request id " ++ show id
 
--- | 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
+    sendNextRequest
 
-passSession :: Session ()
-passSession = do
-  passVar <- ask
-  lift $ putMVar passVar True
 
 -- | Listens to the server output, makes sure it matches the record and
 -- signals any semaphores
-listenServer
-  :: [FromServerMessage]
-  -> Handle
-  -> RequestMap
-  -> (MVar LSP.LspIdRsp, MVar LSP.LspId)
-  -> Session ()
-listenServer []           _ _      _                        = passSession
-listenServer expectedMsgs h reqMap semas@(reqSema, rspSema) = do
-  msgBytes <- lift $ getNextMessage h
-
-  let actualMsg = decodeFromServerMsg reqMap msgBytes
-
-  lift $ print actualMsg
-
-  newExpectedMsgs <- case actualMsg of
-    ReqRegisterCapability       m -> request actualMsg m
-    ReqApplyWorkspaceEdit       m -> request actualMsg m
-    ReqShowMessage              m -> request actualMsg m
-    ReqUnregisterCapability     m -> request actualMsg m
-    RspInitialize               m -> response actualMsg m
-    RspShutdown                 m -> response actualMsg m
-    RspHover                    m -> response actualMsg m
-    RspCompletion               m -> response actualMsg m
-    RspCompletionItemResolve    m -> response actualMsg m
-    RspSignatureHelp            m -> response actualMsg m
-    RspDefinition               m -> response actualMsg m
-    RspFindReferences           m -> response actualMsg m
-    RspDocumentHighlights       m -> response actualMsg m
-    RspDocumentSymbols          m -> response actualMsg m
-    RspWorkspaceSymbols         m -> response actualMsg m
-    RspCodeAction               m -> response actualMsg m
-    RspCodeLens                 m -> response actualMsg m
-    RspCodeLensResolve          m -> response actualMsg m
-    RspDocumentFormatting       m -> response actualMsg m
-    RspDocumentRangeFormatting  m -> response actualMsg m
-    RspDocumentOnTypeFormatting m -> response actualMsg m
-    RspRename                   m -> response actualMsg m
-    RspExecuteCommand           m -> response actualMsg m
-    RspError                    m -> response actualMsg m
-    RspDocumentLink             m -> response actualMsg m
-    RspDocumentLinkResolve      m -> response actualMsg m
-    RspWillSaveWaitUntil        m -> response actualMsg m
-    NotPublishDiagnostics       m -> notification actualMsg m
-    NotLogMessage               m -> notification actualMsg m
-    NotShowMessage              m -> notification actualMsg m
-    NotTelemetry                m -> notification actualMsg m
-    NotCancelRequestFromServer  m -> notification actualMsg m
-
-  listenServer newExpectedMsgs h reqMap semas
+listenServer :: Handle -> RequestMap -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> IO ()
+listenServer h reqMap semas@(reqSema, rspSema) = do
+  msgBytes <- getNextMessage h
+
+  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
+    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 semas
+
   where
-  response
-    :: Show a
-    => FromServerMessage
-    -> LSP.ResponseMessage a
-    -> Session [FromServerMessage]
-  response msg res = do
-    lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
-
-    lift $ print res
-
-    checkOrder msg
-
-    lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
-
-    markReceived msg
-
-  request
-    :: (Show a, Show b)
-    => FromServerMessage
-    -> LSP.RequestMessage LSP.ServerMethod a b
-    -> Session [FromServerMessage]
-  request msg req = do
-    lift
-      $  putStrLn
+  response :: Show a => LSP.ResponseMessage a -> IO ()
+  response res = 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
+
+  request :: Show a => LSP.RequestMessage LSP.ServerMethod a b -> IO ()
+  request req = do
+    putStrLn
       $  "Got request for id "
       ++ show (req ^. LSP.id)
       ++ " "
       ++ show (req ^. LSP.method)
 
-    lift $ print req
+    print req
 
-    checkOrder msg
+    putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
 
-    lift $ putMVar rspSema (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
 
-    markReceived msg
+  --   lift
+  --     $  putStrLn
+  --     $  show (length (filter isNotification expectedMsgs) - 1)
+  --     ++ " notifications remaining"
 
-  notification
-    :: Show a
-    => FromServerMessage
-    -> LSP.NotificationMessage LSP.ServerMethod a
-    -> Session [FromServerMessage]
-  notification msg n = do
-    lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
-    lift $ print n
+  -- checkOrder msg = unless (inRightOrder msg expectedMsgs) $ failSession
+  --   (  "Out of order\nExpected\n"
+  --   ++ show firstExpected
+  --   ++ "\nGot\n"
+  --   ++ show msg
+  --   ++ "\n"
+  --   )
 
-    lift
-      $  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
 
-    if n ^. LSP.method == LSP.WindowLogMessage
-      then return expectedMsgs
-      else markReceived msg
-
-  checkOrder msg = unless (inRightOrder msg expectedMsgs) $ failSession
-    (  "Out of order\nExpected\n"
-    ++ show firstExpected
-    ++ "\nGot\n"
-    ++ show msg
-    ++ "\n"
-    )
-
-  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
+  -- firstExpected = head $ filter (not . isNotification) expectedMsgs
 
 isNotification :: FromServerMessage -> Bool
 isNotification (NotPublishDiagnostics      _) = True
@@ -331,3 +298,19 @@ inRightOrder received (expected : msgs)
   | received == expected    = True
   | isNotification expected = inRightOrder received msgs
   | otherwise               = False
+
+-- | 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/stack.yaml b/stack.yaml
index 35cf5b183167fa61c499ef899dad40b9716e7e44..8de2811463b7a32bb62e7581ebd6b4c2bddf8d1e 100644 (file)
--- a/stack.yaml
+++ b/stack.yaml
@@ -1,4 +1,4 @@
-resolver: nightly-2018-05-30
+resolver: nightly-2018-06-02
 packages:
   - .
 

diff --git a/test/Test.hs b/test/Test.hs
index 3fd14e4c5dc9cbad53ff157cbffd0e8da8aecfae..7c7f272ad6f620c32735ae47aeeef896c2386b48 100644 (file)
--- a/test/Test.hs
+++ b/test/Test.hs
@@ -2,37 +2,17 @@ import Test.Hspec
 import System.IO
 import System.Directory
 import Control.Lens
+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
 
-main = hspec $ do
-  describe "Replay" $ 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" 
-             "test/recordings/documentSymbolFail"
-        `shouldReturn` False
-
-  -- describe "file swapping" $ do
-  --   it "gets the base directory" $ do
-  --     h <- openFile "test/recordings/renamePass/client.log" ReadMode
-  --     msgs <- getAllMessages h
-  --     rootDir msgs `shouldBe` "/Users/luke/Desktop"
-  
-    -- it "gets builds a mapping of files" $ do
-    --   h <- openFile "test/recordings/renamePass/client.log" ReadMode
-    --   msgs <- getAllMessages h
-    --   let root = rootDir msgs
-    --   swapped <- swapFiles root "test/recordings/renamePass/" msgs
-    --   let (Just n) = decode (swapped !! 3) :: Maybe LSP.DidOpenNotification
-
-    --   cd <- getCurrentDirectory
-
-    --   n .^ params . uri `shouldBe` LSP.uriFromFilePath (cd </> "test/recordings/renamePass/")
+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