From cf3f6fa63d952c083363a4664be68838d5497283 Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Sun, 20 Dec 2020 11:05:13 -0600 Subject: [PATCH 1/5] Add final newline. --- test/testdata/gototest/src/Lib.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/testdata/gototest/src/Lib.hs b/test/testdata/gototest/src/Lib.hs index 2603a7474c..5698c76832 100644 --- a/test/testdata/gototest/src/Lib.hs +++ b/test/testdata/gototest/src/Lib.hs @@ -37,4 +37,4 @@ typEnuId enu = enu data Parameter a = Parameter a parameterId :: Parameter a -> Parameter a -parameterId pid = pid \ No newline at end of file +parameterId pid = pid From 5fc4966c210661a6e33d14f9e6cb14061182cc66 Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Sun, 20 Dec 2020 11:18:03 -0600 Subject: [PATCH 2/5] Enable getTypeDefinitions tests. --- test/functional/TypeDefinition.hs | 36 +++++++++++++++++++------------ 1 file changed, 22 insertions(+), 14 deletions(-) diff --git a/test/functional/TypeDefinition.hs b/test/functional/TypeDefinition.hs index afa224f640..0fb8af516b 100644 --- a/test/functional/TypeDefinition.hs +++ b/test/functional/TypeDefinition.hs @@ -6,12 +6,12 @@ import Language.Haskell.LSP.Types import System.Directory import Test.Hls.Util import Test.Tasty -import Test.Tasty.ExpectedFailure (ignoreTestBecause) import Test.Tasty.HUnit +import Test.Tasty.ExpectedFailure (expectFailBecause) tests :: TestTree tests = testGroup "type definitions" [ - ignoreTestBecause "Broken" $ testCase "finds local definition of record variable" + testCase "finds local definition of record variable" $ runSession hlsCommand fullCaps "test/testdata/gototest" $ do doc <- openDoc "src/Lib.hs" "haskell" @@ -21,7 +21,8 @@ tests = testGroup "type definitions" [ defs @?= [ Location (filePathToUri fp) (Range (toPos (8, 1)) (toPos (8, 29))) ] - , ignoreTestBecause "Broken" $ testCase "finds local definition of newtype variable" + + , testCase "finds local definition of newtype variable" $ runSession hlsCommand fullCaps "test/testdata/gototest" $ do doc <- openDoc "src/Lib.hs" "haskell" @@ -31,7 +32,8 @@ tests = testGroup "type definitions" [ defs @?= [ Location (filePathToUri fp) (Range (toPos (13, 1)) (toPos (13, 30))) ] - , ignoreTestBecause "Broken" $ testCase "finds local definition of sum type variable" + + , testCase "finds local definition of sum type variable" $ runSession hlsCommand fullCaps "test/testdata/gototest" $ do doc <- openDoc "src/Lib.hs" "haskell" @@ -41,7 +43,8 @@ tests = testGroup "type definitions" [ defs @?= [ Location (filePathToUri fp) (Range (toPos (18, 1)) (toPos (18, 26))) ] - , ignoreTestBecause "Broken" $ testCase "finds local definition of sum type contructor" + + , testCase "finds local definition of sum type constructor" $ runSession hlsCommand fullCaps "test/testdata/gototest" $ do doc <- openDoc "src/Lib.hs" "haskell" @@ -52,14 +55,20 @@ tests = testGroup "type definitions" [ @?= [ Location (filePathToUri fp) (Range (toPos (18, 1)) (toPos (18, 26))) ] - , ignoreTestBecause "Broken" $ testCase "can not find non-local definition of type def" + + , testCase "finds non-local definition of type def" $ runSession hlsCommand fullCaps "test/testdata/gototest" $ do doc <- openDoc "src/Lib.hs" "haskell" defs <- getTypeDefinitions doc (toPos (30, 17)) - liftIO $ defs @?= [] + liftIO $ do + fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" + defs + @?= [ Location (filePathToUri fp) + (Range (toPos (27, 1)) (toPos (27, 17))) + ] - , ignoreTestBecause "Broken" $ testCase "find local definition of type def" + , testCase "find local definition of type def" $ runSession hlsCommand fullCaps "test/testdata/gototest" $ do doc <- openDoc "src/Lib.hs" "haskell" @@ -67,12 +76,11 @@ tests = testGroup "type definitions" [ liftIO $ do fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" defs @?= [ Location (filePathToUri fp) - (Range (toPos (18, 1)) (toPos (18, 26))) + (Range (toPos (32, 1)) (toPos (32, 18))) ] - {-- TODO Implement - , ignoreTestBecause "Broken" $ testCase "find type-definition of type def in component" - $ pendingWith "Finding symbols cross module is currently not supported" + , expectFailBecause "This test is broken because it needs a proper cradle." $ + testCase "find type-definition of type def in component" $ runSession hlsCommand fullCaps "test/testdata/gototest" $ do doc <- openDoc "src/Lib2.hs" "haskell" @@ -85,8 +93,8 @@ tests = testGroup "type definitions" [ @?= [ Location (filePathToUri fp) (Range (toPos (8, 1)) (toPos (8, 29))) ] - --} - , ignoreTestBecause "Broken" $ testCase "find definition of parameterized data type" + + , testCase "find definition of parameterized data type" $ runSession hlsCommand fullCaps "test/testdata/gototest" $ do doc <- openDoc "src/Lib.hs" "haskell" From d0670098c39b220dca4927aa6e95a86842d8b51c Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Sun, 20 Dec 2020 17:15:24 -0600 Subject: [PATCH 3/5] Refactor getTypeDefinition tests. --- test/functional/TypeDefinition.hs | 114 ++++++++---------------------- 1 file changed, 29 insertions(+), 85 deletions(-) diff --git a/test/functional/TypeDefinition.hs b/test/functional/TypeDefinition.hs index 0fb8af516b..ee840b0c98 100644 --- a/test/functional/TypeDefinition.hs +++ b/test/functional/TypeDefinition.hs @@ -1,111 +1,55 @@ module TypeDefinition (tests) where +import Control.Lens ((^.)) import Control.Monad.IO.Class import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types.Lens as L import System.Directory +import System.FilePath (()) import Test.Hls.Util import Test.Tasty import Test.Tasty.HUnit -import Test.Tasty.ExpectedFailure (expectFailBecause) tests :: TestTree tests = testGroup "type definitions" [ testCase "finds local definition of record variable" - $ runSession hlsCommand fullCaps "test/testdata/gototest" - $ do - doc <- openDoc "src/Lib.hs" "haskell" - defs <- getTypeDefinitions doc (toPos (11, 23)) - liftIO $ do - fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" - defs @?= [ Location (filePathToUri fp) - (Range (toPos (8, 1)) (toPos (8, 29))) - ] - + $ getTypeDefinitionTest' (11, 23) 8 , testCase "finds local definition of newtype variable" - $ runSession hlsCommand fullCaps "test/testdata/gototest" - $ do - doc <- openDoc "src/Lib.hs" "haskell" - defs <- getTypeDefinitions doc (toPos (16, 21)) - liftIO $ do - fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" - defs @?= [ Location (filePathToUri fp) - (Range (toPos (13, 1)) (toPos (13, 30))) - ] - + $ getTypeDefinitionTest' (16, 21) 13 , testCase "finds local definition of sum type variable" - $ runSession hlsCommand fullCaps "test/testdata/gototest" - $ do - doc <- openDoc "src/Lib.hs" "haskell" - defs <- getTypeDefinitions doc (toPos (21, 13)) - liftIO $ do - fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" - defs @?= [ Location (filePathToUri fp) - (Range (toPos (18, 1)) (toPos (18, 26))) - ] - + $ getTypeDefinitionTest' (21, 13) 18 , testCase "finds local definition of sum type constructor" - $ runSession hlsCommand fullCaps "test/testdata/gototest" - $ do - doc <- openDoc "src/Lib.hs" "haskell" - defs <- getTypeDefinitions doc (toPos (24, 7)) - liftIO $ do - fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" - defs - @?= [ Location (filePathToUri fp) - (Range (toPos (18, 1)) (toPos (18, 26))) - ] - + $ getTypeDefinitionTest' (24, 7) 18 , testCase "finds non-local definition of type def" - $ runSession hlsCommand fullCaps "test/testdata/gototest" - $ do - doc <- openDoc "src/Lib.hs" "haskell" - defs <- getTypeDefinitions doc (toPos (30, 17)) - liftIO $ do - fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" - defs - @?= [ Location (filePathToUri fp) - (Range (toPos (27, 1)) (toPos (27, 17))) - ] - + $ getTypeDefinitionTest' (30, 17) 27 , testCase "find local definition of type def" - $ runSession hlsCommand fullCaps "test/testdata/gototest" - $ do - doc <- openDoc "src/Lib.hs" "haskell" - defs <- getTypeDefinitions doc (toPos (35, 16)) - liftIO $ do - fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" - defs @?= [ Location (filePathToUri fp) - (Range (toPos (32, 1)) (toPos (32, 18))) - ] - + $ getTypeDefinitionTest' (35, 16) 32 , expectFailBecause "This test is broken because it needs a proper cradle." $ testCase "find type-definition of type def in component" - $ runSession hlsCommand fullCaps "test/testdata/gototest" - $ do - doc <- openDoc "src/Lib2.hs" "haskell" - otherDoc <- openDoc "src/Lib.hs" "haskell" - closeDoc otherDoc - defs <- getTypeDefinitions doc (toPos (13, 20)) - liftIO $ do - fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" - defs - @?= [ Location (filePathToUri fp) - (Range (toPos (8, 1)) (toPos (8, 29))) - ] - + $ getTypeDefinitionTest "src/Lib2.hs" (13, 20) "src/Lib.hs" 8 , testCase "find definition of parameterized data type" - $ runSession hlsCommand fullCaps "test/testdata/gototest" - $ do - doc <- openDoc "src/Lib.hs" "haskell" - defs <- getTypeDefinitions doc (toPos (40, 19)) - liftIO $ do - fp <- canonicalizePath "test/testdata/gototest/src/Lib.hs" - defs @?= [ Location (filePathToUri fp) - (Range (toPos (37, 1)) (toPos (37, 31))) - ] + $ getTypeDefinitionTest' (40, 19) 37 ] +getTypeDefinitionTest :: String -> (Int, Int) -> String -> Int -> Assertion +getTypeDefinitionTest symbolFile symbolPosition definitionFile definitionLine = + failIfSessionTimeout . runSession hlsCommand fullCaps "test/testdata/gototest" $ do + doc <- openDoc symbolFile "haskell" + _ <- openDoc definitionFile "haskell" + defs <- getTypeDefinitions doc $ toPos symbolPosition + fp <- liftIO $ canonicalizePath $ "test/testdata/gototest" definitionFile + liftIO $ do + length defs == 1 @? "Expecting a list containing one location, but got: " ++ show defs + let [def] = defs + def ^. L.uri @?= filePathToUri fp + def ^. L.range . L.start . L.line @?= definitionLine - 1 + def ^. L.range . L.end . L.line @?= definitionLine - 1 + +getTypeDefinitionTest' :: (Int, Int) -> Int -> Assertion +getTypeDefinitionTest' symbolPosition definitionLine = + getTypeDefinitionTest "src/Lib.hs" symbolPosition "src/Lib.hs" definitionLine + --NOTE: copied from Haskell.Ide.Engine.ArtifactMap toPos :: (Int,Int) -> Position toPos (l,c) = Position (l-1) (c-1) From a475307331bd7187536612e79ba178f2c2ac6585 Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Sun, 20 Dec 2020 17:16:14 -0600 Subject: [PATCH 4/5] Fix cradle and enable last getTypeDefinition test. For HLS to find definitions in Lib when queried about symbols in Lib2, HLS needs access to a proper cradle. --- test/functional/TypeDefinition.hs | 3 +-- test/testdata/gototest/Setup.hs | 2 -- test/testdata/gototest/app/Main.hs | 7 ------- test/testdata/gototest/cabal.project | 3 --- test/testdata/gototest/gototest.cabal | 24 ------------------------ test/testdata/gototest/hie.yaml | 6 ++++++ 6 files changed, 7 insertions(+), 38 deletions(-) delete mode 100644 test/testdata/gototest/Setup.hs delete mode 100644 test/testdata/gototest/app/Main.hs delete mode 100644 test/testdata/gototest/cabal.project delete mode 100644 test/testdata/gototest/gototest.cabal create mode 100644 test/testdata/gototest/hie.yaml diff --git a/test/functional/TypeDefinition.hs b/test/functional/TypeDefinition.hs index ee840b0c98..909698f3cb 100644 --- a/test/functional/TypeDefinition.hs +++ b/test/functional/TypeDefinition.hs @@ -25,8 +25,7 @@ tests = testGroup "type definitions" [ $ getTypeDefinitionTest' (30, 17) 27 , testCase "find local definition of type def" $ getTypeDefinitionTest' (35, 16) 32 - , expectFailBecause "This test is broken because it needs a proper cradle." $ - testCase "find type-definition of type def in component" + , testCase "find type-definition of type def in component" $ getTypeDefinitionTest "src/Lib2.hs" (13, 20) "src/Lib.hs" 8 , testCase "find definition of parameterized data type" $ getTypeDefinitionTest' (40, 19) 37 diff --git a/test/testdata/gototest/Setup.hs b/test/testdata/gototest/Setup.hs deleted file mode 100644 index 9a994af677..0000000000 --- a/test/testdata/gototest/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/test/testdata/gototest/app/Main.hs b/test/testdata/gototest/app/Main.hs deleted file mode 100644 index 2c951ca59d..0000000000 --- a/test/testdata/gototest/app/Main.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -import Lib -import Lib2 - -main :: IO () -main = someFunc >> g diff --git a/test/testdata/gototest/cabal.project b/test/testdata/gototest/cabal.project deleted file mode 100644 index 258ca2fe22..0000000000 --- a/test/testdata/gototest/cabal.project +++ /dev/null @@ -1,3 +0,0 @@ -packages: . - -write-ghc-environment-files: never diff --git a/test/testdata/gototest/gototest.cabal b/test/testdata/gototest/gototest.cabal deleted file mode 100644 index 5cac1ffefd..0000000000 --- a/test/testdata/gototest/gototest.cabal +++ /dev/null @@ -1,24 +0,0 @@ -name: gototest -version: 0.1.0.0 --- synopsis: --- description: -license: BSD3 -author: Author name here -maintainer: example@example.com -copyright: 2017 Author name here -category: Web -build-type: Simple -cabal-version: >=1.10 - -executable gototest-exec - hs-source-dirs: app - main-is: Main.hs - other-modules: - build-depends: base >= 4.7 && < 5, gototest - default-language: Haskell2010 - -library - hs-source-dirs: src - exposed-modules: Lib, Lib2 - build-depends: base >= 4.7 && < 5 - default-language: Haskell2010 diff --git a/test/testdata/gototest/hie.yaml b/test/testdata/gototest/hie.yaml new file mode 100644 index 0000000000..94c8271c18 --- /dev/null +++ b/test/testdata/gototest/hie.yaml @@ -0,0 +1,6 @@ +cradle: + direct: + arguments: + - "-i src/" + - "Lib" + - "Lib2" From 32b5cbc89d672c57b533639221bccc843bd2056c Mon Sep 17 00:00:00 2001 From: Peter Wicks Stringfield Date: Sun, 20 Dec 2020 19:45:58 -0600 Subject: [PATCH 5/5] Disable test on GHC 8.8.x. --- test/functional/TypeDefinition.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/functional/TypeDefinition.hs b/test/functional/TypeDefinition.hs index 909698f3cb..f94ed27de1 100644 --- a/test/functional/TypeDefinition.hs +++ b/test/functional/TypeDefinition.hs @@ -19,7 +19,8 @@ tests = testGroup "type definitions" [ $ getTypeDefinitionTest' (16, 21) 13 , testCase "finds local definition of sum type variable" $ getTypeDefinitionTest' (21, 13) 18 - , testCase "finds local definition of sum type constructor" + , knownBrokenForGhcVersions [GHC88] "Definition of sum type not found from data constructor in GHC 8.8.x" $ + testCase "finds local definition of sum type constructor" $ getTypeDefinitionTest' (24, 7) 18 , testCase "finds non-local definition of type def" $ getTypeDefinitionTest' (30, 17) 27