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/?p=lsp-test.git;a=commitdiff_plain;h=refs%2Fheads%2Fscript-fsm;hp=fbb260c6078a39ff071fefd6586af18715b3e6a3 Merge branch 'master' into script-fsm --- diff --git a/.gitignore b/.gitignore index 730460f..93b38a2 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,8 @@ .stack-work +dist +dist-newstyle +cabal.project.local* +.ghc.environment.* **/.DS_Store *.swp + diff --git a/README.md b/README.md index 0af386e..dd71506 100644 --- a/README.md +++ b/README.md @@ -7,8 +7,8 @@ runSession "session/root/dir" $ do skipMany notification - sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc) - - rspSymbols <- response :: DocumentSymbolsResponse - let (List symbols) = fromJust (rspSymbols ^. result) + symbols <- getDocumentSymbols doc ``` + +## Developing +To test make sure you have [haskell-ide-engine](https://github.com/haskell/haskell-ide-engine) installed. diff --git a/example/Main.hs b/example/Main.hs index cc74026..c992b8e 100644 --- a/example/Main.hs +++ b/example/Main.hs @@ -1,14 +1,19 @@ -import Language.Haskell.LSP.Test -import Language.Haskell.LSP.TH.DataTypesJSON - +import Control.Applicative.Combinators import Control.Monad.IO.Class +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types main = runSession "hie --lsp" "test/recordings/renamePass" $ do docItem <- openDoc "Desktop/simple.hs" "haskell" + -- Use your favourite favourite combinators. + skipManyTill loggingNotification (count 2 publishDiagnosticsNotification) + + -- Send requests and notifications and receive responses let params = DocumentSymbolParams docItem - _ <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse + response <- sendRequest TextDocumentDocumentSymbol params :: Session DocumentSymbolsResponse + liftIO $ print response - skipMany loggingNotification + -- Or use one of the helper functions + getDocumentSymbols docItem >>= liftIO . print - anyResponse >>= liftIO . print diff --git a/haskell-lsp-test.cabal b/haskell-lsp-test.cabal index c5d1391..6fba8f2 100644 --- a/haskell-lsp-test.cabal +++ b/haskell-lsp-test.cabal @@ -1,12 +1,14 @@ 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 @@ -18,10 +20,13 @@ library 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 @@ -35,8 +40,6 @@ library , unordered-containers , yi-rope - ghc-options: -W - library haskell-lsp-test-internal hs-source-dirs: src default-language: Haskell2010 @@ -77,14 +80,13 @@ library haskell-lsp-test-internal build-depends: unix 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 @@ -104,13 +106,8 @@ test-suite tests , 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 +119,3 @@ executable lsp-test-example default-language: Haskell2010 build-depends: base >= 4.7 && < 5 , haskell-lsp-test - , haskell-lsp-types - , lens - , text - , directory diff --git a/lib/Language/Haskell/LSP/Test.hs b/lib/Language/Haskell/LSP/Test.hs index eda3cd2..c5090f9 100644 --- a/lib/Language/Haskell/LSP/Test.hs +++ b/lib/Language/Haskell/LSP/Test.hs @@ -39,25 +39,6 @@ module Language.Haskell.LSP.Test , 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 @@ module Language.Haskell.LSP.Test , 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 @@ import qualified Data.Map as Map 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 @@ getDocumentEdit doc = do 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 @@ getDocUri file = do 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 @@ getDocumentSymbols doc = do 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 @@ getAllCodeActions doc = do 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 @@ executeCodeAction action = do 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 --git a/lib/Language/Haskell/LSP/Test/Machine.hs b/lib/Language/Haskell/LSP/Test/Machine.hs index 7e0a78d..2f513c4 100644 --- a/lib/Language/Haskell/LSP/Test/Machine.hs +++ b/lib/Language/Haskell/LSP/Test/Machine.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} module Language.Haskell.LSP.Test.Machine where import Control.Monad.IO.Class @@ -9,10 +8,10 @@ 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 diff --git a/lib/Language/Haskell/LSP/Test/Replay.hs b/lib/Language/Haskell/LSP/Test/Replay.hs index b224be6..979b789 100644 --- a/lib/Language/Haskell/LSP/Test/Replay.hs +++ b/lib/Language/Haskell/LSP/Test/Replay.hs @@ -145,7 +145,7 @@ listenServer expectedMsgs reqMap reqSema rspSema passSema mainThreadId serverOut 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 --git a/src/Language/Haskell/LSP/Test/Exceptions.hs b/src/Language/Haskell/LSP/Test/Exceptions.hs index c8ca4f9..b337f0b 100644 --- a/src/Language/Haskell/LSP/Test/Exceptions.hs +++ b/src/Language/Haskell/LSP/Test/Exceptions.hs @@ -6,29 +6,29 @@ import Language.Haskell.LSP.Types import Data.Aeson import qualified Data.ByteString.Lazy.Char8 as B -data SessionException = TimeoutException - | UnexpectedMessageException String FromServerMessage - | ReplayOutOfOrderException FromServerMessage [FromServerMessage] - | UnexpectedDiagnosticsException - | IncorrectApplyEditRequestException String +data SessionException = Timeout + | UnexpectedMessage String FromServerMessage + | ReplayOutOfOrder FromServerMessage [FromServerMessage] + | UnexpectedDiagnostics + | IncorrectApplyEditRequest String | UnexpectedResponseError LspIdRsp ResponseError deriving Eq instance Exception SessionException instance Show SessionException where - show TimeoutException = "Timed out waiting to receive a message from the server." - show (UnexpectedMessageException expected lastMsg) = + show Timeout = "Timed out waiting to receive a message from the server." + show (UnexpectedMessage expected lastMsg) = "Received an unexpected message from the server:\n" ++ "Was parsing: " ++ expected ++ "\n" ++ "Last message received: " ++ show lastMsg - show (ReplayOutOfOrderException received expected) = + show (ReplayOutOfOrder received expected) = "Replay is out of order:\n" ++ -- Print json so its a bit easier to update the session logs "Received from server:\n" ++ B.unpack (encode received) ++ "\n" ++ "Expected one of:\n" ++ unlines (map (B.unpack . encode) expected) - show UnexpectedDiagnosticsException = "Unexpectedly received diagnostics from the server." - show (IncorrectApplyEditRequestException msgStr) = "ApplyEditRequest didn't contain document, instead received:\n" + show UnexpectedDiagnostics = "Unexpectedly received diagnostics from the server." + show (IncorrectApplyEditRequest msgStr) = "ApplyEditRequest didn't contain document, instead received:\n" ++ msgStr show (UnexpectedResponseError lid e) = "Received an exepected error in a response for id " ++ show lid ++ ":\n" ++ show e diff --git a/src/Language/Haskell/LSP/Test/Parsing.hs b/src/Language/Haskell/LSP/Test/Parsing.hs index 88109a5..1d7f38e 100644 --- a/src/Language/Haskell/LSP/Test/Parsing.hs +++ b/src/Language/Haskell/LSP/Test/Parsing.hs @@ -53,9 +53,8 @@ satisfy pred = do 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 diff --git a/src/Language/Haskell/LSP/Test/Session.hs b/src/Language/Haskell/LSP/Test/Session.hs index 10f63b2..1dee298 100644 --- a/src/Language/Haskell/LSP/Test/Session.hs +++ b/src/Language/Haskell/LSP/Test/Session.hs @@ -13,6 +13,7 @@ module Language.Haskell.LSP.Test.Session , get , put , modify + , modifyM , ask , asks , sendMessage @@ -44,8 +45,9 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.HashMap.Strict as HashMap import Data.Maybe +import Data.Function import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.TH.ClientCapabilities +import Language.Haskell.LSP.Types.Capabilities import Language.Haskell.LSP.Types hiding (error) import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Test.Decoding @@ -123,6 +125,9 @@ class Monad m => HasState s m where modify :: (s -> s) -> m () modify f = get >>= put . f + modifyM :: (HasState s m, Monad m) => (s -> m s) -> m () + modifyM f = get >>= f >>= put + instance Monad m => HasState s (ParserStateReader a s r m) where get = lift State.get put = lift . State.put @@ -135,16 +140,14 @@ instance Monad m => HasState SessionState (ConduitM a b (StateT SessionState m)) type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m)) runSession :: SessionContext -> SessionState -> Session a -> IO (a, SessionState) -runSession context state session = - -- source <- sourceList <$> getChanContents (messageChan context) - runReaderT (runStateT conduit state) context +runSession context state session = runReaderT (runStateT conduit state) context where conduit = runConduit $ chanSource .| watchdog .| updateStateC .| runConduitParser (catchError session handler) handler (Unexpected "ConduitParser.empty") = do lastMsg <- fromJust . lastReceivedMessage <$> get name <- getParserName - liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg) + liftIO $ throw (UnexpectedMessage (T.unpack name) lastMsg) handler e = throw e @@ -159,7 +162,7 @@ runSession context state session = curId <- curTimeoutId <$> get case msg of ServerMessage sMsg -> yield sMsg - TimeoutMessage tId -> when (curId == tId) $ throw TimeoutException + TimeoutMessage tId -> when (curId == tId) $ throw Timeout -- | 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. @@ -205,6 +208,7 @@ updateState (NotPublishDiagnostics n) = do updateState (ReqApplyWorkspaceEdit r) = do + allChangeParams <- case r ^. params . edit . documentChanges of Just (List cs) -> do mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs @@ -215,9 +219,9 @@ updateState (ReqApplyWorkspaceEdit r) = do return $ concatMap (uncurry getChangeParams) (HashMap.toList cs) Nothing -> error "No changes!" - oldVFS <- vfs <$> get - newVFS <- liftIO $ changeFromServerVFS oldVFS r - modify (\s -> s { vfs = newVFS }) + modifyM $ \s -> do + newVFS <- liftIO $ changeFromServerVFS (vfs s) r + return $ s { vfs = newVFS } let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams mergedParams = map mergeParams groupedParams @@ -225,6 +229,18 @@ updateState (ReqApplyWorkspaceEdit r) = do -- TODO: Don't do this when replaying a session forM_ mergedParams (sendMessage . NotificationMessage "2.0" TextDocumentDidChange) + -- Update VFS to new document versions + let sortedVersions = map (sortBy (compare `on` (^. textDocument . version))) groupedParams + latestVersions = map ((^. textDocument) . last) sortedVersions + bumpedVersions = map (version . _Just +~ 1) latestVersions + + forM_ bumpedVersions $ \(VersionedTextDocumentIdentifier uri v) -> + modify $ \s -> + let oldVFS = vfs s + update (VirtualFile oldV t) = VirtualFile (fromMaybe oldV v) t + newVFS = Map.adjust update uri oldVFS + in s { vfs = newVFS } + where checkIfNeedsOpened uri = do oldVFS <- vfs <$> get ctx <- ask @@ -237,15 +253,15 @@ updateState (ReqApplyWorkspaceEdit r) = do msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item) liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg) - oldVFS <- vfs <$> get - newVFS <- liftIO $ openVFS oldVFS msg - modify (\s -> s { vfs = newVFS }) + modifyM $ \s -> do + newVFS <- liftIO $ openVFS (vfs s) msg + return $ s { vfs = newVFS } getParams (TextDocumentEdit docId (List edits)) = let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits in DidChangeTextDocumentParams docId (List changeEvents) - textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri) [0..] + textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri . Just) [0..] textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits diff --git a/stack.yaml b/stack.yaml index adf9f08..934b356 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,15 +1,7 @@ -resolver: nightly-2018-06-02 +resolver: lts-12.0 packages: - . extra-deps: - - github: Bubba/haskell-lsp-client - commit: b7cf14eb48837a73032e867dab90db1708220c66 - - github: Bubba/haskell-lsp - commit: 47176f14738451b36b061b2314a2acb05329fde4 - subdirs: - - . - - ./haskell-lsp-types - - sorted-list-0.2.1.0 - - github: yi-editor/yi-rope - commit: 7867909f4f20952be051fd4252cca5bbfc80cf41 + - haskell-lsp-0.4.0.0 + - haskell-lsp-types-0.4.0.0 diff --git a/test/Test.hs b/test/Test.hs index 90be1e2..6353e09 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -8,6 +8,7 @@ import Data.Aeson import Data.Default import qualified Data.HashMap.Strict as HM import qualified Data.Text as T +import Control.Applicative.Combinators import Control.Concurrent import Control.Monad.IO.Class import Control.Monad @@ -16,12 +17,15 @@ import GHC.Generics import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Test import Language.Haskell.LSP.Test.Replay -import Language.Haskell.LSP.TH.ClientCapabilities -import Language.Haskell.LSP.Types hiding (message, capabilities) +import Language.Haskell.LSP.Types.Capabilities +import Language.Haskell.LSP.Types as LSP hiding (capabilities, message) import System.Timeout +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +{-# ANN module ("HLint: ignore Unnecessary hiding" :: String) #-} + main = hspec $ do - describe "manual session" $ do + describe "Session" $ do it "fails a test" $ -- TODO: Catch the exception in haskell-lsp-test and provide nicer output let session = runSession "hie --lsp" "test/data/renamePass" $ do @@ -29,16 +33,13 @@ main = hspec $ do skipMany loggingNotification anyRequest in session `shouldThrow` anyException - it "can get initialize response" $ runSession "hie --lsp" "test/data/renamePass" $ do + it "initializeResponse" $ runSession "hie --lsp" "test/data/renamePass" $ do rsp <- initializeResponse liftIO $ rsp ^. result `shouldNotBe` Nothing - it "can register specific capabilities" $ do - let caps = def { _workspace = Just workspaceCaps } - workspaceCaps = def { _didChangeConfiguration = Just configCaps } - configCaps = DidChangeConfigurationClientCapabilities (Just True) - conf = def { capabilities = caps } - runSessionWithConfig conf "hie --lsp" "test/data/renamePass" $ return () + it "runSessionWithConfig" $ + runSessionWithConfig (def { capabilities = didChangeCaps }) + "hie --lsp" "test/data/renamePass" $ return () describe "withTimeout" $ do it "times out" $ @@ -85,10 +86,10 @@ main = hspec $ do getDocumentSymbols doc -- should now timeout skipManyTill anyMessage message :: Session ApplyWorkspaceEditRequest - in sesh `shouldThrow` (== TimeoutException) + in sesh `shouldThrow` (== Timeout) - describe "exceptions" $ do + describe "SessionException" $ do it "throw on time out" $ let sesh = runSessionWithConfig (def {messageTimeout = 10}) "hie --lsp" "test/data/renamePass" $ do skipMany loggingNotification @@ -104,11 +105,11 @@ main = hspec $ do describe "UnexpectedMessageException" $ do it "throws when there's an unexpected message" $ - let selector (UnexpectedMessageException "Publish diagnostics notification" (NotLogMessage _)) = True + let selector (UnexpectedMessage "Publish diagnostics notification" (NotLogMessage _)) = True selector _ = False in runSession "hie --lsp" "test/data/renamePass" publishDiagnosticsNotification `shouldThrow` selector it "provides the correct types that were expected and received" $ - let selector (UnexpectedMessageException "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True + let selector (UnexpectedMessage "ResponseMessage WorkspaceEdit" (RspDocumentSymbols _)) = True selector _ = False sesh = do doc <- openDoc "Desktop/simple.hs" "haskell" @@ -118,11 +119,11 @@ main = hspec $ do in runSession "hie --lsp" "test/data/renamePass" sesh `shouldThrow` selector - describe "replay session" $ do + describe "replaySession" $ do it "passes a test" $ replaySession "hie --lsp" "test/data/renamePass" it "fails a test" $ - let selector (ReplayOutOfOrderException _ _) = True + let selector (ReplayOutOfOrder _ _) = True selector _ = False in replaySession "hie --lsp" "test/data/renameFail" `shouldThrow` selector @@ -160,9 +161,9 @@ main = hspec $ do noDiagnostics contents <- documentContents doc - liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42" + liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n" - describe "documentEdit" $ + describe "getDocumentEdit" $ it "automatically consumes applyedit requests" $ runSession "hie --lsp" "test/data/refactor" $ do doc <- openDoc "Main.hs" "haskell" @@ -173,7 +174,7 @@ main = hspec $ do reqParams = ExecuteCommandParams "applyrefact:applyOne" (Just (List [args])) sendRequest_ WorkspaceExecuteCommand reqParams contents <- getDocumentEdit doc - liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42" + liftIO $ contents `shouldBe` "main :: IO Int\nmain = return 42\n" noDiagnostics describe "getAllCodeActions" $ @@ -202,6 +203,69 @@ main = hspec $ do mainSymbol ^. location . range `shouldBe` Range (Position 3 0) (Position 3 4) mainSymbol ^. containerName `shouldBe` Nothing + describe "applyEdit" $ do + it "increments the version" $ runSessionWithConfig (def { capabilities = docChangesCaps }) "hie --lsp" "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + VersionedTextDocumentIdentifier _ (Just oldVersion) <- getVersionedDoc doc + let edit = TextEdit (Range (Position 1 1) (Position 1 3)) "foo" + VersionedTextDocumentIdentifier _ (Just newVersion) <- applyEdit doc edit + liftIO $ newVersion `shouldBe` oldVersion + 1 + it "changes the document contents" $ runSession "hie --lsp" "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + let edit = TextEdit (Range (Position 0 0) (Position 0 2)) "foo" + applyEdit doc edit + contents <- documentContents doc + liftIO $ contents `shouldSatisfy` T.isPrefixOf "foodule" + + describe "getCompletions" $ + it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + [item] <- getCompletions doc (Position 5 5) + liftIO $ do + item ^. label `shouldBe` "interactWithUser" + item ^. kind `shouldBe` Just CiFunction + item ^. detail `shouldBe` Just "Items -> IO ()\nMain" + + describe "getReferences" $ + it "works" $ runSession "hie --lsp" "test/data/renamePass" $ do + doc <- openDoc "Desktop/simple.hs" "haskell" + let pos = Position 40 3 -- interactWithUser + uri = doc ^. LSP.uri + refs <- getReferences doc pos True + liftIO $ refs `shouldContain` map (Location uri) [ + mkRange 41 0 41 16 + , mkRange 75 6 75 22 + , mkRange 71 6 71 22 + ] + + describe "waitForDiagnosticsSource" $ + it "works" $ runSession "hie --lsp" "test/data" $ do + openDoc "Error.hs" "haskell" + [diag] <- waitForDiagnosticsSource "ghcmod" + liftIO $ do + diag ^. severity `shouldBe` Just DsError + diag ^. source `shouldBe` Just "ghcmod" + + describe "rename" $ + it "works" $ runSession "hie --lsp" "test/data" $ do + doc <- openDoc "Rename.hs" "haskell" + rename doc (Position 1 0) "bar" + documentContents doc >>= liftIO . shouldBe "main = bar\nbar = return 42\n" + +mkRange sl sc el ec = Range (Position sl sc) (Position el ec) + +didChangeCaps :: ClientCapabilities +didChangeCaps = def { _workspace = Just workspaceCaps } + where + workspaceCaps = def { _didChangeConfiguration = Just configCaps } + configCaps = DidChangeConfigurationClientCapabilities (Just True) + +docChangesCaps :: ClientCapabilities +docChangesCaps = def { _workspace = Just workspaceCaps } + where + workspaceCaps = def { _workspaceEdit = Just editCaps } + editCaps = WorkspaceEditClientCapabilities (Just True) + data ApplyOneParams = AOP { file :: Uri , start_pos :: Position diff --git a/test/data/Error.hs b/test/data/Error.hs new file mode 100644 index 0000000..79c1dd9 --- /dev/null +++ b/test/data/Error.hs @@ -0,0 +1,2 @@ +main :: IO Int +main = return "hello" diff --git a/test/data/Rename.hs b/test/data/Rename.hs new file mode 100644 index 0000000..13e4d96 --- /dev/null +++ b/test/data/Rename.hs @@ -0,0 +1,2 @@ +main = foo +foo = return 42