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..c62044e2fd 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,16 @@ import Development.IDE.Types.Shake (WithHieDb) import HieDb hiding (pointCommand) import System.Directory (doesFileExist) +#if MIN_VERSION_ghc(9,0,1) +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) +#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 @@ -171,14 +180,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 @@ -197,7 +210,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 +224,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 +237,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 +272,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 +286,42 @@ 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 "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) (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) (maybeToList $ 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 a context" + _ -> ppr src +#endif + + typeLocationsAtPoint :: forall m . MonadIO m @@ -276,7 +337,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 +356,12 @@ typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKi HQualTy a b -> getTypes [a,b] HCastTy a -> getTypes [a] _ -> [] - in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts) + 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) + getts x = nodeType ni ++ mapMaybe identType (M.elems $ nodeIdentifiers ni) where ni = nodeInfo x - in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts) + in nubOrd <$> concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts) namesInType :: Type -> [Name] namesInType (TyVarTy n) = [varName n] @@ -313,24 +374,30 @@ 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] -locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast = +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 + evNs = concatMap (map (Right . evidenceVar) . T.flatten) evTrees +#else + evNs = [] +#endif zeroPos = Position 0 0 zeroRange = Range zeroPos zeroPos - 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 + modToLocation m = (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) <$> M.lookup m imports + 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])