find definition test to core-plugin

Author: soulomoon

ghcide/ghcide.cabal

@@ -361,12 +361,10 @@ test-suite ghcide-tests
     DependentFileTest
     DiagnosticTests
     ExceptionTests
-    FindDefinitionAndHoverTests
     FuzzySearch
     GarbageCollectionTests
     HaddockTests
     HieDbRetry
-    HighlightTests
     IfaceTests
     LogType
     NonLspCommandLine

ghcide/test/exe/Main.hs

@@ -50,8 +50,6 @@ import OpenCloseTest
 import CPPTests
 import DiagnosticTests
 import CodeLensTests
-import HighlightTests
-import FindDefinitionAndHoverTests
 import PluginSimpleTests
 import PreprocessorTests
 import THTests
@@ -93,8 +91,6 @@ main = do
     , CPPTests.tests
     , DiagnosticTests.tests
     , CodeLensTests.tests
-    , HighlightTests.tests
-    , FindDefinitionAndHoverTests.tests
     , PluginSimpleTests.tests
     , PreprocessorTests.tests
     , THTests.tests

haskell-language-server.cabal

@@ -1763,9 +1763,11 @@ test-suite hls-core-plugin-tests
   main-is:          CoreTest.hs
   other-modules:
     Util
+    FindDefinitionAndHoverTests
     InitializeResponseTests
     OutlineTests
     CompletionTests
+    HighlightTests
 
 
   build-depends:
@@ -1790,6 +1792,7 @@ test-suite hls-core-plugin-tests
     , row-types
     , extra
     , hls-test-utils
+    , regex-tdfa
 
 
 -----------------------------

plugins/hls-core-plugin/test/CoreTest.hs

@@ -3,17 +3,22 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 import qualified CompletionTests
+import qualified FindDefinitionAndHoverTests
+import qualified HighlightTests
 import qualified InitializeResponseTests
 import qualified OutlineTests
-import           Test.Hls                (defaultTestRunner, testGroup)
+import           Test.Hls                    (defaultTestRunner, testGroup)
 
 
 main :: IO ()
 main =
   defaultTestRunner $
     testGroup
       "core"
-      [ InitializeResponseTests.tests
+      [
+        InitializeResponseTests.tests
       , OutlineTests.tests
       , CompletionTests.tests
+      , HighlightTests.tests
+      , FindDefinitionAndHoverTests.tests
       ]

plugins/hls-core-plugin/test/exe/CompletionTests.hs

@@ -28,9 +28,13 @@ import           Language.LSP.Protocol.Types    hiding
                                                  mkRange)
 import           Language.LSP.Test
 import           System.FilePath
-import           Test.Hls                       (waitForTypecheck)
+import           Test.Hls                       (knownBrokenForGhcVersions,
+                                                 knownBrokenInEnv,
+                                                 waitForTypecheck)
 import qualified Test.Hls.FileSystem            as FS
 import           Test.Hls.FileSystem            (file, text)
+import           Test.Hls.Util                  (EnvSpec (..), OS (..),
+                                                 knownBrokenOnWindows)
 import           Test.Tasty
 import           Test.Tasty.HUnit
 import           Util
@@ -272,7 +276,7 @@ nonLocalCompletionTests =
       []
   ]
   where
-    brokenForWinGhc = knownBrokenFor (BrokenSpecific Windows [GHC92, GHC94, GHC96, GHC98]) "Windows has strange things in scope for some reason"
+    brokenForWinGhc = knownBrokenOnWindows "Windows has strange things in scope for some reason"
 
 otherCompletionTests :: [TestTree]
 otherCompletionTests = [
@@ -554,7 +558,7 @@ completionDocTests =
   ]
   where
     -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903
-    brokenForMacGhc9 = knownBrokenFor (BrokenSpecific MacOS [GHC92, GHC94, GHC96]) "Extern doc doesn't support MacOS for ghc9"
+    brokenForMacGhc9 = knownBrokenInEnv [] "Extern doc doesn't support MacOS for ghc9"
     test doc pos label mn expected = do
       _ <- waitForDiagnostics
       compls <- getCompletions doc pos

ghcide/test/exe/FindDefinitionAndHoverTests.hs renamed to plugins/hls-core-plugin/test/exe/FindDefinitionAndHoverTests.hs

@@ -1,56 +1,70 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns      #-}
 
 module FindDefinitionAndHoverTests (tests) where
 
 import           Control.Monad
-import           Control.Monad.IO.Class         (liftIO)
+import           Control.Monad.IO.Class      (liftIO)
 import           Data.Foldable
 import           Data.Maybe
