, lens
, parser-combinators
, process
+ , random
, text
, transformers
+ , uuid
, unordered-containers
if os(windows)
build-depends: win32
other-modules: Language.Haskell.LSP.Test.Compat
Language.Haskell.LSP.Test.Decoding
Language.Haskell.LSP.Test.Files
- Language.Haskell.LSP.Test.Parsing
Language.Haskell.LSP.Test.Messages
+ Language.Haskell.LSP.Test.Parsing
+ Language.Haskell.LSP.Test.Server
+ Language.Haskell.LSP.Test.Session
ghc-options: -W
test-suite tests
(
-- * Sessions
runSession
- , runSessionWithHandler
+ , runSessionWithHandles
, Session
-- * Sending
, sendRequest
import Control.Monad
import Control.Monad.IO.Class
import Control.Concurrent
-import Control.Lens hiding ((.=))
+import Control.Lens hiding ((.=), List)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Default
-import System.Process
+import Data.Foldable
+import qualified Data.HashMap.Strict as HashMap
+import Data.List
import Language.Haskell.LSP.Types
import qualified Language.Haskell.LSP.Types as LSP (error, id)
+import Language.Haskell.LSP.Messages
+import Language.Haskell.LSP.VFS
import Language.Haskell.LSP.Test.Compat
+import Language.Haskell.LSP.Test.Decoding
+import Language.Haskell.LSP.Test.Parsing
+import Language.Haskell.LSP.Test.Session
+import Language.Haskell.LSP.Test.Server
import System.IO
import System.Directory
import System.FilePath
-import Language.Haskell.LSP.Test.Decoding
-import Language.Haskell.LSP.Test.Parsing
-- | Starts a new session.
runSession :: String -- ^ The command to run the server.
def
(Just TraceOff)
- runSessionWithHandler listenServer serverExe rootDir $ do
+ withServer serverExe $ \serverIn serverOut _ -> runSessionWithHandles serverIn serverOut listenServer rootDir $ do
-- Wrap the session around initialize and shutdown calls
sendRequest Initialize initializeParams
initRspVar <- initRsp <$> ask
liftIO $ putMVar initRspVar initRspMsg
-
sendNotification Initialized InitializedParams
-- Run the actual test
return result
--- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
--- It also does not automatically send initialize and exit messages.
-runSessionWithHandler :: (Handle -> Session ())
- -> String
- -> FilePath
- -> Session a
- -> IO a
-runSessionWithHandler serverHandler serverExe rootDir session = do
- absRootDir <- canonicalizePath rootDir
-
- let createProc = (shell serverExe) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
- (Just serverIn, Just serverOut, _, serverProc) <- createProcess createProc
-
- hSetBuffering serverIn NoBuffering
- hSetBuffering serverOut NoBuffering
-
- reqMap <- newMVar newRequestMap
- messageChan <- newChan
- meaninglessChan <- newChan
- initRsp <- newEmptyMVar
-
- let context = SessionContext serverIn absRootDir messageChan reqMap initRsp
- initState = SessionState (IdInt 9)
-
- threadId <- forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
- (result, _) <- runSession' messageChan context initState session
-
- terminateProcess serverProc
- killThread threadId
-
- return result
-
-- | Listens to the server output, makes sure it matches the record and
-- signals any semaphores
listenServer :: Handle -> Session ()
context <- ask
reqMap <- liftIO $ readMVar $ requestMap context
- liftIO $ writeChan (messageChan context) $ decodeFromServerMsg reqMap msgBytes
+ let msg = decodeFromServerMsg reqMap msgBytes
+ processTextChanges msg
+ liftIO $ writeChan (messageChan context) msg
listenServer serverOut
+processTextChanges :: FromServerMessage -> Session ()
+processTextChanges (ReqApplyWorkspaceEdit r) = do
+ List changeParams <- case r ^. params . edit . documentChanges of
+ Just cs -> mapM applyTextDocumentEdit cs
+ Nothing -> case r ^. params . edit . changes of
+ Just cs -> mapM (uncurry applyTextEdit) (List (HashMap.toList cs))
+ Nothing -> return (List [])
+
+ let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) changeParams
+ mergedParams = map mergeParams groupedParams
+
+ forM_ mergedParams (sendNotification TextDocumentDidChange)
+
+ where applyTextDocumentEdit (TextDocumentEdit docId (List edits)) = do
+ oldVFS <- vfs <$> get
+ let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
+ params = DidChangeTextDocumentParams docId (List changeEvents)
+ newVFS <- liftIO $ changeVFS oldVFS (fmClientDidChangeTextDocumentNotification params)
+ modify (\s -> s { vfs = newVFS })
+ liftIO $ print newVFS
+ return params
+
+ applyTextEdit uri edits = applyTextDocumentEdit (TextDocumentEdit (VersionedTextDocumentIdentifier uri 0) edits)
+
+ mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
+ mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
+ in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
+processTextChanges _ = return ()
+
-- | Sends a request to the server.
--
-- @
module Language.Haskell.LSP.Test.Parsing where
import Control.Applicative
-import Control.Concurrent.Chan
-import Control.Concurrent.MVar
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Reader
-import Control.Monad.Trans.State
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as B
-import Data.Conduit hiding (await)
import Data.Conduit.Parser
import Data.Maybe
import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.Types hiding (error)
-import Language.Haskell.LSP.Test.Compat
-import Language.Haskell.LSP.Test.Decoding
import Language.Haskell.LSP.Test.Messages
-import System.IO
-
-data SessionContext = SessionContext
- {
- serverIn :: Handle,
- rootDir :: FilePath,
- messageChan :: Chan FromServerMessage,
- requestMap :: MVar RequestMap,
- initRsp :: MVar InitializeResponse
- }
-
-newtype SessionState = SessionState
- {
- curReqId :: LspId
- }
-
-type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
-
--- | A session representing one instance of launching and connecting to a server.
---
--- You can send and receive messages to the server within 'Session' via 'getMessage',
--- 'sendRequest' and 'sendNotification'.
---
--- @
--- runSession \"path\/to\/root\/dir\" $ do
--- docItem <- getDocItem "Desktop/simple.hs" "haskell"
--- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
--- diagnostics <- getMessage :: Session PublishDiagnosticsNotification
--- @
-type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
-- | Matches if the message is a notification.
anyNotification :: Monad m => ConduitParser FromServerMessage m FromServerMessage
then return x
else empty
-runSession' :: Chan FromServerMessage -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
-runSession' chan context state session = runReaderT (runStateT conduit state) context
- where conduit = runConduit $ chanSource chan .| runConduitParser session
-
-get :: Monad m => ParserStateReader a s r m s
-get = lift Control.Monad.Trans.State.get
-
-put :: Monad m => s -> ParserStateReader a s r m ()
-put = lift . Control.Monad.Trans.State.put
-
-modify :: Monad m => (s -> s) -> ParserStateReader a s r m ()
-modify = lift . Control.Monad.Trans.State.modify
-
-ask :: Monad m => ParserStateReader a s r m r
-ask = lift $ lift Control.Monad.Trans.Reader.ask
import Prelude hiding (id)
import Control.Concurrent
+import Control.Exception
import Control.Monad.IO.Class
import qualified Data.ByteString.Lazy.Char8 as B
+import qualified Data.Text as T
+import Data.UUID
import Language.Haskell.LSP.Capture
import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.Types hiding (error)
import Data.Aeson
import Data.List
import Data.Maybe
-import Control.Lens
+import Control.Lens hiding (List)
import Control.Monad
import System.IO
import System.FilePath
+import System.Random
import Language.Haskell.LSP.Test
import Language.Haskell.LSP.Test.Files
import Language.Haskell.LSP.Test.Decoding
import Language.Haskell.LSP.Test.Messages
+import Language.Haskell.LSP.Test.Server
-- | Replays a captured client output and
-- decode session
let unswappedEvents = map (fromJust . decode) entries
- events <- swapFiles sessionDir unswappedEvents
+ withServer serverExe $ \serverIn serverOut pid -> do
+
+ events <- swapUUIDs pid <$> swapFiles sessionDir unswappedEvents
let clientEvents = filter isClientMsg events
serverEvents = filter isServerMsg events
passVar <- newEmptyMVar :: IO (MVar Bool)
threadId <- forkIO $
- runSessionWithHandler (listenServer serverMsgs requestMap reqSema rspSema passVar)
- serverExe
+ runSessionWithHandles serverIn
+ serverOut
+ (listenServer serverMsgs requestMap reqSema rspSema passVar)
sessionDir
(sendMessages clientMsgs reqSema rspSema)
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 handler :: IOException -> IO B.ByteString
+ handler _ = putMVar passVar False >> return B.empty
+
+ msgBytes <- liftIO $ catch (getNextMessage serverOut) handler
let msg = decodeFromServerMsg reqMap msgBytes
handleServerMessage request response notification msg
shouldSkip (NotShowMessage _) = True
shouldSkip (ReqShowMessage _) = True
shouldSkip _ = False
+
+-- | Swaps out the expected UUIDs to match the current process ID
+swapUUIDs :: Int -> [Event] -> [Event]
+swapUUIDs _ [] = []
+swapUUIDs pid (FromServer t (RspInitialize rsp):xs) = FromServer t (RspInitialize swapped):swapUUIDs pid xs
+ where swapped = case newCommands of
+ Just cmds -> result . _Just . capabilities . executeCommandProvider . _Just . commands .~ cmds $ rsp
+ Nothing -> rsp
+ oldCommands = rsp ^? result . _Just . capabilities . executeCommandProvider . _Just . commands
+ newCommands = fmap (fmap swap) oldCommands
+ swap cmd
+ | isUuid cmd = T.append uuid $ T.dropWhile (/= ':') cmd
+ | otherwise = cmd
+ uuid = toText $ fst $ random $ mkStdGen pid
+ isUuid = isJust . fromText . T.takeWhile (/= ':')
+swapUUIDs pid (x:xs) = x:swapUUIDs pid xs
\ No newline at end of file
--- /dev/null
+module Language.Haskell.LSP.Test.Server where
+
+import Control.Concurrent
+import Control.Monad
+import Data.Maybe
+import System.IO
+import System.Process
+
+withServer :: String -> (Handle -> Handle -> Int -> IO a) -> IO a
+withServer serverExe f = do
+ let createProc = (shell serverExe) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
+ (Just serverIn, Just serverOut, Just serverErr, serverProc) <- createProcess createProc
+
+ -- Need to continuously consume to stderr else it gets blocked
+ -- Can't pass NoStream either to std_err
+ hSetBuffering serverErr NoBuffering
+ errSinkThread <- forkIO $ forever $ hGetLine serverErr
+
+ pid <- fromIntegral . fromJust <$> getPid serverProc
+
+ result <- f serverIn serverOut pid
+
+ killThread errSinkThread
+ terminateProcess serverProc
+ return result
\ No newline at end of file
--- /dev/null
+module Language.Haskell.LSP.Test.Session where
+
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.State
+import Data.Conduit
+import Data.Conduit.Parser
+import Language.Haskell.LSP.Messages
+import Language.Haskell.LSP.Types
+import Language.Haskell.LSP.VFS
+import Language.Haskell.LSP.Test.Compat
+import Language.Haskell.LSP.Test.Decoding
+import System.Directory
+import System.IO
+
+data SessionContext = SessionContext
+ {
+ serverIn :: Handle
+ , rootDir :: FilePath
+ , messageChan :: Chan FromServerMessage
+ , requestMap :: MVar RequestMap
+ , initRsp :: MVar InitializeResponse
+ }
+
+data SessionState = SessionState
+ {
+ curReqId :: LspId
+ , vfs :: VFS
+ }
+
+type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
+
+-- | A session representing one instance of launching and connecting to a server.
+--
+-- You can send and receive messages to the server within 'Session' via 'getMessage',
+-- 'sendRequest' and 'sendNotification'.
+--
+-- @
+-- runSession \"path\/to\/root\/dir\" $ do
+-- docItem <- getDocItem "Desktop/simple.hs" "haskell"
+-- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
+-- diagnostics <- getMessage :: Session PublishDiagnosticsNotification
+-- @
+type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
+
+
+runSession' :: Chan FromServerMessage -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
+runSession' chan context state session = runReaderT (runStateT conduit state) context
+ where conduit = runConduit $ chanSource chan .| runConduitParser session
+
+get :: Monad m => ParserStateReader a s r m s
+get = lift Control.Monad.Trans.State.get
+
+put :: Monad m => s -> ParserStateReader a s r m ()
+put = lift . Control.Monad.Trans.State.put
+
+modify :: Monad m => (s -> s) -> ParserStateReader a s r m ()
+modify = lift . Control.Monad.Trans.State.modify
+
+ask :: Monad m => ParserStateReader a s r m r
+ask = lift $ lift Control.Monad.Trans.Reader.ask
+
+
+
+-- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
+-- It also does not automatically send initialize and exit messages.
+runSessionWithHandles :: Handle -- ^ Server in
+ -> Handle -- ^ Server out
+ -> (Handle -> Session ()) -- ^ Server listener
+ -> FilePath
+ -> Session a
+ -> IO a
+runSessionWithHandles serverIn serverOut serverHandler rootDir session = do
+ absRootDir <- canonicalizePath rootDir
+
+ hSetBuffering serverIn NoBuffering
+ hSetBuffering serverOut NoBuffering
+
+ reqMap <- newMVar newRequestMap
+ messageChan <- newChan
+ meaninglessChan <- newChan
+ initRsp <- newEmptyMVar
+
+ let context = SessionContext serverIn absRootDir messageChan reqMap initRsp
+ initState = SessionState (IdInt 9) mempty
+
+ threadId <- forkIO $ void $ runSession' meaninglessChan context initState (serverHandler serverOut)
+ (result, _) <- runSession' messageChan context initState session
+
+ killThread threadId
+
+ return result
\ No newline at end of file
{"tag":"FromClient","contents":["2018-06-03T04:08:38.856591Z",{"tag":"ReqInitialize","contents":{"jsonrpc":"2.0","params":{"rootUri":"file:///Users/luke","processId":7558,"rootPath":"/Users/luke","capabilities":{"textDocument":{"completion":{"completionItem":{"snippetSupport":false}}}},"trace":"off"},"method":"initialize","id":9}}]}
-{"tag":"FromServer","contents":["2018-06-03T04:08:38.873087Z",{"tag":"RspInitialize","contents":{"result":{"capabilities":{"textDocumentSync":{"openClose":true,"change":2,"willSave":false,"willSaveWaitUntil":false,"save":{"includeText":false}},"documentRangeFormattingProvider":true,"documentHighlightProvider":true,"executeCommandProvider":{"commands":["applyrefact:applyOne","hare:demote"]},"renameProvider":true,"definitionProvider":true,"hoverProvider":true,"codeActionProvider":true,"completionProvider":{"triggerCharacters":["."],"resolveProvider":true},"documentSymbolProvider":true,"documentFormattingProvider":true,"referencesProvider":true}},"jsonrpc":"2.0","id":9}}]}
+{"tag":"FromServer","contents":["2018-06-03T04:08:38.873087Z",{"tag":"RspInitialize","contents":{"result":{"capabilities":{"textDocumentSync":{"openClose":true,"change":2,"willSave":false,"willSaveWaitUntil":false,"save":{"includeText":false}},"documentRangeFormattingProvider":true,"documentHighlightProvider":true,"executeCommandProvider":{"commands":["57b3244d-e5fe-47fe-9ca8-f4b15f444541:applyrefact:applyOne","57b3244d-e5fe-47fe-9ca8-f4b15f444541:hare:demote"]},"renameProvider":true,"definitionProvider":true,"hoverProvider":true,"codeActionProvider":true,"completionProvider":{"triggerCharacters":["."],"resolveProvider":true},"documentSymbolProvider":true,"documentFormattingProvider":true,"referencesProvider":true}},"jsonrpc":"2.0","id":9}}]}
{"tag":"FromClient","contents":["2018-06-03T04:08:39.325465Z",{"tag":"NotInitialized","contents":{"jsonrpc":"2.0","params":{},"method":"initialized"}}]}
{"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"}}]}
projects / lsp-test.git / commitdiff