4f61cb6 · ghcide · git.iko.soy

git.iko.soy/ghcide

Fix source spans for multi-clause definitions (#318)

* 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.

commit4f61cb66c9c41d7d1e70c56bc2e176d42f3ac08c authorMoritz Kiefer <moritz.kiefer@purelyfunctional.org> dateFri 10 Jan 2020, 15:37 (7 years ago) parenteb96e2c

3 files changed+30−7

compare with master

unifiedsplit

src/Development/IDE/Spans/Calculate.hs+20−5 test/data/GotoHover.hs+1−1 test/exe/Main.hs+9−1

src/Development/IDE/Spans/Calculate.hs+20−5

@@ -23,6 +23,7 @@ import Desugar

2323import GHC

2424import GhcMonad

2525import FastString (mkFastString)

26+import OccName

2627import Development.IDE.Types.Location

2728import Development.IDE.Spans.Type

2829import Development.IDE.GHC.Error (zeroSpan)

@@ -30,6 +31,7 @@ import Prelude hiding (mod)

3031import TcHsSyn

3132import Var

3233import Development.IDE.Core.Compile

34+import qualified Development.IDE.GHC.Compat as Compat

3335import Development.IDE.GHC.Util

3436

3537

@@ -63,7 +65,8 @@ getSpanInfo mods tcm =

6365 es = listifyAllSpans tcs :: [LHsExpr GhcTc]

6466 ps = listifyAllSpans' tcs :: [Pat GhcTc]

6567 ts = listifyAllSpans $ tm_renamed_source tcm :: [LHsType GhcRn]

66− bts <- mapM (getTypeLHsBind tcm) bs -- binds

68+ let funBinds = funBindMap $ tm_parsed_module tcm

69+ bts <- mapM (getTypeLHsBind funBinds) bs -- binds

6770 ets <- mapM (getTypeLHsExpr tcm) es -- expressions

6871 pts <- mapM (getTypeLPat tcm) ps -- patterns

6972 tts <- mapM (getLHsType tcm) ts -- types

@@ -76,6 +79,15 @@ getSpanInfo mods tcm =

7679 | b `isSubspanOf` a = GT

7780 | otherwise = compare (srcSpanStart a) (srcSpanStart b)

7881

82+-- | The locations in the typechecked module are slightly messed up in some cases (e.g. HsMatchContext always

83+-- points to the first match) whereas the parsed module has the correct locations.

84+-- Therefore we build up a map from OccName to the corresponding definition in the parsed module

85+-- to lookup precise locations for things like multi-clause function definitions.

86+--

87+-- For now this only contains FunBinds.

88+funBindMap :: ParsedModule -> OccEnv (HsBind GhcPs)

89+funBindMap pm = mkOccEnv $ [ (occName $ unLoc f, bnd) | L _ (Compat.ValD bnd@FunBind{fun_id = f}) <- hsmodDecls $ unLoc $ pm_parsed_source pm ]

90+

7991getExports :: TypecheckedModule -> [(SpanSource, SrcSpan, Maybe Type)]

8092getExports m

8193 | Just (_, _, Just exports, _) <- renamedSource m =

@@ -95,12 +107,15 @@ ieLNames _ = []

95107

96108-- | Get the name and type of a binding.

97109getTypeLHsBind :: (GhcMonad m)

98− => TypecheckedModule

110+ => OccEnv (HsBind GhcPs)

99111 -> LHsBind GhcTc

100112 -> m [(SpanSource, SrcSpan, Maybe Type)]

101−getTypeLHsBind _ (L _spn FunBind{ fun_id = pid

102− , fun_matches = MG{mg_alts=(L _ matches)}}) =

103− return [(Named (getName (unLoc pid)), getLoc match, Just (varType (unLoc pid))) | match <- matches ]

113+getTypeLHsBind funBinds (L _spn FunBind{fun_id = pid})

114+ | Just FunBind {fun_matches = MG{mg_alts=L _ matches}} <- lookupOccEnv funBinds (occName $ unLoc pid) =

115+ return [(Named (getName (unLoc pid)), getLoc mc_fun, Just (varType (unLoc pid))) | match <- matches, FunRhs{mc_fun = mc_fun} <- [m_ctxt $ unLoc match] ]

116+-- In theory this shouldn’t ever fail but if it does, we can at least show the first clause.

117+getTypeLHsBind _ (L _spn FunBind{fun_id = pid,fun_matches = MG{}}) =

118+ return [(Named $ getName (unLoc pid), getLoc pid, Just (varType (unLoc pid)))]

104119getTypeLHsBind _ _ = return []

105120

106121-- | Get the name and type of an expression.

test/data/GotoHover.hs+1−1

@@ -34,7 +34,7 @@ listCompBind :: [Char]

3434listCompBind = [ succ c | c <- "ptfx" ]

3535

3636multipleClause :: Bool -> Char

37−multipleClause True = 't'

37+multipleClause True = 't'

3838multipleClause False = 'f'

3939

4040-- | Recognizable docs: kpqz

test/exe/Main.hs+9−1

@@ -1004,6 +1004,8 @@ findDefinitionAndHoverTests = let

10041004 check (ExpectRange expectedRange) = do

10051005 assertNDefinitionsFound 1 defs

10061006 assertRangeCorrect (head defs) expectedRange

1007+ check ExpectNoDefinitions = do

1008+ assertNDefinitionsFound 0 defs

10071009 check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"

10081010 check _ = pure () -- all other expectations not relevant to getDefinition

10091011

@@ -1018,13 +1020,14 @@ findDefinitionAndHoverTests = let

10181020

10191021 check expected =

10201022 case hover of

1021− Nothing -> liftIO $ assertFailure "no hover found"

1023+ Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found"

10221024 Just Hover{_contents = (HoverContents MarkupContent{_value = msg})

10231025 ,_range = rangeInHover } ->

10241026 case expected of

10251027 ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg

10261028 ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg

10271029 ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets

1030+ ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover

10281031 _ -> pure () -- all other expectations not relevant to hover

10291032 _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover

10301033

@@ -1089,6 +1092,7 @@ findDefinitionAndHoverTests = let

10891092 lclL33 = Position 33 22

10901093 mclL36 = Position 36 1 ; mcl = [mkR 36 0 36 14]

10911094 mclL37 = Position 37 1

1095+ spaceL37 = Position 37 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]]

10921096 docL41 = Position 41 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]]

10931097 ; constr = [ExpectHoverText ["Monad m =>"]]

10941098 eitL40 = Position 40 28 ; kindE = [ExpectHoverText [":: * -> * -> *\n"]]

@@ -1126,6 +1130,7 @@ findDefinitionAndHoverTests = let

11261130 , test yes yes lclL33 lcb "listcomp lookup"

11271131 , test yes yes mclL36 mcl "top-level fn 1st clause"

11281132 , test yes yes mclL37 mcl "top-level fn 2nd clause #246"

1133+ , test yes yes spaceL37 space "top-level fn on space #315"

11291134 , test no broken docL41 doc "documentation #7"

11301135 , test no broken eitL40 kindE "kind of Either #273"

11311136 , test no broken intL40 kindI "kind of Int #273"

@@ -1482,7 +1487,10 @@ data Expect

14821487 | ExpectHoverRange Range -- Only hover should report this range

14831488 | ExpectHoverText [T.Text] -- the hover message must contain these snippets

14841489 | ExpectExternFail -- definition lookup in other file expected to fail

1490+ | ExpectNoDefinitions

1491+ | ExpectNoHover

14851492-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples

1493+ deriving Eq

14861494

14871495mkR :: Int -> Int -> Int -> Int -> Expect

14881496mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn