import Language.Haskell.LSP.Test
import Language.Haskell.LSP.TH.DataTypesJSON
-import Data.Proxy
import Control.Monad.IO.Class
main = runSession "hie --lsp" "test/recordings/renamePass" $ do
+ docItem <- openDoc "Desktop/simple.hs" "haskell"
- docItem <- getDocItem "Desktop/simple.hs" "haskell"
- docId <- TextDocumentIdentifier <$> getDocUri "Desktop/simple.hs"
-
- sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
-
- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams docId)
+ sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams docItem)
skipMany loggingNotification
, (<|>)
, satisfy
-- * Utilities
- , getInitializeResponse
+ , initializeResponse
, openDoc
- , getDocItem
, documentContents
+ , documentEdit
, getDocUri
+ , noDiagnostics
+ , documentSymbols
+ ,
) where
import Control.Applicative
import Control.Applicative.Combinators
-import Control.Monad.IO.Class
import Control.Concurrent
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Exception
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 qualified Data.HashMap.Strict as HashMap
import qualified Data.Map as Map
import Data.Maybe
import Language.Haskell.LSP.Types hiding (id, capabilities)
let file = vfs Map.! (doc ^. uri)
return $ Rope.toText $ Language.Haskell.LSP.VFS._text file
+-- | Parses an ApplyEditRequest, checks that it is for the passed document
+-- and returns the new content
+documentEdit :: TextDocumentIdentifier -> Session T.Text
+documentEdit doc = do
+ req <- request :: Session ApplyWorkspaceEditRequest
+
+ unless (checkDocumentChanges req || checkChanges req) $
+ liftIO $ throw (IncorrectApplyEditRequestException (show req))
+
+ documentContents doc
+ where
+ checkDocumentChanges :: ApplyWorkspaceEditRequest -> Bool
+ checkDocumentChanges req =
+ let changes = req ^. params . edit . documentChanges
+ maybeDocs = fmap (fmap (^. textDocument . uri)) changes
+ in case maybeDocs of
+ Just docs -> (doc ^. uri) `elem` docs
+ Nothing -> False
+ checkChanges :: ApplyWorkspaceEditRequest -> Bool
+ checkChanges req =
+ let mMap = req ^. params . edit . changes
+ in maybe False (HashMap.member (doc ^. uri)) mMap
+
-- | Sends a request to the server.
--
-- @
-- | Returns the initialize response that was received from the server.
-- The initialize requests and responses are not included the session,
-- so if you need to test it use this.
-getInitializeResponse :: Session InitializeResponse
-getInitializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
+initializeResponse :: Session InitializeResponse
+initializeResponse = initRsp <$> ask >>= (liftIO . readMVar)
-- | Opens a text document and sends a notification to the client.
openDoc :: FilePath -> String -> Session TextDocumentIdentifier
item <- getDocItem file languageId
sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams item)
TextDocumentIdentifier <$> getDocUri file
-
+ where
-- | Reads in a text document as the first version.
getDocItem :: FilePath -- ^ The path to the text document to read in.
-> String -- ^ The language ID, e.g "haskell" for .hs files.
let fp = rootDir context </> file
return $ filePathToUri fp
+-- | Expects a 'PublishDiagnosticsNotification' and throws an
+-- 'UnexpectedDiagnosticsException' if there are any diagnostics
+-- returned.
+noDiagnostics :: Session ()
+noDiagnostics = do
+ diagsNot <- notification :: Session PublishDiagnosticsNotification
+ when (diagsNot ^. params . diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException
+
+-- | Returns the symbols in a document.
+documentSymbols :: TextDocumentIdentifier -> Session DocumentSymbolsResponse
+documentSymbols doc = do
+ sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
+ response
\ No newline at end of file
data SessionException = TimeoutException
| UnexpectedMessageException String FromServerMessage
| ReplayOutOfOrderException FromServerMessage [FromServerMessage]
+ | UnexpectedDiagnosticsException
+ | IncorrectApplyEditRequestException String
instance Exception SessionException
"Replay is out of order:\n" ++
"Received from server:" ++ show received ++ "\n" ++
"Expected one of: " ++ concatMap show expected
+ show UnexpectedDiagnosticsException = "Unexpectedly received diagnostics from the server."
+ show (IncorrectApplyEditRequestException msgStr) = "ApplyEditRequest didn't contain document, instead received:\n"
+ ++ msgStr
anySessionException :: SessionException -> Bool
anySessionException = const True
\ No newline at end of file
then listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut
else if inRightOrder msg expectedMsgs
then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut
- else let expectedMsgs = takeWhile (not . isNotification) expectedMsgs
+ else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs
++ [head $ dropWhile isNotification expectedMsgs]
- exc = ReplayOutOfOrderException msg expectedMsgs
+ exc = ReplayOutOfOrderException msg remainingMsgs
in liftIO $ throwTo mainThreadId exc
where
-- | Stuff you can configure for a 'Session'.
data SessionConfig = SessionConfig
{
- capabilities :: ClientCapabilities, -- ^ Specific capabilities the client should advertise.
- timeout :: Int -- ^ Maximum time to wait for a request in seconds.
+ capabilities :: ClientCapabilities -- ^ Specific capabilities the client should advertise. Default is yes to everything.
+ , timeout :: Int -- ^ Maximum time to wait for a request in seconds. Defaults to 60.
}
instance Default SessionConfig where
- .
extra-deps:
- # - haskell-lsp
- github: Bubba/haskell-lsp-client
commit: b7cf14eb48837a73032e867dab90db1708220c66
- - github: Bubba/haskell-lsp
- commit: 3e046bf095568099dae606e1c20a92f1dc60b7b9
+ - github: alanz/haskell-lsp
+ commit: 5f60fb1cbe09e7026201577ad76fa95116008131
subdirs:
- .
- ./haskell-lsp-types
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
+
import Test.Hspec
import Data.Aeson
import Data.Default
skipMany loggingNotification
- checkNoDiagnostics
+ noDiagnostics
rspSymbols <- documentSymbols doc
anyRequest
in session `shouldThrow` anyException
it "can get initialize response" $ runSession "hie --lsp" "test/data/renamePass" $ do
- rsp <- getInitializeResponse
+ rsp <- initializeResponse
liftIO $ rsp ^. result `shouldNotBe` Nothing
it "can register specific capabilities" $ do
runSession "javascript-typescript-stdio" "test/data/javascriptPass" $ do
doc <- openDoc "test.js" "javascript"
- checkNoDiagnostics
+ noDiagnostics
rspSymbols <- documentSymbols doc
fooSymbol ^. name `shouldBe` "foo"
fooSymbol ^. kind `shouldBe` SkFunction
- describe "text document state" $
+ describe "text document VFS" $
it "sends back didChange notifications" $
runSession "hie --lsp" "test/data/refactor" $ do
doc <- openDoc "Main.hs" "haskell"
u `shouldBe` doc ^. uri
es `shouldBe` [TextEdit (Range (Position 1 0) (Position 1 18)) "main = return 42"]
- checkNoDiagnostics
+ noDiagnostics
contents <- documentContents doc
liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42"
+ describe "documentEdit" $
+ it "automatically consumes applyedit requests" $
+ runSession "hie --lsp" "test/data/refactor" $ do
+ doc <- openDoc "Main.hs" "haskell"
+
+ let args = toJSON $ AOP (doc ^. uri)
+ (Position 1 14)
+ "Redundant bracket"
+ reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args]))
+ sendRequest WorkspaceExecuteCommand reqParams
+ skipMany anyNotification
+ _ <- response :: Session ExecuteCommandResponse
+
+ contents <- documentEdit doc
+ liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42"
+ noDiagnostics
+
parsingSpec
data ApplyOneParams = AOP
, hintTitle :: String
} deriving (Generic, ToJSON)
-checkNoDiagnostics :: Session ()
-checkNoDiagnostics = do
- diagsNot <- notification :: Session PublishDiagnosticsNotification
- liftIO $ diagsNot ^. params . diagnostics `shouldBe` List []
-
-documentSymbols :: TextDocumentIdentifier -> Session DocumentSymbolsResponse
-documentSymbols doc = do
- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc)
- response
{"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":["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":"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":["1234:applyrefact:applyOne","1234:hare:demote","16026:hie:applyWorkspaceEdit","16026:hsimport:import","16026:package:add"]},"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 / opengl.git / commitdiff