-import qualified Data.Text                      as T
-import           Development.IDE.GHC.Compat     (GhcVersion (..), ghcVersion)
+import qualified Data.Text                   as T
+import           Development.IDE.GHC.Compat  (GhcVersion (..), ghcVersion)
 import           Development.IDE.GHC.Util
-import           Development.IDE.Test           (expectDiagnostics,
-                                                 standardizeQuotes)
-import           Development.IDE.Types.Location
-import qualified Language.LSP.Protocol.Lens     as L
-import           Language.LSP.Protocol.Types    hiding
-                                                (SemanticTokenAbsolute (..),
-                                                 SemanticTokenRelative (..),
-                                                 SemanticTokensEdit (..),
-                                                 mkRange)
+-- import           Development.IDE.Test           (expectDiagnostics,
+--                                                  standardizeQuotes)
+import qualified Language.LSP.Protocol.Lens  as L
+-- import           Language.LSP.Protocol.Types    hiding
+--                                                 (SemanticTokenAbsolute (..),
+--                                                  SemanticTokenRelative (..),
+--                                                  SemanticTokensEdit (..),
+--                                                  mkRange)
+
+import           Language.LSP.Protocol.Types (DiagnosticSeverity (..),
+                                              Hover (..), MarkupContent (..),
+                                              Position (..), Range,
+                                              TextDocumentIdentifier, mkRange,
+                                              type (|?) (..))
+
 import           Language.LSP.Test
 import           System.FilePath
-import           System.Info.Extra              (isWindows)
+import           System.Info.Extra           (isWindows)
 
-import           Control.Lens                   ((^.))
+import           Control.Lens                ((^.))
 import           Test.Tasty
 import           Test.Tasty.HUnit
-import           TestUtils
-import           Text.Regex.TDFA                ((=~))
+-- import           TestUtils
+import           Test.Hls                    (knownBrokenForGhcVersions,
+                                              waitForProgressDone,
+                                              waitForTypecheck)
+import           Test.Hls.FileSystem         (copy, directProjectMulti)
+import           Text.Regex.TDFA             ((=~))
+import           Util
 
 tests :: TestTree
 tests = let
-
   tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree
-  tst (get, check) pos sfp targetRange title = testSessionWithExtraFiles "hover" title $ \dir -> do
-
+  tst (get, check) pos sfp targetRange title = testSessionWithCorePlugin title (mkFs $  fmap (copy . ("hover" </>)) ["Bar.hs", "Foo.hs", "GotoHover.hs", "hie.yaml", "RecordDotSyntax.hs"]) $ do
     -- Dirty the cache to check that definitions work even in the presence of iface files
-    liftIO $ runInDir dir $ do
-      let fooPath = dir </> "Foo.hs"
-      fooSource <- liftIO $ readFileUtf8 fooPath
-      fooDoc <- createDoc fooPath "haskell" fooSource
-      _ <- getHover fooDoc $ Position 4 3
-      closeDoc fooDoc
-
-    doc <- openTestDataDoc (dir </> sfp)
+    -- let fooPath = "Foo.hs"
+    -- fooSource <- liftIO $ readFileUtf8 fooPath
+    -- fooDoc <- createDoc fooPath "haskell" fooSource
+    -- _ <- getHover fooDoc $ Position 4 3
+    -- closeDoc fooDoc
+
+    doc <- openDoc sfp "haskell"
     waitForProgressDone
+    x <- waitForTypecheck doc
+
+
     found <- get doc pos
     check found targetRange
 
 
 
-  checkHover :: Maybe Hover -> Session [Expect] -> Session ()
+  checkHover :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session ()
   checkHover hover expectations = traverse_ check =<< expectations where
 
+    check :: (HasCallStack) => Expect -> Session ()
     check expected =
       case hover of
         Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"
@@ -100,11 +114,11 @@ tests = let
   mkFindTests tests = testGroup "get"
     [ testGroup "definition" $ mapMaybe fst tests
     , testGroup "hover"      $ mapMaybe snd tests
-    , checkFileCompiles sourceFilePath $
-        expectDiagnostics
-          [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _")])
-          , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _")])
-          ]
+    -- , checkFileCompiles sourceFilePath $
+    --     expectDiagnostics
+    --       [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _")])
+    --       , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _")])
+    --       ]
     , testGroup "type-definition" typeDefinitionTests
     , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ]
 
@@ -117,8 +131,15 @@ tests = let
     , tst (getHover, checkHover) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child"
     ]
 
+  test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b)
   test runDef runHover look expect = testM runDef runHover look (return expect)
 
