{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} module DeferredSpec where import Control.Applicative.Combinators import Control.Monad.IO.Class import Control.Lens hiding (List) import Control.Monad -- import Data.Aeson -- import qualified Data.HashMap.Strict as H import Data.Maybe import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Lens hiding (id, message) import qualified Language.Haskell.LSP.Types.Lens as LSP import Test.Hspec import System.Directory import System.FilePath import TestUtils spec :: Spec spec = do describe "deferred responses" $ do it "do not affect hover requests" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "FuncTest.hs" "haskell" id1 <- sendRequest TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing) skipMany anyNotification hoverRsp <- message :: Session HoverResponse liftIO $ hoverRsp ^? result . _Just . _Just . contents `shouldBe` Nothing liftIO $ hoverRsp ^. LSP.id `shouldBe` responseId id1 id2 <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) symbolsRsp <- skipManyTill anyNotification message :: Session DocumentSymbolsResponse liftIO $ symbolsRsp ^. LSP.id `shouldBe` responseId id2 id3 <- sendRequest TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing) hoverRsp2 <- skipManyTill anyNotification message :: Session HoverResponse liftIO $ hoverRsp2 ^. LSP.id `shouldBe` responseId id3 let contents2 = hoverRsp2 ^? result . _Just . _Just . contents liftIO $ contents2 `shouldNotSatisfy` null -- Now that we have cache the following request should be instant let highlightParams = TextDocumentPositionParams doc (Position 7 0) Nothing highlightRsp <- request TextDocumentDocumentHighlight highlightParams let (Just (List locations)) = highlightRsp ^. result liftIO $ locations `shouldBe` [ DocumentHighlight { _range = Range { _start = Position {_line = 7, _character = 0} , _end = Position {_line = 7, _character = 2} } , _kind = Just HkWrite } , DocumentHighlight { _range = Range { _start = Position {_line = 7, _character = 0} , _end = Position {_line = 7, _character = 2} } , _kind = Just HkWrite } , DocumentHighlight { _range = Range { _start = Position {_line = 5, _character = 6} , _end = Position {_line = 5, _character = 8} } , _kind = Just HkRead } , DocumentHighlight { _range = Range { _start = Position {_line = 7, _character = 0} , _end = Position {_line = 7, _character = 2} } , _kind = Just HkWrite } , DocumentHighlight { _range = Range { _start = Position {_line = 7, _character = 0} , _end = Position {_line = 7, _character = 2} } , _kind = Just HkWrite } , DocumentHighlight { _range = Range { _start = Position {_line = 5, _character = 6} , _end = Position {_line = 5, _character = 8} } , _kind = Just HkRead } ] -- ----------------------------------- it "instantly respond to failed modules with no cache" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "FuncTestFail.hs" "haskell" defs <- getDefinitions doc (Position 1 11) liftIO $ defs `shouldBe` [] -- TODO: the benefits of caching parsed modules is doubted. -- TOOD: add issue link -- it "respond to untypecheckable modules with parsed module cache" $ -- runSession hieCommand fullCaps "test/testdata" $ do -- doc <- openDoc "FuncTestFail.hs" "haskell" -- (Left (sym:_)) <- getDocumentSymbols doc -- liftIO $ sym ^. name `shouldBe` "main" -- ----------------------------------- it "returns hints as diagnostics" $ runSession hieCommand fullCaps "test/testdata" $ do _ <- openDoc "FuncTest.hs" "haskell" cwd <- liftIO getCurrentDirectory let testUri = filePathToUri $ cwd "test/testdata/FuncTest.hs" diags <- skipManyTill loggingNotification publishDiagnosticsNotification liftIO $ diags ^? params `shouldBe` (Just $ PublishDiagnosticsParams { _uri = testUri , _diagnostics = List [ Diagnostic (Range (Position 9 6) (Position 10 18)) (Just DsInfo) (Just (StringValue "Redundant do")) (Just "hlint") "Redundant do\nFound:\n do putStrLn \"hello\"\nWhy not:\n putStrLn \"hello\"\n" Nothing ] } ) -- let args' = H.fromList [("pos", toJSON (Position 7 0)), ("file", toJSON testUri)] -- args = List [Object args'] -- -- executeRsp <- request WorkspaceExecuteCommand (ExecuteCommandParams "hare:demote" (Just args) Nothing) -- liftIO $ executeRsp ^. result `shouldBe` Just (Object H.empty) -- editReq <- message :: Session ApplyWorkspaceEditRequest -- let expectedTextEdits = List [TextEdit (Range (Position 6 0) (Position 7 6)) " where\n bb = 5"] -- expectedTextDocEdits = List [TextDocumentEdit (VersionedTextDocumentIdentifier testUri (Just 0)) expectedTextEdits] -- liftIO $ editReq ^. params . edit `shouldBe` WorkspaceEdit -- Nothing -- (Just expectedTextDocEdits) -- ----------------------------------- describe "multi-server setup" $ it "doesn't have clashing commands on two servers" $ do let getCommands = runSession hieCommand fullCaps "test/testdata" $ do rsp <- initializeResponse let uuids = rsp ^? result . _Just . capabilities . executeCommandProvider . _Just . commands return $ fromJust uuids List uuids1 <- getCommands List uuids2 <- getCommands liftIO $ forM_ (zip uuids1 uuids2) (uncurry shouldNotBe) -- ----------------------------------- describe "multiple main modules" $ it "Can load one file at a time, when more than one Main module exists" -- $ runSession hieCommand fullCaps "test/testdata" $ do $ runSession hieCommand fullCaps "test/testdata" $ do _doc <- openDoc "ApplyRefact2.hs" "haskell" _diagsRspHlint <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification diagsRspGhc <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification let (List diags) = diagsRspGhc ^. params . diagnostics liftIO $ length diags `shouldBe` 2 _doc2 <- openDoc "HaReRename.hs" "haskell" _diagsRspHlint2 <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification -- errMsg <- skipManyTill anyNotification notification :: Session ShowMessageNotification diagsRsp2 <- skipManyTill anyNotification message :: Session PublishDiagnosticsNotification let (List diags2) = diagsRsp2 ^. params . diagnostics liftIO $ show diags2 `shouldBe` "[]"