diff --git a/ghcide/test/exe/FindImplementationAndHoverTests.hs b/ghcide/test/exe/FindImplementationAndHoverTests.hs index 0bbc400e34..221be90dd2 100644 --- a/ghcide/test/exe/FindImplementationAndHoverTests.hs +++ b/ghcide/test/exe/FindImplementationAndHoverTests.hs @@ -7,18 +7,15 @@ module FindImplementationAndHoverTests (tests) where import Control.Monad import Data.Foldable import Data.Maybe -import qualified Data.Text as T -import qualified Language.LSP.Protocol.Lens as L +import Data.Text (Text) +import qualified Data.Text as T import Language.LSP.Test -import Text.Regex.TDFA ((=~)) +import Text.Regex.TDFA ((=~)) import Config -import Control.Category ((>>>)) -import Control.Lens ((^.)) -import Data.Text (Text) -import Development.IDE.Test (standardizeQuotes) +import Development.IDE.Test (standardizeQuotes) import Test.Hls -import Test.Hls.FileSystem (copyDir) +import Test.Hls.FileSystem (copyDir) tests :: TestTree tests = let @@ -39,10 +36,10 @@ tests = let case hover of Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg}) - ,_range = rangeInHover } -> + ,_range = _rangeInHover } -> case expected of - ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectRange _expectedRange -> liftIO $ assertFailure $ "ExpectRange assertion not implemented, yet." + ExpectHoverRange _expectedRange -> liftIO $ assertFailure $ "ExpectHoverRange assertion not implemented, yet." ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool) @@ -50,44 +47,6 @@ tests = let _ -> pure () -- all other expectations not relevant to hover _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover - extractLineColFromHoverMsg :: T.Text -> [T.Text] - extractLineColFromHoverMsg = - -- Hover messages contain multiple lines, and we are looking for the definition - -- site - T.lines - -- The line we are looking for looks like: "*Defined at /tmp/GotoHover.hs:22:3*" - -- So filter by the start of the line - >>> mapMaybe (T.stripPrefix "*Defined at") - -- There can be multiple definitions per hover message! - -- See the test "field in record definition" for example. - -- The tests check against the last line that contains the above line. - >>> last - -- [" /tmp/", "22:3*"] - >>> T.splitOn (sourceFileName <> ":") - -- "22:3*" - >>> last - -- ["22:3", ""] - >>> T.splitOn "*" - -- "22:3" - >>> head - -- ["22", "3"] - >>> T.splitOn ":" - - checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () - checkHoverRange expectedRange rangeInHover msg = - let - lineCol = extractLineColFromHoverMsg msg - -- looks like hovers use 1-based numbering while definitions use 0-based - -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. - adjust Position{_line = l, _character = c} = - Position{_line = l + 1, _character = c + 1} - in - case map (read . T.unpack) lineCol of - [l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c - _ -> liftIO $ assertFailure $ - "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> - "\n but got: " <> show (msg, rangeInHover) - assertFoundIn :: T.Text -> T.Text -> Assertion assertFoundIn part whole = assertBool (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)