{-# LANGUAGE CPP #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
module Deferred(tests) where
import Control.Applicative.Combinators
import Control.Monad.IO.Class
import Control.Lens hiding (List)
-- import Control.Monad
-- import Data.Maybe
import Language.LSP.Test
import Language.LSP.Types
import Language.LSP.Types.Lens hiding (id, message)
-- import qualified Language.LSP.Types.Lens as LSP
import Test.Hls.Util
import Test.Tasty
import Test.Tasty.ExpectedFailure (ignoreTestBecause)
import Test.Tasty.HUnit
tests :: TestTree
tests = testGroup "deferred responses" [
--TODO: DOes not compile
-- testCase "do not affect hover requests" $ runSession hlsCommand 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 @?= Nothing
-- liftIO $ hoverRsp ^. LSP.id @?= responseId id1
-- id2 <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing)
-- symbolsRsp <- skipManyTill anyNotification message :: Session DocumentSymbolsResponse
-- liftIO $ symbolsRsp ^. LSP.id @?= responseId id2
-- id3 <- sendRequest TextDocumentHover (TextDocumentPositionParams doc (Position 4 2) Nothing)
-- hoverRsp2 <- skipManyTill anyNotification message :: Session HoverResponse
-- liftIO $ hoverRsp2 ^. LSP.id @?= 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 @?= [ 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
-- }
-- ]
testCase "instantly respond to failed modules with no cache" $ runSession hlsCommand fullCaps "test/testdata" $ do
doc <- openDoc "FuncTestFail.hs" "haskell"
defs <- getDefinitions doc (Position 1 11)
liftIO $ defs @?= InR []
-- TODO: the benefits of caching parsed modules is doubted.
-- TODO: add issue link
-- , testCase "respond to untypecheckable modules with parsed module cache" $
-- runSession hlsCommand fullCaps "test/testdata" $ do
-- doc <- openDoc "FuncTestFail.hs" "haskell"
-- (Left (sym:_)) <- getDocumentSymbols doc
-- liftIO $ sym ^. name @?= "main"
-- TODO does not compile
-- , testCase "returns hints as diagnostics" $ runSession hlsCommand 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 @?= (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 @?= 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 @?= WorkspaceEdit
-- Nothing
-- (Just expectedTextDocEdits)
-- , multiServerTests
, multiMainTests
]
--TODO: Does not compile
-- multiServerTests :: TestTree
-- multiServerTests = testGroup "multi-server setup" [
-- testCase "doesn't have clashing commands on two servers" $ do
-- let getCommands = runSession hlsCommand 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)
-- ]
multiMainTests :: TestTree
multiMainTests = testGroup "multiple main modules" [
ignoreTestBecause "Broken: Unexpected ConduitParser.empty" $
testCase "Can load one file at a time, when more than one Main module exists"
$ runSession hlsCommand fullCaps "test/testdata" $ do
_doc <- openDoc "ApplyRefact2.hs" "haskell"
_diagsRspHlint <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics)
diagsRspGhc <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics)
let (List diags) = diagsRspGhc ^. params . diagnostics
liftIO $ length diags @?= 2
_doc2 <- openDoc "HaReRename.hs" "haskell"
_diagsRspHlint2 <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics)
-- errMsg <- skipManyTill anyNotification notification :: Session ShowMessageNotification
diagsRsp2 <- skipManyTill anyNotification (message STextDocumentPublishDiagnostics)
let (List diags2) = diagsRsp2 ^. params . diagnostics
liftIO $ show diags2 @?= "[]"
]