From 4f61cb66c9c41d7d1e70c56bc2e176d42f3ac08c Mon Sep 17 00:00:00 2001 From: Moritz Kiefer Date: Fri, 10 Jan 2020 15:37:09 +0100 Subject: [PATCH] Fix source spans for multi-clause definitions (#318) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Fix source spans for multi-clause definitions Currently, we use the source span of the match which corresponds to the whole clause instead of just the function identifier. This resulted in us pointing every goto definition request within a clause to the function if there is no other information (either because it failed because it came from an external package or simply because you are not on an identifier). This PR fixes this by getting the proper source spans frmo the HsMatchContext. Somewhat annoyingly, we have to get it from the parsed module since GHC messes this up during typechecking but it’s reasonably simple. --- src/Development/IDE/Spans/Calculate.hs | 25 ++++++++++++++++++++----- test/data/GotoHover.hs | 2 +- test/exe/Main.hs | 10 +++++++++- 3 files changed, 30 insertions(+), 7 deletions(-) diff --git a/src/Development/IDE/Spans/Calculate.hs b/src/Development/IDE/Spans/Calculate.hs index 8a235a344a..b6016ff336 100644 --- a/src/Development/IDE/Spans/Calculate.hs +++ b/src/Development/IDE/Spans/Calculate.hs @@ -23,6 +23,7 @@ import Desugar import GHC import GhcMonad import FastString (mkFastString) +import OccName import Development.IDE.Types.Location import Development.IDE.Spans.Type import Development.IDE.GHC.Error (zeroSpan) @@ -30,6 +31,7 @@ import Prelude hiding (mod) import TcHsSyn import Var import Development.IDE.Core.Compile +import qualified Development.IDE.GHC.Compat as Compat import Development.IDE.GHC.Util @@ -63,7 +65,8 @@ getSpanInfo mods tcm = es = listifyAllSpans tcs :: [LHsExpr GhcTc] ps = listifyAllSpans' tcs :: [Pat GhcTc] ts = listifyAllSpans $ tm_renamed_source tcm :: [LHsType GhcRn] - bts <- mapM (getTypeLHsBind tcm) bs -- binds + let funBinds = funBindMap $ tm_parsed_module tcm + bts <- mapM (getTypeLHsBind funBinds) bs -- binds ets <- mapM (getTypeLHsExpr tcm) es -- expressions pts <- mapM (getTypeLPat tcm) ps -- patterns tts <- mapM (getLHsType tcm) ts -- types @@ -76,6 +79,15 @@ getSpanInfo mods tcm = | b `isSubspanOf` a = GT | otherwise = compare (srcSpanStart a) (srcSpanStart b) +-- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always +-- points to the first match) whereas the parsed module has the correct locations. +-- Therefore we build up a map from OccName to the corresponding definition in the parsed module +-- to lookup precise locations for things like multi-clause function definitions. +-- +-- For now this only contains FunBinds. +funBindMap :: ParsedModule -> OccEnv (HsBind GhcPs) +funBindMap pm = mkOccEnv $ [ (occName $ unLoc f, bnd) | L _ (Compat.ValD bnd@FunBind{fun_id = f}) <- hsmodDecls $ unLoc $ pm_parsed_source pm ] + getExports :: TypecheckedModule -> [(SpanSource, SrcSpan, Maybe Type)] getExports m | Just (_, _, Just exports, _) <- renamedSource m = @@ -95,12 +107,15 @@ ieLNames _ = [] -- | Get the name and type of a binding. getTypeLHsBind :: (GhcMonad m) - => TypecheckedModule + => OccEnv (HsBind GhcPs) -> LHsBind GhcTc -> m [(SpanSource, SrcSpan, Maybe Type)] -getTypeLHsBind _ (L _spn FunBind{ fun_id = pid - , fun_matches = MG{mg_alts=(L _ matches)}}) = - return [(Named (getName (unLoc pid)), getLoc match, Just (varType (unLoc pid))) | match <- matches ] +getTypeLHsBind funBinds (L _spn FunBind{fun_id = pid}) + | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) = + return [(Named (getName (unLoc pid)), getLoc mc_fun, Just (varType (unLoc pid))) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ] +-- In theory this shouldn’t ever fail but if it does, we can at least show the first clause. +getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) = + return [(Named $ getName (unLoc pid), getLoc pid, Just (varType (unLoc pid)))] getTypeLHsBind _ _ = return [] -- | Get the name and type of an expression. diff --git a/test/data/GotoHover.hs b/test/data/GotoHover.hs index 91b0f780b2..135d50e8ee 100644 --- a/test/data/GotoHover.hs +++ b/test/data/GotoHover.hs @@ -34,7 +34,7 @@ listCompBind :: [Char] listCompBind = [ succ c | c <- "ptfx" ] multipleClause :: Bool -> Char -multipleClause True = 't' +multipleClause True = 't' multipleClause False = 'f' -- | Recognizable docs: kpqz diff --git a/test/exe/Main.hs b/test/exe/Main.hs index ff26345c5b..64b59d5ef5 100644 --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -1004,6 +1004,8 @@ findDefinitionAndHoverTests = let check (ExpectRange expectedRange) = do assertNDefinitionsFound 1 defs assertRangeCorrect (head defs) expectedRange + check ExpectNoDefinitions = do + assertNDefinitionsFound 0 defs check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file" check _ = pure () -- all other expectations not relevant to getDefinition @@ -1018,13 +1020,14 @@ findDefinitionAndHoverTests = let check expected = case hover of - Nothing -> liftIO $ assertFailure "no hover found" + Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" Just Hover{_contents = (HoverContents MarkupContent{_value = msg}) ,_range = rangeInHover } -> case expected of ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets + 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 @@ -1089,6 +1092,7 @@ findDefinitionAndHoverTests = let lclL33 = Position 33 22 mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14] mclL37 = Position 37 1 + spaceL37 = Position 37 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]] docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]] ; constr = [ExpectHoverText ["Monad m =>"]] eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]] @@ -1126,6 +1130,7 @@ findDefinitionAndHoverTests = let , test yes yes lclL33 lcb "listcomp lookup" , test yes yes mclL36 mcl "top-level fn 1st clause" , test yes yes mclL37 mcl "top-level fn 2nd clause #246" + , test yes yes spaceL37 space "top-level fn on space #315" , test no broken docL41 doc "documentation #7" , test no broken eitL40 kindE "kind of Either #273" , test no broken intL40 kindI "kind of Int #273" @@ -1482,7 +1487,10 @@ data Expect | ExpectHoverRange Range -- Only hover should report this range | ExpectHoverText [T.Text] -- the hover message must contain these snippets | ExpectExternFail -- definition lookup in other file expected to fail + | ExpectNoDefinitions + | ExpectNoHover -- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples + deriving Eq mkR :: Int -> Int -> Int -> Int -> Expect mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn