Skip to content

Commit

Permalink
Remove unused test code with helpful error message
Browse files Browse the repository at this point in the history
  • Loading branch information
fendor committed Oct 23, 2024
1 parent cfd73c7 commit 8ce5ec5
Showing 1 changed file with 8 additions and 49 deletions.
57 changes: 8 additions & 49 deletions ghcide/test/exe/FindImplementationAndHoverTests.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -39,55 +36,17 @@ 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)
ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover
_ -> 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 <> ":<LINE>:<COL>**[...]", 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)
Expand Down

0 comments on commit 8ce5ec5

Please sign in to comment.