From 42ce195cb3567e2fa25ca6b46eb3d0c26cd7e931 Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Wed, 30 Dec 2020 16:06:26 -0600 Subject: [PATCH 1/2] Make rename tests compile. (They can't pass since we don't have a renamer yet.) --- test/functional/Rename.hs | 37 ++++++++++++++-------------- test/testdata/{ => rename}/Rename.hs | 0 2 files changed, 19 insertions(+), 18 deletions(-) rename test/testdata/{ => rename}/Rename.hs (100%) diff --git a/test/functional/Rename.hs b/test/functional/Rename.hs index 3b503daf68..bcd9a65a62 100644 --- a/test/functional/Rename.hs +++ b/test/functional/Rename.hs @@ -1,27 +1,28 @@ {-# LANGUAGE OverloadedStrings #-} module Rename (tests) where --- import Control.Monad.IO.Class --- import Language.Haskell.LSP.Test --- import Language.Haskell.LSP.Types --- import Test.Hls.Util +import Control.Monad.IO.Class (liftIO) +import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Types +import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.ExpectedFailure (ignoreTestBecause) tests :: TestTree tests = testGroup "rename" [ - testCase "works" $ True @?= True - -- pendingWith "removed because of HaRe" - -- runSession hlsCommand fullCaps "test/testdata" $ do - -- doc <- openDoc "Rename.hs" "haskell" - -- rename doc (Position 3 1) "baz" -- foo :: Int -> Int - -- documentContents doc >>= liftIO . flip shouldBe expected - -- where - -- expected = - -- "main = do\n\ - -- \ x <- return $ baz 42\n\ - -- \ return (baz x)\n\ - -- \baz :: Int -> Int\n\ - -- \baz x = x + 1\n\ - -- \bar = (+ 1) . baz\n" + ignoreTestBecause "no symbol renaming (yet!)" $ + testCase "works" $ + runSession hlsCommand fullCaps "test/testdata/rename" $ do + doc <- openDoc "Rename.hs" "haskell" + rename doc (Position 3 1) "baz" -- foo :: Int -> Int + contents <- documentContents doc + let expected = + "main = do\n\ + \ x <- return $ baz 42\n\ + \ return (baz x)\n\ + \baz :: Int -> Int\n\ + \baz x = x + 1\n\ + \bar = (+ 1) . baz\n" + liftIO $ contents @?= expected ] diff --git a/test/testdata/Rename.hs b/test/testdata/rename/Rename.hs similarity index 100% rename from test/testdata/Rename.hs rename to test/testdata/rename/Rename.hs From 67c53fdbcb45d872d6f84f8b88dcd75073a4b33a Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Wed, 9 Dec 2020 16:29:26 -0600 Subject: [PATCH 2/2] Enable some more tests. --- test/functional/Command.hs | 13 ++--- test/functional/Diagnostic.hs | 69 ++++++++--------------- test/functional/FunctionalCodeAction.hs | 17 ++++-- test/functional/FunctionalLiquid.hs | 75 ++----------------------- test/functional/HieBios.hs | 27 +++++---- test/testdata/testdata.cabal | 7 +++ test/testdata/wErrorTest/cabal.project | 1 + test/testdata/wErrorTest/hie.yaml | 4 ++ 8 files changed, 72 insertions(+), 141 deletions(-) create mode 100644 test/testdata/wErrorTest/cabal.project create mode 100644 test/testdata/wErrorTest/hie.yaml diff --git a/test/functional/Command.hs b/test/functional/Command.hs index 4561dfea66..61a806801d 100644 --- a/test/functional/Command.hs +++ b/test/functional/Command.hs @@ -11,10 +11,7 @@ import Language.Haskell.LSP.Types.Lens as LSP import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit -import Test.Tasty.ExpectedFailure (ignoreTestBecause) - ---TODO : Response Message no longer has 4 inputs tests :: TestTree tests = testGroup "commands" [ testCase "are prefixed" $ @@ -25,13 +22,13 @@ tests = testGroup "commands" [ liftIO $ do all f cmds @? "All prefixed" not (null cmds) @? "Commands aren't empty" - , ignoreTestBecause "Broken: Plugin package doesn't exist" $ - testCase "get de-prefixed" $ + , testCase "get de-prefixed" $ runSession hlsCommand fullCaps "test/testdata/" $ do ResponseMessage _ _ (Left err) <- request WorkspaceExecuteCommand - (ExecuteCommandParams "1234:package:add" (Just (List [])) Nothing) :: Session ExecuteCommandResponse + (ExecuteCommandParams "34133:eval:evalCommand" (Just (List [])) Nothing) :: Session ExecuteCommandResponse let ResponseError _ msg _ = err - -- We expect an error message about the dud arguments, but should pickup "add" and "package" - liftIO $ (msg `T.isInfixOf` "while parsing args for add in plugin package") @? "Has error message" + -- We expect an error message about the dud arguments, but we can + -- check that we found the right plugin. + liftIO $ "while parsing args for evalCommand in plugin eval" `T.isInfixOf` msg @? "Has error message" ] diff --git a/test/functional/Diagnostic.hs b/test/functional/Diagnostic.hs index 134d7d57d5..855a729203 100644 --- a/test/functional/Diagnostic.hs +++ b/test/functional/Diagnostic.hs @@ -6,9 +6,7 @@ import Control.Applicative.Combinators import Control.Lens hiding (List) import Control.Monad.IO.Class import Data.Aeson (toJSON) -import qualified Data.Text as T import qualified Data.Default -import Ide.Logger import Ide.Plugin.Config import Language.Haskell.LSP.Test hiding (message) import Language.Haskell.LSP.Types @@ -22,72 +20,53 @@ import Test.Tasty.HUnit tests :: TestTree tests = testGroup "diagnostics providers" [ - saveTests - , triggerTests - , errorTests + basicTests + , saveTests , warningTests ] - -triggerTests :: TestTree -triggerTests = testGroup "diagnostics triggers" [ - ignoreTestBecause "Broken" $ - ignoreTestBecause "Broken" $ testCase "runs diagnostics on save" $ - runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do - logm "starting DiagnosticSpec.runs diagnostic on save" +basicTests :: TestTree +basicTests = testGroup "Diagnostics work" [ + testCase "hlint produces diagnostics" $ + runSession hlsCommand fullCaps "test/testdata/hlint" $ do doc <- openDoc "ApplyRefact2.hs" "haskell" - - diags@(reduceDiag:_) <- waitForDiagnostics - + diags <- waitForDiagnosticsFromSource doc "hlint" + reduceDiag <- liftIO $ inspectDiagnostic diags ["Eta reduce"] + redundantID <- liftIO $ inspectDiagnostic diags ["Redundant id"] liftIO $ do length diags @?= 2 reduceDiag ^. LSP.range @?= Range (Position 1 0) (Position 1 12) reduceDiag ^. LSP.severity @?= Just DsInfo - reduceDiag ^. LSP.code @?= Just (StringValue "Eta reduce") - reduceDiag ^. LSP.source @?= Just "hlint" - - diags2a <- waitForDiagnostics - - liftIO $ length diags2a @?= 2 - - sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) - - diags3@(d:_) <- waitForDiagnosticsSource "eg2" + redundantID ^. LSP.severity @?= Just DsInfo + , testCase "example plugin produces diagnostics" $ + runSession hlsCommandExamplePlugin fullCaps "test/testdata/hlint" $ do + doc <- openDoc "ApplyRefact2.hs" "haskell" + diags <- waitForDiagnosticsFromSource doc "example2" + reduceDiag <- liftIO $ inspectDiagnostic diags ["example2 diagnostic, hello world"] liftIO $ do - length diags3 @?= 1 - d ^. LSP.range @?= Range (Position 0 0) (Position 1 0) - d ^. LSP.severity @?= Nothing - d ^. LSP.code @?= Nothing - d ^. LSP.message @?= T.pack "Example plugin diagnostic, triggered byDiagnosticOnSave" - ] - -errorTests :: TestTree -errorTests = testGroup "typed hole errors" [ - ignoreTestBecause "Broken" $ testCase "is deferred" $ - runSession hlsCommand fullCaps "test/testdata" $ do - _ <- openDoc "TypedHoles.hs" "haskell" - [diag] <- waitForDiagnosticsSource "bios" - liftIO $ diag ^. LSP.severity @?= Just DsWarning + length diags @?= 1 + reduceDiag ^. LSP.range @?= Range (Position 0 0) (Position 1 0) + reduceDiag ^. LSP.severity @?= Just DsError ] warningTests :: TestTree warningTests = testGroup "Warnings are warnings" [ - ignoreTestBecause "Broken" $ testCase "Overrides -Werror" $ + testCase "Overrides -Werror" $ runSession hlsCommand fullCaps "test/testdata/wErrorTest" $ do - _ <- openDoc "src/WError.hs" "haskell" - [diag] <- waitForDiagnosticsSource "bios" + doc <- openDoc "src/WError.hs" "haskell" + [diag] <- waitForDiagnosticsFrom doc liftIO $ diag ^. LSP.severity @?= Just DsWarning ] saveTests :: TestTree saveTests = testGroup "only diagnostics on save" [ - ignoreTestBecause "Broken" $ testCase "Respects diagnosticsOnChange setting" $ + ignoreTestBecause "diagnosticsOnChange parameter is not supported right now" $ testCase "Respects diagnosticsOnChange setting" $ runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do let config = Data.Default.def { diagnosticsOnChange = False } :: Config sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) doc <- openDoc "Hover.hs" "haskell" - diags <- waitForDiagnostics + diags <- waitForDiagnosticsFrom doc liftIO $ do length diags @?= 0 @@ -97,7 +76,7 @@ saveTests = testGroup "only diagnostics on save" [ skipManyTill loggingNotification noDiagnostics sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) - diags2 <- waitForDiagnostics + diags2 <- waitForDiagnosticsFrom doc liftIO $ length diags2 @?= 1 ] diff --git a/test/functional/FunctionalCodeAction.hs b/test/functional/FunctionalCodeAction.hs index db67adb9cc..960e0bb0d1 100644 --- a/test/functional/FunctionalCodeAction.hs +++ b/test/functional/FunctionalCodeAction.hs @@ -475,15 +475,24 @@ unusedTermTests = testGroup "unused term code actions" [ doc <- openDoc "CodeActionOnly.hs" "haskell" _ <- waitForDiagnosticsFrom doc diags <- getCurrentDiagnostics doc - let params = CodeActionParams doc (Range (Position 2 10) (Position 4 0)) caContext Nothing + let params = CodeActionParams doc (Range (Position 1 0) (Position 4 0)) caContext Nothing caContext = CodeActionContext (List diags) (Just (List [CodeActionRefactorInline])) + caContextAllActions = CodeActionContext (List diags) Nothing + -- Verify that we get code actions of at least two different kinds. + ResponseMessage _ _ (Right (List allCodeActions)) + <- request TextDocumentCodeAction (params & L.context .~ caContextAllActions) + liftIO $ do + redundantId <- inspectCodeAction allCodeActions ["Redundant id"] + redundantId ^. L.kind @?= Just CodeActionQuickFix + unfoldFoo <- inspectCodeAction allCodeActions ["Unfold foo"] + unfoldFoo ^. L.kind @?= Just CodeActionRefactorInline + -- Verify that that when we set the only parameter, we only get actions + -- of the right kind. ResponseMessage _ _ (Right (List res)) <- request TextDocumentCodeAction params let cas = map fromAction res kinds = map (^. L.kind) cas liftIO $ do - -- TODO: When HaRe is back this should be uncommented - -- kinds `shouldNotSatisfy` null - not (any (Just CodeActionRefactorInline /=) kinds) @? "None not CodeActionRefactorInline" + not (null kinds) @? "We found an action of kind RefactorInline" all (Just CodeActionRefactorInline ==) kinds @? "All CodeActionRefactorInline" ] diff --git a/test/functional/FunctionalLiquid.hs b/test/functional/FunctionalLiquid.hs index 96e9862ade..8a461d5777 100644 --- a/test/functional/FunctionalLiquid.hs +++ b/test/functional/FunctionalLiquid.hs @@ -6,7 +6,6 @@ import Control.Lens hiding (List) import Control.Monad.IO.Class import Data.Aeson import Data.Default -import qualified Data.Text as T import Language.Haskell.LSP.Test hiding (message) import Language.Haskell.LSP.Types as LSP import Language.Haskell.LSP.Types.Lens as LSP hiding (contents) @@ -20,83 +19,19 @@ import Test.Tasty.HUnit tests :: TestTree tests = testGroup "liquid haskell diagnostics" [ - ignoreTestBecause "Broken" $ testCase "runs diagnostics on save, no liquid" $ - runSession hlsCommandExamplePlugin codeActionSupportCaps "test/testdata" $ do - doc <- openDoc "liquid/Evens.hs" "haskell" - - diags@(reduceDiag:_) <- waitForDiagnostics - - liftIO $ do - length diags @?= 2 - reduceDiag ^. range @?= Range (Position 5 18) (Position 5 22) - reduceDiag ^. severity @?= Just DsHint - reduceDiag ^. code @?= Just (StringValue "Use negate") - reduceDiag ^. source @?= Just "hlint" - - diags2hlint <- waitForDiagnostics - - liftIO $ length diags2hlint @?= 2 - - sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) - - diags3@(d:_) <- waitForDiagnosticsSource "eg2" - - liftIO $ do - length diags3 @?= 1 - d ^. LSP.range @?= Range (Position 0 0) (Position 1 0) - d ^. LSP.severity @?= Nothing - d ^. LSP.code @?= Nothing - d ^. LSP.message @?= T.pack "Example plugin diagnostic, triggered byDiagnosticOnSave" - - -- --------------------------------- - - , ignoreTestBecause "Broken" $ testCase "runs diagnostics on save, with liquid haskell" $ + ignoreTestBecause "no liquid haskell" + $ testCase "liquid haskell generates diagnostics" $ runSession hlsCommand codeActionSupportCaps "test/testdata" $ do - -- runSessionWithConfig logConfig hlsCommand codeActionSupportCaps "test/testdata" $ do doc <- openDoc "liquid/Evens.hs" "haskell" - diags@(reduceDiag:_) <- waitForDiagnostics - - -- liftIO $ show diags @?= "" - - liftIO $ do - length diags @?= 2 - reduceDiag ^. range @?= Range (Position 5 18) (Position 5 22) - reduceDiag ^. severity @?= Just DsHint - reduceDiag ^. code @?= Just (StringValue "Use negate") - reduceDiag ^. source @?= Just "hlint" - - -- Enable liquid haskell plugin and disable hlint let config = def { liquidOn = True, hlintOn = False } sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) - -- docItem <- getDocItem file languageId - sendNotification TextDocumentDidSave (DidSaveTextDocumentParams doc) - -- TODO: what does that test? - -- TODO: whether hlint is really disbabled? - -- TODO: @fendor, document or remove - -- diags2hlint <- waitForDiagnostics - -- -- liftIO $ show diags2hlint @?= "" - - -- -- We turned hlint diagnostics off - -- liftIO $ length diags2hlint @?= 0 - -- diags2liquid <- waitForDiagnostics - -- liftIO $ length diags2liquid @?= 0 - -- liftIO $ show diags2liquid @?= "" - diags3@(d:_) <- waitForDiagnosticsSource "liquid" - -- liftIO $ show diags3 @?= "" + diags <- waitForDiagnosticsFromSource doc "liquid" + d <- liftIO $ inspectDiagnostic diags ["Liquid Type Mismatch"] liftIO $ do - length diags3 @?= 1 + length diags @?= 1 d ^. range @?= Range (Position 8 0) (Position 8 11) d ^. severity @?= Just DsError d ^. code @?= Nothing - d ^. source @?= Just "liquid" - (d ^. message) `T.isPrefixOf` - ("Error: Liquid Type Mismatch\n" <> - " Inferred type\n" <> - " VV : {v : GHC.Types.Int | v == 7}\n" <> - " \n" <> - " not a subtype of Required type\n" <> - " VV : {VV : GHC.Types.Int | VV mod 2 == 0}\n ") - @? "Contains error message" ] diff --git a/test/functional/HieBios.hs b/test/functional/HieBios.hs index 2d04edc403..bda0c552a4 100644 --- a/test/functional/HieBios.hs +++ b/test/functional/HieBios.hs @@ -1,36 +1,35 @@ {-# LANGUAGE OverloadedStrings #-} module HieBios (tests) where -import Control.Applicative.Combinators +import Control.Lens ((^.)) +import Control.Monad.IO.Class import qualified Data.Text as T import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types -import Language.Haskell.LSP.Messages +import qualified Language.Haskell.LSP.Types.Lens as L import System.FilePath (()) import Test.Hls.Util import Test.Tasty -import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit tests :: TestTree tests = testGroup "hie-bios" [ - ignoreTestBecause "Broken" $ testCase "loads modules inside main-is" $ do + testCase "loads modules inside main-is" $ do writeFile (hieBiosErrorPath "hie.yaml") "" runSession hlsCommand fullCaps "test/testdata/hieBiosMainIs" $ do - _ <- openDoc "Main.hs" "haskell" - _ <- count 2 waitForDiagnostics - return () + doc <- openDoc "Main.hs" "haskell" + Just mainHoverText <- getHover doc (Position 3 1) + let (HoverContents (MarkupContent _ x)) = mainHoverText ^. L.contents + liftIO $ "main :: IO ()" `T.isInfixOf` x + @? "found hover text for main" - , ignoreTestBecause "Broken" $ testCase "reports errors in hie.yaml" $ do + , testCase "reports errors in hie.yaml" $ do writeFile (hieBiosErrorPath "hie.yaml") "" runSession hlsCommand fullCaps hieBiosErrorPath $ do _ <- openDoc "Foo.hs" "haskell" - _ <- skipManyTill loggingNotification (satisfy isMessage) - return () + (diag:_) <- waitForDiagnostics + liftIO $ "Expected a cradle: key containing the preferences" `T.isInfixOf` (diag ^. L.message) + @? "Error reported" ] where hieBiosErrorPath = "test/testdata/hieBiosError" - - isMessage (NotShowMessage (NotificationMessage _ _ (ShowMessageParams MtError s))) = - "Couldn't parse hie.yaml" `T.isInfixOf` s - isMessage _ = False diff --git a/test/testdata/testdata.cabal b/test/testdata/testdata.cabal index 76b2bdb95f..7f08905fe0 100644 --- a/test/testdata/testdata.cabal +++ b/test/testdata/testdata.cabal @@ -8,6 +8,13 @@ executable codeactionrename main-is: CodeActionRename.hs default-language: Haskell2010 +executable codeactiononly + build-depends: base + main-is: CodeActionOnly.hs + default-language: Haskell2010 + + + executable hover build-depends: base main-is: Hover.hs diff --git a/test/testdata/wErrorTest/cabal.project b/test/testdata/wErrorTest/cabal.project new file mode 100644 index 0000000000..52db9d1bc4 --- /dev/null +++ b/test/testdata/wErrorTest/cabal.project @@ -0,0 +1 @@ +packages: test.cabal diff --git a/test/testdata/wErrorTest/hie.yaml b/test/testdata/wErrorTest/hie.yaml new file mode 100644 index 0000000000..aa4b2f058f --- /dev/null +++ b/test/testdata/wErrorTest/hie.yaml @@ -0,0 +1,4 @@ +cradle: + cabal: + - path: "src" + component: "lib:test"