From 230a9c9f079272b33b3843b2bea3500ac3193ce0 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 26 Jun 2021 19:17:15 +0530 Subject: [PATCH 1/3] Jump to instance definition and explain typeclass evidence --- ghcide/src/Development/IDE/Core/Actions.hs | 2 +- ghcide/src/Development/IDE/Spans/AtPoint.hs | 115 +++++++++++++++++--- 2 files changed, 103 insertions(+), 14 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 304dfd393e..c57d4ab730 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -86,7 +86,7 @@ getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) getDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide - (HAR _ hf _ _ _, mapping) <- useE GetHieAst file + (hf, mapping) <- useE GetHieAst file (ImportMap imports, _) <- useE GetImportMap file !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) toCurrentLocations mapping <$> AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos' diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index c729ec8e5d..b2a641e59d 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -49,7 +49,6 @@ import qualified Data.Text as T import qualified Data.Array as A import Data.Either -import Data.List (isSuffixOf) import Data.List.Extra (dropEnd1, nubOrd) import Data.Version (showVersion) @@ -57,6 +56,15 @@ import Development.IDE.Types.Shake (WithHieDb) import HieDb hiding (pointCommand) import System.Directory (doesFileExist) +#if MIN_VERSION_ghc(9,0,1) +import qualified Outputable as O +import Data.Tree +import qualified Data.Tree as T +import Data.List (isSuffixOf, sortOn) +#else +import Data.List (isSuffixOf) +#endif + -- | Gives a Uri for the module, given the .hie file location and the the module info -- The Bool denotes if it is a boot module type LookupModule m = FilePath -> ModuleName -> Unit -> Bool -> MaybeT m Uri @@ -197,7 +205,7 @@ gotoDefinition -> LookupModule m -> IdeOptions -> M.Map ModuleName NormalizedFilePath - -> HieASTs a + -> HieAstResult -> Position -> MaybeT m [Location] gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos @@ -211,7 +219,7 @@ atPoint -> HscEnv -> Position -> Maybe (Maybe Range, [T.Text]) -atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ pointCommand hf pos hoverInfo +atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) _rf _ kind) (DKMap dm km) env pos = listToMaybe $ pointCommand hf pos hoverInfo where -- Hover info for values/data hoverInfo ast = (Just range, prettyNames ++ pTypes) @@ -224,12 +232,21 @@ atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ p wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n" info = nodeInfoH kind ast - names = M.assocs $ nodeIdentifiers info + names = +#if MIN_VERSION_ghc(9,0,1) + sortOn (any isEvidenceUse . identInfo . snd) $ +#endif + M.assocs $ nodeIdentifiers info types = nodeType info prettyNames :: [T.Text] prettyNames = map prettyName names - prettyName (Right n, dets) = T.unlines $ + prettyName (Right n, dets) +#if MIN_VERSION_ghc(9,0,1) + | any isEvidenceUse (identInfo dets) = maybe "" (printOutputable . renderEvidenceTree) (getEvidenceTree _rf n) <> "\n" + | otherwise +#endif + = T.unlines $ wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) : maybeToList (pretty (definedAt n) (prettyPackageName n)) ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n @@ -250,9 +267,12 @@ atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ p pure $ "*(" <> pkgName <> "-" <> version <> ")*" prettyTypes = map (("_ :: "<>) . prettyType) types - prettyType t = case kind of - HieFresh -> printOutputable t - HieFromDisk full_file -> printOutputable $ hieTypeToIface $ recoverFullType t (hie_types full_file) + prettyType = printOutputable . expandType + + expandType :: a -> SDoc + expandType t = case kind of + HieFresh -> ppr t + HieFromDisk full_file -> ppr $ hieTypeToIface $ recoverFullType t (hie_types full_file) definedAt name = -- do not show "at " and similar messages @@ -261,6 +281,43 @@ atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ p UnhelpfulLoc {} | isInternalName name || isSystemName name -> Nothing _ -> Just $ "*Defined " <> printOutputable (pprNameDefnLoc name) <> "*" +#if MIN_VERSION_ghc(9,0,1) + -- We want to render the root constraint even if it is a let, + -- but we don't want to render any subsequent lets + renderEvidenceTree :: Tree (EvidenceInfo a) -> SDoc + -- However, if the root constraint is simply an indirection (via let) to a single other constraint, + -- we can still skip rendering it + renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) [x]) + = renderEvidenceTree x + renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_), ..}) xs) + = hang (text "- Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $ + vcat $ text "depending on:" : map renderEvidenceTree' xs + renderEvidenceTree x = renderEvidenceTree' x + + -- renderEvidenceTree' skips let bound evidence variables and prints the children directly + renderEvidenceTree' (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) xs) + = vcat (map renderEvidenceTree' xs) + renderEvidenceTree' (T.Node (EvidenceInfo{..}) xs) + = hang (text "- Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $ + vcat $ map (text . T.unpack) (definedAt evidenceVar) + ++ [printDets evidenceSpan evidenceDetails (null xs)] + ++ map renderEvidenceTree' xs + + printDets :: RealSrcSpan -> Maybe (EvVarSource, Scope, Maybe Span) -> Bool -> SDoc + printDets _ Nothing True = text "" + printDets _ Nothing False = text "constructed using:" + printDets ospn (Just (src,_,mspn)) _ = pprSrc + $$ text "at" <+> ppr spn + where + -- Use the bind span if we have one, else use the occurence span + spn = fromMaybe ospn mspn + pprSrc = case src of + -- Users don't know what HsWrappers are + EvWrapperBind -> "bound by type signature or pattern" + _ -> ppr src +#endif + + typeLocationsAtPoint :: forall m . MonadIO m @@ -276,7 +333,7 @@ typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKi let arr = hie_types hf ts = concat $ pointCommand ast pos getts unfold = map (arr A.!) - getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) + getts x = nodeType ni ++ mapMaybe identType (M.elems $ nodeIdentifiers ni) where ni = nodeInfo' x getTypes ts = flip concatMap (unfold ts) $ \case HTyVarTy n -> [n] @@ -295,12 +352,24 @@ typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKi HQualTy a b -> getTypes [a,b] HCastTy a -> getTypes [a] _ -> [] +<<<<<<< HEAD in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts) +||||||| parent of dc807c4a (Jump to instance definition and explain typeclass evidence) + in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) +======= + in nubOrd <$> concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) +>>>>>>> dc807c4a (Jump to instance definition and explain typeclass evidence) HieFresh -> let ts = concat $ pointCommand ast pos getts - getts x = nodeType ni ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni) + getts x = nodeType ni ++ mapMaybe identType (M.elems $ nodeIdentifiers ni) where ni = nodeInfo x +<<<<<<< HEAD in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts) +||||||| parent of dc807c4a (Jump to instance definition and explain typeclass evidence) + in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) +======= + in nubOrd <$> concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) +>>>>>>> dc807c4a (Jump to instance definition and explain typeclass evidence) namesInType :: Type -> [Name] namesInType (TyVarTy n) = [varName n] @@ -313,24 +382,44 @@ namesInType (LitTy _) = [] namesInType _ = [] getTypes :: [Type] -> [Name] -getTypes ts = concatMap namesInType ts +getTypes = concatMap namesInType locationsAtPoint - :: forall m a + :: forall m . MonadIO m => WithHieDb -> LookupModule m -> IdeOptions -> M.Map ModuleName NormalizedFilePath -> Position - -> HieASTs a + -> HieAstResult -> m [Location] +<<<<<<< HEAD locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast = +||||||| parent of dc807c4a (Jump to instance definition and explain typeclass evidence) +locationsAtPoint hiedb lookupModule _ideOptions imports pos ast = +======= +locationsAtPoint hiedb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) = +>>>>>>> dc807c4a (Jump to instance definition and explain typeclass evidence) let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) +#if MIN_VERSION_ghc(9,0,1) + evTrees = mapMaybe (either (const Nothing) $ getEvidenceTree _rm) ns + evNs = concatMap (map (Right . evidenceVar) . T.flatten) evTrees +#else + evNs = [] +#endif zeroPos = Position 0 0 zeroRange = Range zeroPos zeroPos +<<<<<<< HEAD modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports in fmap (nubOrd . concat) $ mapMaybeM (either (pure . modToLocation) $ nameToLocation withHieDb lookupModule) ns +||||||| parent of dc807c4a (Jump to instance definition and explain typeclass evidence) + modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports + in fmap (nubOrd . concat) $ mapMaybeM (either (pure . modToLocation) $ nameToLocation hiedb lookupModule) ns +======= + modToLocation m = (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) <$> M.lookup m imports + in nubOrd . concat <$> mapMaybeM (either (pure . modToLocation) $ nameToLocation hiedb lookupModule) (ns ++ evNs) +>>>>>>> dc807c4a (Jump to instance definition and explain typeclass evidence) -- | Given a 'Name' attempt to find the location where it is defined. nameToLocation :: MonadIO m => WithHieDb -> LookupModule m -> Name -> m (Maybe [Location]) From c14ceb373d3edaa80214cb17f28eaab48eb6930c Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 3 Jul 2021 17:17:46 +0530 Subject: [PATCH 2/3] improve hover rendering --- ghcide/src/Development/IDE/Spans/AtPoint.hs | 71 +++++++-------------- 1 file changed, 24 insertions(+), 47 deletions(-) diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index b2a641e59d..a2ba354dea 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -179,14 +179,18 @@ documentHighlight hf rf pos = pure highlights highlights = do n <- ns ref <- fromMaybe [] (M.lookup (Right n) rf) - pure $ makeHighlight ref - makeHighlight (sp,dets) = - DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets) + maybeToList (makeHighlight n ref) + makeHighlight n (sp,dets) + | isTvNameSpace (nameNameSpace n) && isBadSpan n sp = Nothing + | otherwise = Just $ DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets) highlightType s = if any (isJust . getScopeFromContext) s then HkWrite else HkRead + isBadSpan :: Name -> RealSrcSpan -> Bool + isBadSpan n sp = srcSpanStartLine sp /= srcSpanEndLine sp || (srcSpanEndCol sp - srcSpanStartCol sp > lengthFS (occNameFS $ nameOccName n)) + gotoTypeDefinition :: MonadIO m => WithHieDb @@ -290,30 +294,29 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) _rf _ kind) (DKMap dm km) env pos renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) [x]) = renderEvidenceTree x renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_), ..}) xs) - = hang (text "- Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $ - vcat $ text "depending on:" : map renderEvidenceTree' xs - renderEvidenceTree x = renderEvidenceTree' x + = hang (text "Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $ + vcat $ text "constructed using:" : map renderEvidenceTree' xs + renderEvidenceTree (T.Node (EvidenceInfo{..}) _) + = hang (text "Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $ + vcat $ printDets evidenceSpan evidenceDetails : map (text . T.unpack) (definedAt evidenceVar) -- renderEvidenceTree' skips let bound evidence variables and prints the children directly renderEvidenceTree' (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) xs) = vcat (map renderEvidenceTree' xs) - renderEvidenceTree' (T.Node (EvidenceInfo{..}) xs) - = hang (text "- Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $ - vcat $ map (text . T.unpack) (definedAt evidenceVar) - ++ [printDets evidenceSpan evidenceDetails (null xs)] - ++ map renderEvidenceTree' xs - - printDets :: RealSrcSpan -> Maybe (EvVarSource, Scope, Maybe Span) -> Bool -> SDoc - printDets _ Nothing True = text "" - printDets _ Nothing False = text "constructed using:" - printDets ospn (Just (src,_,mspn)) _ = pprSrc + renderEvidenceTree' (T.Node (EvidenceInfo{..}) _) + = hang (text "- `" O.<> expandType evidenceType O.<> "`") 2 $ + vcat $ printDets evidenceSpan evidenceDetails : map (text . T.unpack) (definedAt evidenceVar) + + printDets :: RealSrcSpan -> Maybe (EvVarSource, Scope, Maybe Span) -> SDoc + printDets _ Nothing = text "using an external instance" + printDets ospn (Just (src,_,mspn)) = pprSrc $$ text "at" <+> ppr spn where -- Use the bind span if we have one, else use the occurence span spn = fromMaybe ospn mspn pprSrc = case src of -- Users don't know what HsWrappers are - EvWrapperBind -> "bound by type signature or pattern" + EvWrapperBind -> "bound by a context" _ -> ppr src #endif @@ -352,24 +355,12 @@ typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKi HQualTy a b -> getTypes [a,b] HCastTy a -> getTypes [a] _ -> [] -<<<<<<< HEAD - in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts) -||||||| parent of dc807c4a (Jump to instance definition and explain typeclass evidence) - in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) -======= - in nubOrd <$> concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) ->>>>>>> dc807c4a (Jump to instance definition and explain typeclass evidence) + in nubOrd <$> concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts) HieFresh -> let ts = concat $ pointCommand ast pos getts getts x = nodeType ni ++ mapMaybe identType (M.elems $ nodeIdentifiers ni) where ni = nodeInfo x -<<<<<<< HEAD - in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts) -||||||| parent of dc807c4a (Jump to instance definition and explain typeclass evidence) - in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) -======= - in nubOrd <$> concatMapM (fmap (fromMaybe []) . nameToLocation hiedb lookupModule) (getTypes ts) ->>>>>>> dc807c4a (Jump to instance definition and explain typeclass evidence) + in nubOrd <$> concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts) namesInType :: Type -> [Name] namesInType (TyVarTy n) = [varName n] @@ -394,13 +385,7 @@ locationsAtPoint -> Position -> HieAstResult -> m [Location] -<<<<<<< HEAD -locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast = -||||||| parent of dc807c4a (Jump to instance definition and explain typeclass evidence) -locationsAtPoint hiedb lookupModule _ideOptions imports pos ast = -======= -locationsAtPoint hiedb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) = ->>>>>>> dc807c4a (Jump to instance definition and explain typeclass evidence) +locationsAtPoint withHieDb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) = let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) #if MIN_VERSION_ghc(9,0,1) evTrees = mapMaybe (either (const Nothing) $ getEvidenceTree _rm) ns @@ -410,16 +395,8 @@ locationsAtPoint hiedb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) #endif zeroPos = Position 0 0 zeroRange = Range zeroPos zeroPos -<<<<<<< HEAD - modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports - in fmap (nubOrd . concat) $ mapMaybeM (either (pure . modToLocation) $ nameToLocation withHieDb lookupModule) ns -||||||| parent of dc807c4a (Jump to instance definition and explain typeclass evidence) - modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports - in fmap (nubOrd . concat) $ mapMaybeM (either (pure . modToLocation) $ nameToLocation hiedb lookupModule) ns -======= modToLocation m = (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) <$> M.lookup m imports - in nubOrd . concat <$> mapMaybeM (either (pure . modToLocation) $ nameToLocation hiedb lookupModule) (ns ++ evNs) ->>>>>>> dc807c4a (Jump to instance definition and explain typeclass evidence) + in nubOrd . concat <$> mapMaybeM (either (pure . modToLocation) $ nameToLocation withHieDb lookupModule) (ns ++ evNs) -- | Given a 'Name' attempt to find the location where it is defined. nameToLocation :: MonadIO m => WithHieDb -> LookupModule m -> Name -> m (Maybe [Location]) From 8a7299760acda1beb54544d8cfe694df5539ec69 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Thu, 6 Oct 2022 15:54:51 +0530 Subject: [PATCH 3/3] fixes --- ghcide/src/Development/IDE/Spans/AtPoint.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index a2ba354dea..c62044e2fd 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -57,7 +57,8 @@ import HieDb hiding (pointCommand) import System.Directory (doesFileExist) #if MIN_VERSION_ghc(9,0,1) -import qualified Outputable as O +import qualified GHC.Utils.Outputable as O +import GHC.Data.FastString (lengthFS) import Data.Tree import qualified Data.Tree as T import Data.List (isSuffixOf, sortOn) @@ -298,14 +299,14 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) _rf _ kind) (DKMap dm km) env pos vcat $ text "constructed using:" : map renderEvidenceTree' xs renderEvidenceTree (T.Node (EvidenceInfo{..}) _) = hang (text "Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $ - vcat $ printDets evidenceSpan evidenceDetails : map (text . T.unpack) (definedAt evidenceVar) + vcat $ printDets evidenceSpan evidenceDetails : map (text . T.unpack) (maybeToList $ definedAt evidenceVar) -- renderEvidenceTree' skips let bound evidence variables and prints the children directly renderEvidenceTree' (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) xs) = vcat (map renderEvidenceTree' xs) renderEvidenceTree' (T.Node (EvidenceInfo{..}) _) = hang (text "- `" O.<> expandType evidenceType O.<> "`") 2 $ - vcat $ printDets evidenceSpan evidenceDetails : map (text . T.unpack) (definedAt evidenceVar) + vcat $ printDets evidenceSpan evidenceDetails : map (text . T.unpack) (maybeToList $ definedAt evidenceVar) printDets :: RealSrcSpan -> Maybe (EvVarSource, Scope, Maybe Span) -> SDoc printDets _ Nothing = text "using an external instance"