From: Luke Lau Date: Thu, 12 Jul 2018 18:56:31 +0000 (+0100) Subject: Merge branch 'master' into script-fsm X-Git-Url: http://git.lukelau.me/?a=commitdiff_plain;h=b1b104cd31ca2e90b6c1842be93b61a14d942101;hp=-c;p=lsp-test.git Merge branch 'master' into script-fsm --- b1b104cd31ca2e90b6c1842be93b61a14d942101 diff --combined haskell-lsp-test.cabal index c5d1391,860c29b..6fba8f2 --- a/haskell-lsp-test.cabal +++ b/haskell-lsp-test.cabal @@@ -1,60 -1,32 +1,63 @@@ name: haskell-lsp-test version: 0.1.0.0 - -- synopsis: + synopsis: Functional test framework for LSP servers. -- description: homepage: https://github.com/Bubba/haskell-lsp-test#readme license: BSD3 license-file: LICENSE author: Luke Lau maintainer: luke_lau@icloud.com + stability: experimental + bug-reports: https://github.com/Bubba/haskell-lsp-test/issues copyright: 2018 Luke Lau category: Testing build-type: Simple -cabal-version: >=1.10 +cabal-version: >=2.0 extra-source-files: README.md library - hs-source-dirs: src + hs-source-dirs: lib exposed-modules: Language.Haskell.LSP.Test , Language.Haskell.LSP.Test.Replay + , Language.Haskell.LSP.Test.Machine + reexported-modules: haskell-lsp:Language.Haskell.LSP.Types + , haskell-lsp:Language.Haskell.LSP.Types.Capabilities + , parser-combinators:Control.Applicative.Combinators default-language: Haskell2010 build-depends: base >= 4.7 && < 5 + , haskell-lsp-types - , haskell-lsp >= 0.3 + , haskell-lsp >= 0.4 + , haskell-lsp-test-internal + , aeson + , bytestring + , containers + , data-default + , directory + , filepath + , lens + , parser-combinators + , text + , unordered-containers + , yi-rope + - ghc-options: -W - +library haskell-lsp-test-internal + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: Language.Haskell.LSP.Test.Compat + Language.Haskell.LSP.Test.Decoding + Language.Haskell.LSP.Test.Exceptions + Language.Haskell.LSP.Test.Files + Language.Haskell.LSP.Test.Messages + Language.Haskell.LSP.Test.Parsing + Language.Haskell.LSP.Test.Script + Language.Haskell.LSP.Test.Server + Language.Haskell.LSP.Test.Session + build-depends: base + , haskell-lsp-types + , haskell-lsp >= 0.3 , aeson , ansi-terminal + , async , bytestring , conduit , conduit-parse @@@ -64,7 -36,6 +67,7 @@@ , filepath , lens , mtl + , scientific , parser-combinators , process , text @@@ -75,26 -46,16 +78,25 @@@ build-depends: Win32 else build-depends: unix - other-modules: Language.Haskell.LSP.Test.Compat - Language.Haskell.LSP.Test.Decoding - Language.Haskell.LSP.Test.Exceptions - Language.Haskell.LSP.Test.Files - Language.Haskell.LSP.Test.Messages - Language.Haskell.LSP.Test.Parsing - Language.Haskell.LSP.Test.Server - Language.Haskell.LSP.Test.Session ghc-options: -W - +executable lsp-test + hs-source-dirs: lsp-test + main-is: Main.hs + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , haskell-lsp-types - , haskell-lsp >= 0.3 ++ , haskell-lsp >= 0.4 + , haskell-lsp-test-internal + , haskell-lsp-test + , aeson + , bytestring + , directory + , filepath + , text + , unordered-containers + , scientific + test-suite tests type: exitcode-stdio-1.0 main-is: Test.hs @@@ -104,13 -65,8 +106,8 @@@ , hspec , lens , data-default - , directory + , haskell-lsp >= 0.4 , haskell-lsp-test - , haskell-lsp-test-internal - , haskell-lsp - , haskell-lsp-types - , conduit - , conduit-parse , aeson , unordered-containers , text @@@ -122,7 -78,3 +119,3 @@@ executable lsp-test-exampl default-language: Haskell2010 build-depends: base >= 4.7 && < 5 , haskell-lsp-test - , haskell-lsp-types - , lens - , text - , directory diff --combined lib/Language/Haskell/LSP/Test.hs index eda3cd2,c5090f9..c5090f9 --- a/lib/Language/Haskell/LSP/Test.hs +++ b/lib/Language/Haskell/LSP/Test.hs @@@ -39,25 -39,6 +39,6 @@@ module Language.Haskell.LSP.Tes , loggingNotification , publishDiagnosticsNotification -- * Combinators - , choice - , option - , optional - , between - , some - , many - , sepBy - , sepBy1 - , sepEndBy1 - , sepEndBy - , endBy1 - , endBy - , count - , manyTill - , skipMany - , skipSome - , skipManyTill - , skipSomeTill - , (<|>) , satisfy -- * Utilities , initializeResponse @@@ -66,19 -47,28 +47,28 @@@ , documentContents , getDocumentEdit , getDocUri + , getVersionedDoc -- ** Symbols , getDocumentSymbols -- ** Diagnostics , waitForDiagnostics + , waitForDiagnosticsSource , noDiagnostics -- ** Commands , executeCommand -- ** Code Actions , getAllCodeActions , executeCodeAction + -- ** Completions + , getCompletions + -- ** References + , getReferences + -- ** Renaming + , rename + -- ** Edits + , applyEdit ) where - import Control.Applicative import Control.Applicative.Combinators import Control.Concurrent import Control.Monad @@@ -94,6 -84,7 +84,7 @@@ import qualified Data.Map as Ma import Data.Maybe import Language.Haskell.LSP.Types hiding (id, capabilities, message) import qualified Language.Haskell.LSP.Types as LSP + import qualified Language.Haskell.LSP.Types.Capabilities as LSP import Language.Haskell.LSP.Messages import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Test.Compat @@@ -177,7 -168,7 +168,7 @@@ getDocumentEdit doc = d req <- message :: Session ApplyWorkspaceEditRequest unless (checkDocumentChanges req || checkChanges req) $ - liftIO $ throw (IncorrectApplyEditRequestException (show req)) + liftIO $ throw (IncorrectApplyEditRequest (show req)) documentContents doc where @@@ -313,19 -304,31 +304,31 @@@ getDocUri file = d let fp = rootDir context file return $ filePathToUri fp + -- | Waits for diagnostics to be published and returns them. waitForDiagnostics :: Session [Diagnostic] waitForDiagnostics = do diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification let (List diags) = diagsNot ^. params . LSP.diagnostics return diags + waitForDiagnosticsSource :: String -> Session [Diagnostic] + waitForDiagnosticsSource src = do + diags <- waitForDiagnostics + let res = filter matches diags + if null res + then waitForDiagnosticsSource src + else return res + where + matches :: Diagnostic -> Bool + matches d = d ^. source == Just (T.pack src) + -- | Expects a 'PublishDiagnosticsNotification' and throws an -- 'UnexpectedDiagnosticsException' if there are any diagnostics -- returned. noDiagnostics :: Session () noDiagnostics = do diagsNot <- message :: Session PublishDiagnosticsNotification - when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnosticsException + when (diagsNot ^. params . LSP.diagnostics /= List []) $ liftIO $ throw UnexpectedDiagnostics -- | Returns the symbols in a document. getDocumentSymbols :: TextDocumentIdentifier -> Session [SymbolInformation] @@@ -335,6 -338,9 +338,9 @@@ getDocumentSymbols doc = d let (Just (List symbols)) = mRes return symbols + -- | Returns all the code actions in a document by + -- querying the code actions at each of the current + -- diagnostics' positions. getAllCodeActions :: TextDocumentIdentifier -> Session [CommandOrCodeAction] getAllCodeActions doc = do curDiags <- fromMaybe [] . Map.lookup (doc ^. uri) . curDiagnostics <$> get @@@ -353,12 -359,17 +359,17 @@@ let Just (List cmdOrCAs) = mRes in return (acc ++ cmdOrCAs) + -- | Executes a command. executeCommand :: Command -> Session () executeCommand cmd = do let args = decode $ encode $ fromJust $ cmd ^. arguments execParams = ExecuteCommandParams (cmd ^. command) args sendRequest_ WorkspaceExecuteCommand execParams + -- | Executes a code action. + -- Matching with the specification, if a code action + -- contains both an edit and a command, the edit will + -- be applied first. executeCodeAction :: CodeAction -> Session () executeCodeAction action = do maybe (return ()) handleEdit $ action ^. edit @@@ -366,5 -377,80 +377,80 @@@ where handleEdit :: WorkspaceEdit -> Session () handleEdit e = + -- Its ok to pass in dummy parameters here as they aren't used let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams e) in updateState (ReqApplyWorkspaceEdit req) + + -- | Adds the current version to the document, as tracked by the session. + getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier + getVersionedDoc (TextDocumentIdentifier uri) = do + fs <- vfs <$> get + let ver = + case fs Map.!? uri of + Just (VirtualFile v _) -> Just v + _ -> Nothing + return (VersionedTextDocumentIdentifier uri ver) + + -- | Applys an edit to the document and returns the updated document version. + applyEdit :: TextDocumentIdentifier -> TextEdit -> Session VersionedTextDocumentIdentifier + applyEdit doc edit = do + + verDoc <- getVersionedDoc doc + + caps <- asks (capabilities . config) + + let supportsDocChanges = fromMaybe False $ do + let LSP.ClientCapabilities mWorkspace _ _ = caps + LSP.WorkspaceClientCapabilities _ mEdit _ _ _ _ <- mWorkspace + LSP.WorkspaceEditClientCapabilities mDocChanges <- mEdit + mDocChanges + + let wEdit = if supportsDocChanges + then + let docEdit = TextDocumentEdit verDoc (List [edit]) + in WorkspaceEdit Nothing (Just (List [docEdit])) + else + let changes = HashMap.singleton (doc ^. uri) (List [edit]) + in WorkspaceEdit (Just changes) Nothing + + let req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) + updateState (ReqApplyWorkspaceEdit req) + + -- version may have changed + getVersionedDoc doc + + -- | Returns the completions for the position in the document. + getCompletions :: TextDocumentIdentifier -> Position -> Session [CompletionItem] + getCompletions doc pos = do + rsp <- sendRequest TextDocumentCompletion (TextDocumentPositionParams doc pos) + + case getResponseResult rsp of + Completions (List items) -> return items + CompletionList (CompletionListType _ (List items)) -> return items + + -- | Returns the references for the position in the document. + getReferences :: TextDocumentIdentifier -- ^ The document to lookup in. + -> Position -- ^ The position to lookup. + -> Bool -- ^ Whether to include declarations as references. + -> Session [Location] -- ^ The locations of the references. + getReferences doc pos inclDecl = + let ctx = ReferenceContext inclDecl + params = ReferenceParams doc pos ctx + in fromMaybe [] . (^. result) <$> sendRequest TextDocumentReferences params + + -- ^ Renames the term at the specified position. + rename :: TextDocumentIdentifier -> Position -> String -> Session () + rename doc pos newName = do + let params = RenameParams doc pos (T.pack newName) + rsp <- sendRequest TextDocumentRename params :: Session RenameResponse + let wEdit = getResponseResult rsp + req = RequestMessage "" (IdInt 0) WorkspaceApplyEdit (ApplyWorkspaceEditParams wEdit) + updateState (ReqApplyWorkspaceEdit req) + + -- | Checks the response for errors and throws an exception if needed. + -- Returns the result if successful. + getResponseResult :: ResponseMessage a -> a + getResponseResult rsp = fromMaybe exc (rsp ^. result) + where exc = throw $ UnexpectedResponseError (rsp ^. LSP.id) + (fromJust $ rsp ^. LSP.error) + diff --combined lib/Language/Haskell/LSP/Test/Machine.hs index 7e0a78d,0000000..2f513c4 mode 100644,000000..100644 --- a/lib/Language/Haskell/LSP/Test/Machine.hs +++ b/lib/Language/Haskell/LSP/Test/Machine.hs @@@ -1,37 -1,0 +1,36 @@@ - {-# LANGUAGE OverloadedStrings #-} +module Language.Haskell.LSP.Test.Machine where + +import Control.Monad.IO.Class +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Test + +data State = State String (FromServerMessage -> Bool) [Session ()] State + | Passed + | Failed + - data Event = Timeout | Received FromServerMessage ++data Event = TimeoutEvent | Received FromServerMessage + +advance :: State -> Event -> Session State - advance _ Timeout = return Failed ++advance _ TimeoutEvent = return Failed +advance s@(State name f actions next) (Received msg) + | f msg = do + liftIO $ putStrLn name + sequence_ actions + return next + | otherwise = return s +advance s _ = return s + +mkStates [] = Passed +mkStates ((n, f, msgs):xs) = State n f msgs (mkStates xs) + +runMachine :: String -> FilePath -> [(String, FromServerMessage -> Bool, [Session ()])] -> IO Bool +runMachine cmd rootDir encodedStates = + runSession cmd rootDir $ do + let f Passed = return Passed + f s = Received <$> anyMessage >>= advance s >>= f + initState = mkStates encodedStates + res <- f initState + case res of + Passed -> return True + _ -> return False + diff --combined lib/Language/Haskell/LSP/Test/Replay.hs index b224be6,979b789..979b789 --- a/lib/Language/Haskell/LSP/Test/Replay.hs +++ b/lib/Language/Haskell/LSP/Test/Replay.hs @@@ -145,7 -145,7 +145,7 @@@ listenServer expectedMsgs reqMap reqSem then listenServer (delete msg expectedMsgs) reqMap reqSema rspSema passSema mainThreadId serverOut ctx else let remainingMsgs = takeWhile (not . isNotification) expectedMsgs ++ [head $ dropWhile isNotification expectedMsgs] - exc = ReplayOutOfOrderException msg remainingMsgs + exc = ReplayOutOfOrder msg remainingMsgs in liftIO $ throwTo mainThreadId exc where diff --combined src/Language/Haskell/LSP/Test/Parsing.hs index 88109a5,36349da..1d7f38e --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@@ -53,9 -53,8 +53,8 @@@ satisfy pred = d message :: forall a. (Typeable a, FromJSON a) => Session a message = let parser = decode . encodeMsg :: FromServerMessage -> Maybe a - in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $ do - x <- satisfy (isJust . parser) - return $ castMsg x + in named (T.pack $ show $ head $ snd $ splitTyConApp $ last $ typeRepArgs $ typeOf parser) $ + castMsg <$> satisfy (isJust . parser) -- | Matches if the message is a notification. anyNotification :: Session FromServerMessage @@@ -85,10 -84,7 +84,10 @@@ castMsg = fromMaybe (error "Failed cast -- | A version of encode that encodes FromServerMessages as if they -- weren't wrapped. encodeMsg :: FromServerMessage -> B.ByteString -encodeMsg = encode . genericToJSON (defaultOptions { sumEncoding = UntaggedValue }) +encodeMsg = encode . toJSONMsg + +toJSONMsg :: FromServerMessage -> Value +toJSONMsg = genericToJSON (defaultOptions { sumEncoding = UntaggedValue }) -- | Matches if the message is a log message notification or a show message notification/request. loggingNotification :: Session FromServerMessage