+  testM :: (HasCallStack) => (TestTree -> a)
+    -> (TestTree -> b)
+    -> Position
+    -> Session [Expect]
+    -> String
+    -> (a, b)
   testM runDef runHover look expect title =
     ( runDef   $ tst def   look sourceFilePath expect title
     , runHover $ tst hover look sourceFilePath expect title ) where
@@ -228,8 +249,8 @@ tests = let
         no = const Nothing -- don't run this test at all
         --skip = const Nothing -- unreliable, don't run
 
-checkFileCompiles :: FilePath -> Session () -> TestTree
-checkFileCompiles fp diag =
-  testSessionWithExtraFiles "hover" ("Does " ++ fp ++ " compile") $ \dir -> do
-    void (openTestDataDoc (dir </> fp))
-    diag
+-- checkFileCompiles :: FilePath -> Session () -> TestTree
+-- checkFileCompiles fp diag =
+--    testSessionWithCorePluginSingleFile ("hover: Does " ++ fp ++ " compile") $ \dir -> do
+--     void (openTestDataDoc fp)
+--     diag

ghcide/test/exe/HighlightTests.hs renamed to plugins/hls-core-plugin/test/exe/HighlightTests.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 
 module HighlightTests (tests) where
 
@@ -11,14 +12,17 @@ import           Language.LSP.Protocol.Types    hiding
                                                  SemanticTokensEdit (..),
                                                  mkRange)
 import           Language.LSP.Test
+import           Test.Hls                       (knownBrokenForGhcVersions)
 import           Test.Tasty
 import           Test.Tasty.HUnit
-import           TestUtils
+import           Util
+
+
 
 tests :: TestTree
 tests = testGroup "highlight"
-  [ testSessionWait "value" $ do
-    doc <- createDoc "A.hs" "haskell" source
+  [ testSessionWait "value" source $ do
+    doc <- openDoc "A.hs" "haskell"
     _ <- waitForDiagnostics
     highlights <- getHighlights doc (Position 3 2)
     liftIO $ highlights @?=
@@ -27,16 +31,16 @@ tests = testGroup "highlight"
             , DocumentHighlight (R 4 6 4 9) (Just DocumentHighlightKind_Read)
             , DocumentHighlight (R 5 22 5 25) (Just DocumentHighlightKind_Read)
             ]
-  , testSessionWait "type" $ do
-    doc <- createDoc "A.hs" "haskell" source
+  , testSessionWait "type" source $ do
+    doc <- openDoc "A.hs" "haskell"
     _ <- waitForDiagnostics
     highlights <- getHighlights doc (Position 2 8)
     liftIO $ highlights @?=
             [ DocumentHighlight (R 2 7 2 10) (Just DocumentHighlightKind_Read)
             , DocumentHighlight (R 3 11 3 14) (Just DocumentHighlightKind_Read)
             ]
-  , testSessionWait "local" $ do
-    doc <- createDoc "A.hs" "haskell" source
+  , testSessionWait "local" source $ do
+    doc <- openDoc "A.hs" "haskell"
     _ <- waitForDiagnostics
     highlights <- getHighlights doc (Position 6 5)
     liftIO $ highlights @?=
@@ -45,8 +49,8 @@ tests = testGroup "highlight"
             , DocumentHighlight (R 7 12 7 15) (Just DocumentHighlightKind_Read)
             ]
   , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "Ghc9 highlights the constructor and not just this field" $
-        testSessionWait "record" $ do
-        doc <- createDoc "A.hs" "haskell" recsource
+        testSessionWait "record" recsource $ do
+        doc <- openDoc "A.hs" "haskell"
         _ <- waitForDiagnostics
         highlights <- getHighlights doc (Position 4 15)
         liftIO $ highlights @?=
@@ -77,3 +81,4 @@ tests = testGroup "highlight"
       ,"data Rec = Rec { field1 :: Int, field2 :: Char }"
       ,"foo Rec{..} = field2 + field1"
       ]
+    testSessionWait name ct = testSessionWithCorePluginSingleFile name "A.hs" ct

plugins/hls-core-plugin/test/exe/OutlineTests.hs

@@ -17,8 +17,6 @@ import           Test.Tasty.HUnit
 import           Util
 -- import           TestUtils
 
-pattern R :: UInt -> UInt -> UInt -> UInt -> Range
-pattern R x y x' y' = Range (Position x y) (Position x' y')
 
 testSymbols :: (HasCallStack) => TestName -> FilePath -> [Text]  -> [DocumentSymbol] -> TestTree
 testSymbols testName path content expectedSymbols =