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