Add recorded playback

diff --git a/.travis.yml b/.travis.yml
index d8f497678bfa79240bb0081282ad53f0458fd6ad..9e73eaa8db66581a4464d933d378c265b0c5567b 100644 (file)
--- a/.travis.yml
+++ b/.travis.yml
@@ -1,4 +1,4 @@
-language: haskell
+language: c
 
 sudo: false
 

diff --git a/example/Main.hs b/example/Main.hs
index 9318bcb7df8249fe8821dba52c255e278dc8b5bf..8080991051ec609e297498b6d491ef14470c76af 100644 (file)
--- a/example/Main.hs
+++ b/example/Main.hs
@@ -9,8 +9,8 @@ import System.Environment
 
 main = do
   files <- getArgs
-  forM_ files $ \file -> session $ do
-    file <- liftIO $ canonicalizePath file
+  forM_ files $ \fp -> session $ do
+    file <- liftIO $ canonicalizePath fp
     openDocument file
     symbols <- documentSymbols file
     liftIO $ mapM_ T.putStrLn (symbols ^.. traverse . LSP.name)

diff --git a/example/Recorded.hs b/example/Recorded.hs
new file mode 100644 (file)
index 0000000..dc4aa69
--- /dev/null
+++ b/example/Recorded.hs
@@ -0,0 +1,7 @@
+import           Language.Haskell.LSP.Test.Recorded
+import           System.Directory
+import           System.Environment
+
+main = do
+  file <- (head <$> getArgs) >>= canonicalizePath
+  replay file

diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal
index 44c0487989b04b57bb5f368e977bf5754df0c089..b00d5077ea3df7e45ae0e21ab8aec2819b89f7af 100644 (file)
--- a/haskell-lsp-test.cabal
+++ b/haskell-lsp-test.cabal
@@ -16,10 +16,15 @@ extra-source-files:  README.md
 library
   hs-source-dirs:      src
   exposed-modules:     Language.Haskell.LSP.Test
+                     , Language.Haskell.LSP.Test.Recorded
   default-language:    Haskell2010
   build-depends:       base >= 4.7 && < 5
                      , haskell-lsp-client
                      , haskell-lsp-types
+                     , haskell-lsp
+                     , data-default
+                     , bytestring
+                     , aeson
                      , lens
                      , text
                      , transformers
@@ -42,3 +47,11 @@ executable example
                      , lens
                      , text
                      , directory
+
+executable recorded-example
+  hs-source-dirs:      example
+  main-is:             Recorded.hs
+  default-language:    Haskell2010
+  build-depends:       base >= 4.7 && < 5
+                     , haskell-lsp-test
+                     , directory

diff --git a/src/Language/Haskell/LSP/Test/Recorded.hs b/src/Language/Haskell/LSP/Test/Recorded.hs
new file mode 100644 (file)
index 0000000..10aebe3
--- /dev/null
+++ b/src/Language/Haskell/LSP/Test/Recorded.hs
@@ -0,0 +1,128 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.Haskell.LSP.Test.Recorded
+  ( replay
+  )
+where
+
+import           Control.Concurrent
+import           Control.Monad
+import           Data.Default
+import           Language.Haskell.LSP.Control  as Control
+import qualified Data.ByteString.Lazy.Char8    as B
+import           Language.Haskell.LSP.Core
+import qualified Language.Haskell.LSP.Types    as LSP
+import           Data.Aeson
+import           System.IO
+import           System.Process
+
+replay :: FilePath -> IO Int
+replay fp = do
+
+  (Just serverIn, Just serverOut, _, _) <- createProcess
+    (proc "hie" ["--lsp", "-l", "/tmp/hie.log", "-d"]) { std_in  = CreatePipe
+                                                       , std_out = CreatePipe
+                                                       }
+
+  hSetBuffering serverIn  NoBuffering
+  hSetBuffering serverOut NoBuffering
+
+  -- whether to send the next request
+  semaphore <- newEmptyMVar
+
+  -- listen to server
+  forkIO $ forever $ do
+    headers <- getHeaders serverOut
+    case read . init <$> lookup "Content-Length" headers of
+      Nothing   -> error "Couldn't read Content-Length header"
+      Just size -> do
+        message <- B.hGet serverOut size
+        case decode message :: Maybe (LSP.ResponseMessage Value) of
+          Just _  -> putMVar semaphore ()
+          Nothing -> return () -- might be a notification or something, that's ok
+
+  -- the recorded client input to the server
+  clientRecIn <- openFile fp ReadMode
+  null        <- openFile "/dev/null" WriteMode
+
+  -- send inialize request ourselves since haskell-lsp consumes it
+  -- rest are handled via `handlers`
+  sendInitialize clientRecIn serverIn
+
+  Control.runWithHandles clientRecIn
+                         null
+                         (const $ Right (), const $ return Nothing)
+                         (handlers serverIn semaphore)
+                         def
+                         Nothing
+                         Nothing
+ where
+  sendInitialize recH serverH = do
+    headers <- getHeaders recH
+    case read . init <$> lookup "Content-Length" headers of
+      Nothing   -> error "Failed to read the read the initialize request"
+      Just size -> do
+        message <- B.hGet recH size
+        B.hPut serverH (addHeader message)
+        -- bring the file back to the start for haskell-lsp
+        hSeek recH AbsoluteSeek 0
+
+
+handlers :: Handle -> MVar () -> Handlers
+handlers serverH flag = def
+  {
+    -- Requests
+    hoverHandler                             = Just request
+  , completionHandler                        = Just request
+  , completionResolveHandler                 = Just request
+  , signatureHelpHandler                     = Just request
+  , definitionHandler                        = Just request
+  , referencesHandler                        = Just request
+  , documentHighlightHandler                 = Just request
+  , documentSymbolHandler                    = Just request
+  , workspaceSymbolHandler                   = Just request
+  , codeActionHandler                        = Just request
+  , codeLensHandler                          = Just request
+  , codeLensResolveHandler                   = Just request
+  , documentFormattingHandler                = Just request
+  , documentRangeFormattingHandler           = Just request
+  , documentTypeFormattingHandler            = Just request
+  , renameHandler                            = Just request
+  , documentLinkHandler                      = Just request
+  , documentLinkResolveHandler               = Just request
+  , executeCommandHandler                    = Just request
+    -- Notifications
+  , didChangeConfigurationParamsHandler      = Just notification
+  , didOpenTextDocumentNotificationHandler   = Just notification
+  , didChangeTextDocumentNotificationHandler = Just notification
+  , didCloseTextDocumentNotificationHandler  = Just notification
+  , didSaveTextDocumentNotificationHandler   = Just notification
+  , didChangeWatchedFilesNotificationHandler = Just notification
+  , initializedHandler                       = Just notification
+  , willSaveTextDocumentNotificationHandler  = Just notification
+  , cancelNotificationHandler                = Just notification
+  , responseHandler                          = Just notification
+  }
+ where
+  notification m = do
+    B.hPut serverH $ addHeader (encode m)
+    putStrLn "sent a notification"
+  request m = do
+    B.hPut serverH $ addHeader (encode m)
+    putStrLn "sent a request, waiting for a response"
+    takeMVar flag
+    putStrLn "got a response"
+
+addHeader :: B.ByteString -> B.ByteString
+addHeader content = B.concat
+  [ "Content-Length: "
+  , B.pack $ show $ B.length content
+  , "\r\n"
+  , "\r\n"
+  , content
+  ]
+
+getHeaders :: Handle -> IO [(String, String)]
+getHeaders h = do
+  l <- hGetLine h
+  let (name, val) = span (/= ':') l
+  if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h

diff --git a/stack.yaml b/stack.yaml
index d1bf7cc50856263f0fac6bd43317ec09c545ecc1..f85170d085e22ec03459fa8308427e4816c883d4 100644 (file)
--- a/stack.yaml
+++ b/stack.yaml
@@ -6,3 +6,8 @@ extra-deps:
   - github: Bubba/haskell-lsp-client
     commit: b7cf14eb48837a73032e867dab90db1708220c66
   - haskell-lsp-types-0.2.2.0
+  - github: Bubba/haskell-lsp
+    commit: d21ebcfbe8c2c09ac92e33fa18be0a2ce098b8bb
+  - sorted-list-0.2.1.0
+  - github: yi-editor/yi-rope
+    commit: 7867909f4f20952be051fd4252cca5bbfc80cf41