From a86d5fff60589b43d8afa3d64705769ceeeb569b Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 26 Jun 2021 19:17:15 +0530 Subject: [PATCH 1/8] Jump to instance definition and explain typeclass evidence --- ghcide/src/Development/IDE/Core/Actions.hs | 2 +- ghcide/src/Development/IDE/Spans/AtPoint.hs | 92 ++++++++++++++++++--- 2 files changed, 80 insertions(+), 14 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 20c86c8280..12945b59cd 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -98,7 +98,7 @@ getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [(Location, getDefinition file pos = runMaybeT $ do ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask opts <- liftIO $ getIdeOptionsIO ide - (HAR _ hf _ _ _, mapping) <- useWithStaleFastMT GetHieAst file + (hf, mapping) <- useWithStaleFastMT GetHieAst file (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) locationsWithIdentifier <- 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 88c6570b23..c87d3f4332 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -52,11 +52,14 @@ 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.List (isSuffixOf, sortOn) +import Data.Tree +import qualified Data.Tree as T import Data.Version (showVersion) import Development.IDE.Types.Shake (WithHieDb) +import qualified GHC.Utils.Outputable as O import HieDb hiding (pointCommand, withHieDb) import System.Directory (doesFileExist) @@ -198,7 +201,7 @@ gotoDefinition -> LookupModule m -> IdeOptions -> M.Map ModuleName NormalizedFilePath - -> HieASTs a + -> HieAstResult -> Position -> MaybeT m [(Location, Identifier)] gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos @@ -212,7 +215,7 @@ atPoint -> HscEnv -> Position -> IO (Maybe (Maybe Range, [T.Text])) -atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env pos = +atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (DKMap dm km) env pos = listToMaybe <$> sequence (pointCommand hf pos hoverInfo) where -- Hover info for values/data @@ -236,7 +239,7 @@ atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env info = nodeInfoH kind ast names :: [(Identifier, IdentifierDetails hietype)] - names = M.assocs $ nodeIdentifiers info + names = sortOn (any isEvidenceUse . identInfo . snd) $ M.assocs $ nodeIdentifiers info -- Check for evidence bindings isInternal :: (Identifier, IdentifierDetails a) -> Bool @@ -248,11 +251,14 @@ atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env filteredNames = filter (not . isInternal) names prettyName :: (Either ModuleName Name, IdentifierDetails hietype) -> IO T.Text - prettyName (Right n, dets) = pure $ T.unlines $ - wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) - : maybeToList (pretty (definedAt n) (prettyPackageName n)) - ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n - ] + prettyName (Right n, dets) + | any isEvidenceUse (identInfo dets) = + pure $ maybe "" (printOutputable . renderEvidenceTree) (getEvidenceTree rf n) <> "\n" + | otherwise = pure $ T.unlines $ + wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) + : maybeToList (pretty (definedAt n) (prettyPackageName n)) + ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n + ] where maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n pretty Nothing Nothing = Nothing pretty (Just define) Nothing = Just $ define <> "\n" @@ -298,6 +304,12 @@ atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env 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 -> Maybe T.Text definedAt name = @@ -307,6 +319,40 @@ atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env UnhelpfulLoc {} | isInternalName name || isSystemName name -> Nothing _ -> Just $ "*Defined " <> printOutputable (pprNameDefnLoc name) <> "*" + -- 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) (maybeToList $ 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 + -- | Find 'Location's of type definition at a specific point and return them along with their 'Identifier's. typeLocationsAtPoint :: forall m @@ -323,7 +369,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] @@ -337,7 +383,7 @@ typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKi in fmap nubOrd $ concatMapM (\n -> fmap (maybe [] (fmap (,Right n))) (nameToLocation withHieDb lookupModule n)) (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 (\n -> fmap (maybe [] (fmap (,Right n))) (nameToLocation withHieDb lookupModule n)) (getTypes ts) @@ -352,28 +398,48 @@ namesInType (LitTy _) = [] namesInType _ = [] getTypes :: [Type] -> [Name] -getTypes ts = concatMap namesInType ts +getTypes = concatMap namesInType -- | Find 'Location's of definition at a specific point and return them along with their 'Identifier's. locationsAtPoint - :: forall m a + :: forall m . MonadIO m => WithHieDb -> LookupModule m -> IdeOptions -> M.Map ModuleName NormalizedFilePath -> Position +<<<<<<< HEAD -> HieASTs a -> m [(Location, Identifier)] locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast = +||||||| parent of 86ebcf859 (Jump to instance definition and explain typeclass evidence) + -> HieASTs a + -> m [Location] +locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast = +======= + -> HieAstResult + -> m [Location] +locationsAtPoint withHieDb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) = +>>>>>>> 86ebcf859 (Jump to instance definition and explain typeclass evidence) let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) + evTrees = mapMaybe (either (const Nothing) $ getEvidenceTree _rm) ns + evNs = concatMap (map (Right . evidenceVar) . T.flatten) evTrees 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 (\m -> pure ((fmap $ fmap (,Left m)) (modToLocation m))) (\n -> fmap (fmap $ fmap (,Right n)) (nameToLocation withHieDb lookupModule n))) ns +||||||| parent of 86ebcf859 (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 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) +>>>>>>> 86ebcf859 (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 fdba4e5951d820491b32ba149aed73a4f3e22c22 Mon Sep 17 00:00:00 2001 From: Zubin Duggal Date: Sat, 3 Jul 2021 17:17:46 +0530 Subject: [PATCH 2/8] improve hover rendering --- ghcide/src/Development/IDE/Spans/AtPoint.hs | 62 +++++++++------------ 1 file changed, 25 insertions(+), 37 deletions(-) diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index c87d3f4332..4dca1cba7b 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -23,6 +23,10 @@ module Development.IDE.Spans.AtPoint ( , LookupModule ) where + +import GHC.Data.FastString (lengthFS) +import qualified GHC.Utils.Outputable as O + import Development.IDE.GHC.Error import Development.IDE.GHC.Orphans () import Development.IDE.Types.Location @@ -59,7 +63,6 @@ import Data.Tree import qualified Data.Tree as T import Data.Version (showVersion) import Development.IDE.Types.Shake (WithHieDb) -import qualified GHC.Utils.Outputable as O import HieDb hiding (pointCommand, withHieDb) import System.Directory (doesFileExist) @@ -174,14 +177,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 DocumentHighlightKind_Write else DocumentHighlightKind_Read + isBadSpan :: Name -> RealSrcSpan -> Bool + isBadSpan n sp = srcSpanStartLine sp /= srcSpanEndLine sp || (srcSpanEndCol sp - srcSpanStartCol sp > lengthFS (occNameFS $ nameOccName n)) + -- | Locate the type definition of the name at a given position. gotoTypeDefinition :: MonadIO m @@ -327,23 +334,22 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D 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) (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{..}) xs) - = hang (text "- Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $ - vcat $ map (text . T.unpack) (maybeToList $ 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) (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 @@ -409,37 +415,19 @@ locationsAtPoint -> IdeOptions -> M.Map ModuleName NormalizedFilePath -> Position -<<<<<<< HEAD - -> HieASTs a - -> m [(Location, Identifier)] -locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast = -||||||| parent of 86ebcf859 (Jump to instance definition and explain typeclass evidence) - -> HieASTs a - -> m [Location] -locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast = -======= -> HieAstResult - -> m [Location] + -> m [(Location, Identifier)] locationsAtPoint withHieDb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) = ->>>>>>> 86ebcf859 (Jump to instance definition and explain typeclass evidence) let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) evTrees = mapMaybe (either (const Nothing) $ getEvidenceTree _rm) ns evNs = concatMap (map (Right . evidenceVar) . T.flatten) evTrees 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 (\m -> pure ((fmap $ fmap (,Left m)) (modToLocation m))) (\n -> fmap (fmap $ fmap (,Right n)) (nameToLocation withHieDb lookupModule n))) - ns -||||||| parent of 86ebcf859 (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 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) ->>>>>>> 86ebcf859 (Jump to instance definition and explain typeclass evidence) + (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 dc997a9971d75e0c00a6d19c99841dc422919ce3 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 17 Aug 2024 14:54:00 +0200 Subject: [PATCH 3/8] Add "Goto Implementation" LSP handler Adds the necessary instances for handling the request type `Method_TextDocumentImplementation`. Further, wire up the appropriate handlers for the "gotoImplementation" request. --- ghcide/src/Development/IDE/Core/Actions.hs | 10 +++ .../Development/IDE/LSP/HoverDefinition.hs | 7 +- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 2 + ghcide/src/Development/IDE/Spans/AtPoint.hs | 66 ++++++++++++------- .../test/exe/FindDefinitionAndHoverTests.hs | 23 ++++++- ghcide/test/exe/InitializeResponseTests.hs | 4 +- hls-plugin-api/src/Ide/Types.hs | 8 +++ 7 files changed, 92 insertions(+), 28 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 12945b59cd..0d55a73120 100644 --- a/ghcide/src/Development/IDE/Core/Actions.hs +++ b/ghcide/src/Development/IDE/Core/Actions.hs @@ -3,6 +3,7 @@ module Development.IDE.Core.Actions ( getAtPoint , getDefinition , getTypeDefinition +, getImplementationDefinition , highlightAtPoint , refsAtPoint , workspaceSymbols @@ -120,6 +121,15 @@ getTypeDefinition file pos = runMaybeT $ do pure $ Just (fixedLocation, identifier) ) locationsWithIdentifier +getImplementationDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location]) +getImplementationDefinition file pos = runMaybeT $ do + ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask + opts <- liftIO $ getIdeOptionsIO ide + (hf, mapping) <- useWithStaleFastMT GetHieAst file + !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) + locs <- AtPoint.gotoImplementation withHieDb (lookupMod hiedbWriter) opts hf pos' + traverse (MaybeT . toCurrentLocation mapping file) locs + highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight]) highlightAtPoint file pos = runMaybeT $ do (HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst file diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs index 3211d98b5c..0ba6e22530 100644 --- a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs +++ b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs @@ -10,6 +10,7 @@ module Development.IDE.LSP.HoverDefinition , foundHover , gotoDefinition , gotoTypeDefinition + , gotoImplementation , documentHighlight , references , wsSymbols @@ -47,9 +48,11 @@ instance Pretty Log where gotoDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentDefinition) hover :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (Hover |? Null) gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentTypeDefinition) +gotoImplementation :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentImplementation) documentHighlight :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) ([DocumentHighlight] |? Null) -gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR . map fst) -gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR . map fst) +gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition . InR . map fst) +gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition . InR . map fst) +gotoImplementation = request "Implementation" getImplementationDefinition (InR $ InR Null) (InL . Definition . InR) hover = request "Hover" getAtPoint (InR Null) foundHover documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs index ec5c6bf84b..ada0f9e682 100644 --- a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs +++ b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs @@ -51,6 +51,8 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) Hover.gotoDefinition recorder ide TextDocumentPositionParams{..}) <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} -> Hover.gotoTypeDefinition recorder ide TextDocumentPositionParams{..}) + <> mkPluginHandler SMethod_TextDocumentImplementation (\ide _ ImplementationParams{..} -> + Hover.gotoImplementation recorder ide TextDocumentPositionParams{..}) <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> Hover.documentHighlight recorder ide TextDocumentPositionParams{..}) <> mkPluginHandler SMethod_TextDocumentReferences (Hover.references recorder) diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 4dca1cba7b..ee59883dcd 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -10,6 +10,7 @@ module Development.IDE.Spans.AtPoint ( atPoint , gotoDefinition , gotoTypeDefinition + , gotoImplementation , documentHighlight , pointCommand , referencesAtPoint @@ -58,6 +59,8 @@ import qualified Data.Array as A import Data.Either import Data.List.Extra (dropEnd1, nubOrd) + +import Data.Either.Extra (eitherToMaybe) import Data.List (isSuffixOf, sortOn) import Data.Tree import qualified Data.Tree as T @@ -214,6 +217,19 @@ gotoDefinition gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos = lift $ locationsAtPoint withHieDb getHieFile ideOpts imports pos srcSpans +-- | Locate the implementation definition of the name at a given position. +-- Goto Implementation for an overloaded function. +gotoImplementation + :: MonadIO m + => WithHieDb + -> LookupModule m + -> IdeOptions + -> HieAstResult + -> Position + -> MaybeT m [Location] +gotoImplementation withHieDb getHieFile ideOpts srcSpans pos + = lift $ instanceLocationsAtPoint withHieDb getHieFile ideOpts pos srcSpans + -- | Synopsis for the name at a given position. atPoint :: IdeOptions @@ -228,7 +244,7 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D -- Hover info for values/data hoverInfo :: HieAST hietype -> IO (Maybe Range, [T.Text]) hoverInfo ast = do - prettyNames <- mapM prettyName filteredNames + prettyNames <- mapM prettyName names pure (Just range, prettyNames ++ pTypes) where pTypes :: [T.Text] @@ -245,27 +261,20 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D info :: NodeInfo hietype info = nodeInfoH kind ast + -- We want evidence variables to be displayed last. + -- Evidence trees contain information of secondary relevance. names :: [(Identifier, IdentifierDetails hietype)] names = sortOn (any isEvidenceUse . identInfo . snd) $ M.assocs $ nodeIdentifiers info - -- Check for evidence bindings - isInternal :: (Identifier, IdentifierDetails a) -> Bool - isInternal (Right _, dets) = - any isEvidenceContext $ identInfo dets - isInternal (Left _, _) = False - - filteredNames :: [(Identifier, IdentifierDetails hietype)] - filteredNames = filter (not . isInternal) names - prettyName :: (Either ModuleName Name, IdentifierDetails hietype) -> IO T.Text prettyName (Right n, dets) - | any isEvidenceUse (identInfo dets) = - pure $ maybe "" (printOutputable . renderEvidenceTree) (getEvidenceTree rf n) <> "\n" + -- We want to print evidence variable using a readable tree structure. + | any isEvidenceUse (identInfo dets) = pure $ maybe "" (printOutputable . renderEvidenceTree) (getEvidenceTree rf n) <> "\n" | otherwise = pure $ T.unlines $ wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) : maybeToList (pretty (definedAt n) (prettyPackageName n)) ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n - ] + ] where maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n pretty Nothing Nothing = Nothing pretty (Just define) Nothing = Just $ define <> "\n" @@ -299,7 +308,7 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D version = T.pack $ showVersion (unitPackageVersion conf) pure $ pkgName <> "-" <> version - -- Type info for the current node, it may contains several symbols + -- Type info for the current node, it may contain several symbols -- for one range, like wildcard types :: [hietype] types = nodeType info @@ -308,10 +317,7 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D prettyTypes = map (("_ :: "<>) . prettyType) types prettyType :: hietype -> T.Text - prettyType t = case kind of - HieFresh -> printOutputable t - HieFromDisk full_file -> printOutputable $ hieTypeToIface $ recoverFullType t (hie_types full_file) - -- prettyType = printOutputable . expandType + prettyType = printOutputable . expandType expandType :: a -> SDoc expandType t = case kind of @@ -352,7 +358,7 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D printDets ospn (Just (src,_,mspn)) = pprSrc $$ text "at" <+> ppr spn where - -- Use the bind span if we have one, else use the occurence span + -- Use the bind span if we have one, else use the occurrence span spn = fromMaybe ospn mspn pprSrc = case src of -- Users don't know what HsWrappers are @@ -419,15 +425,31 @@ locationsAtPoint -> m [(Location, Identifier)] locationsAtPoint withHieDb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) = let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) - evTrees = mapMaybe (either (const Nothing) $ getEvidenceTree _rm) ns - evNs = concatMap (map (Right . evidenceVar) . T.flatten) evTrees 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 (\m -> pure ((fmap $ fmap (,Left m)) (modToLocation m))) (\n -> fmap (fmap $ fmap (,Right n)) (nameToLocation withHieDb lookupModule n))) - (ns ++ evNs) + ns + +-- | Find 'Location's of a implementation definition at a specific point. +instanceLocationsAtPoint + :: forall m + . MonadIO m + => WithHieDb + -> LookupModule m + -> IdeOptions + -> Position + -> HieAstResult + -> m [Location] +instanceLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _rm _ _) = + let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) + evTrees = mapMaybe (eitherToMaybe >=> getEvidenceTree _rm) ns + evNs = concatMap (map (evidenceVar) . T.flatten) evTrees + in fmap (nubOrd . concat) $ mapMaybeM + (nameToLocation withHieDb lookupModule) + evNs -- | Given a 'Name' attempt to find the location where it is defined. nameToLocation :: MonadIO m => WithHieDb -> LookupModule m -> Name -> m (Maybe [Location]) diff --git a/ghcide/test/exe/FindDefinitionAndHoverTests.hs b/ghcide/test/exe/FindDefinitionAndHoverTests.hs index 66115c16ae..dbca38c681 100644 --- a/ghcide/test/exe/FindDefinitionAndHoverTests.hs +++ b/ghcide/test/exe/FindDefinitionAndHoverTests.hs @@ -13,6 +13,7 @@ import Language.LSP.Test import System.Info.Extra (isWindows) import Config +import Control.Category ((>>>)) import Control.Lens ((^.)) import Development.IDE.Test (expectDiagnostics, standardizeQuotes) @@ -53,7 +54,27 @@ tests = let _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover extractLineColFromHoverMsg :: T.Text -> [T.Text] - extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":") + extractLineColFromHoverMsg = + -- Hover messages contain multiple lines, and we are looking for the definition + -- site + T.lines + -- The line we are looking for looks like: "*Defined at /tmp/GotoHover.hs:22:3*" + -- So filter by the start of the line + >>> mapMaybe (T.stripPrefix "*Defined at") + -- There can be multiple definitions per hover message! + -- See the test "field in record definition" for example. + -- The tests check against the last line that contains the above line. + >>> last + -- [" /tmp/", "22:3*"] + >>> T.splitOn (sourceFileName <> ":") + -- "22:3*" + >>> last + -- ["22:3", ""] + >>> T.splitOn "*" + -- "22:3" + >>> head + -- ["22", "3"] + >>> T.splitOn ":" checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () checkHoverRange expectedRange rangeInHover msg = diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs index 6192a8aeed..f13344e368 100644 --- a/ghcide/test/exe/InitializeResponseTests.hs +++ b/ghcide/test/exe/InitializeResponseTests.hs @@ -33,9 +33,7 @@ tests = withResource acquire release tests where , chk "NO signature help" _signatureHelpProvider Nothing , chk " goto definition" _definitionProvider (Just $ InR (DefinitionOptions (Just False))) , chk " goto type definition" _typeDefinitionProvider (Just $ InR (InL (TypeDefinitionOptions (Just False)))) - -- BUG in lsp-test, this test fails, just change the accepted response - -- for now - , chk "NO goto implementation" _implementationProvider Nothing + , chk " goto implementation" _implementationProvider (Just $ InR (InL (ImplementationOptions (Just False)))) , chk " find references" _referencesProvider (Just $ InR (ReferenceOptions (Just False))) , chk " doc highlight" _documentHighlightProvider (Just $ InR (DocumentHighlightOptions (Just False))) , chk " doc symbol" _documentSymbolProvider (Just $ InR (DocumentSymbolOptions (Just False) Nothing)) diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs index b77c5404fc..c84fe15345 100644 --- a/hls-plugin-api/src/Ide/Types.hs +++ b/hls-plugin-api/src/Ide/Types.hs @@ -503,6 +503,9 @@ instance PluginMethod Request Method_TextDocumentDefinition where instance PluginMethod Request Method_TextDocumentTypeDefinition where handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc +instance PluginMethod Request Method_TextDocumentImplementation where + handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc + instance PluginMethod Request Method_TextDocumentDocumentHighlight where handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc @@ -696,6 +699,11 @@ instance PluginRequestMethod Method_TextDocumentTypeDefinition where | Just (Just True) <- caps ^? (L.textDocument . _Just . L.typeDefinition . _Just . L.linkSupport) = foldl' mergeDefinitions x xs | otherwise = downgradeLinks $ foldl' mergeDefinitions x xs +instance PluginRequestMethod Method_TextDocumentImplementation where + combineResponses _ _ caps _ (x :| xs) + | Just (Just True) <- caps ^? (L.textDocument . _Just . L.implementation . _Just . L.linkSupport) = foldl' mergeDefinitions x xs + | otherwise = downgradeLinks $ foldl' mergeDefinitions x xs + instance PluginRequestMethod Method_TextDocumentDocumentHighlight where instance PluginRequestMethod Method_TextDocumentReferences where From 267a00199d995f08a11f1db0615f3bd1cde5c4a5 Mon Sep 17 00:00:00 2001 From: Fendor Date: Fri, 18 Oct 2024 17:51:02 +0200 Subject: [PATCH 4/8] Add docs for 'Jump to Implementation' request --- docs/features.md | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/docs/features.md b/docs/features.md index 897552dff7..cb7e6ecde7 100644 --- a/docs/features.md +++ b/docs/features.md @@ -81,6 +81,16 @@ Known limitations: - Only works for [local definitions](https://github.com/haskell/haskell-language-server/issues/708). +## Jump to implementation + +Provided by: `ghcide` + +Jump to the implementation instance of a type class method. + +Known limitations: + +- Only works for [local definitions](https://github.com/haskell/haskell-language-server/issues/708). + ## Jump to note definition Provided by: `hls-notes-plugin` From 25f17fbe433cfbd560022ebb2d36f9d81481c1f6 Mon Sep 17 00:00:00 2001 From: Fendor Date: Tue, 15 Oct 2024 16:13:29 +0200 Subject: [PATCH 5/8] Add Tests for 'Goto Implementation' feature --- .hlint.yaml | 2 + ghcide/test/data/hover/GotoImplementation.hs | 30 ++ ghcide/test/data/hover/hie.yaml | 2 +- ghcide/test/exe/Config.hs | 3 + .../exe/FindImplementationAndHoverTests.hs | 269 ++++++++++++++++++ ghcide/test/exe/Main.hs | 4 +- haskell-language-server.cabal | 1 + 7 files changed, 309 insertions(+), 2 deletions(-) create mode 100644 ghcide/test/data/hover/GotoImplementation.hs create mode 100644 ghcide/test/exe/FindImplementationAndHoverTests.hs diff --git a/.hlint.yaml b/.hlint.yaml index 0bf0e0a313..edc6886871 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -110,6 +110,7 @@ - CompletionTests #Previously part of GHCIDE Main tests - DiagnosticTests #Previously part of GHCIDE Main tests - FindDefinitionAndHoverTests #Previously part of GHCIDE Main tests + - FindImplementationAndHoverTests #Previously part of GHCIDE Main tests - TestUtils #Previously part of GHCIDE Main tests - CodeLensTests #Previously part of GHCIDE Main tests @@ -134,6 +135,7 @@ - Ide.Plugin.Eval.Parse.Comments - Ide.Plugin.Eval.CodeLens - FindDefinitionAndHoverTests #Previously part of GHCIDE Main tests + - FindImplementationAndHoverTests #Previously part of GHCIDE Main tests - name: [Prelude.init, Data.List.init] within: diff --git a/ghcide/test/data/hover/GotoImplementation.hs b/ghcide/test/data/hover/GotoImplementation.hs new file mode 100644 index 0000000000..12038857c6 --- /dev/null +++ b/ghcide/test/data/hover/GotoImplementation.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE GADTs, GeneralisedNewtypeDeriving, DerivingStrategies #-} +{-# OPTIONS_GHC -Wno-missing-methods #-} +module GotoImplementation where + +data AAA = AAA +instance Num AAA where +aaa :: Num x => x +aaa = 1 +aaa1 :: AAA = aaa + +class BBB a where + bbb :: a -> a +instance BBB AAA where + bbb = const AAA +bbbb :: AAA +bbbb = bbb AAA + +ccc :: Show a => a -> String +ccc d = show d + +newtype Q k = Q k + deriving newtype (Eq, Show) +ddd :: (Show k, Eq k) => k -> String +ddd k = if Q k == Q k then show k else "" +ddd1 = ddd (Q 0) + +data GadtTest a where + GadtTest :: Int -> GadtTest Int +printUsingEvidence :: Show a => GadtTest a -> String +printUsingEvidence (GadtTest i) = show i diff --git a/ghcide/test/data/hover/hie.yaml b/ghcide/test/data/hover/hie.yaml index e2b3e97c5d..de7cc991cc 100644 --- a/ghcide/test/data/hover/hie.yaml +++ b/ghcide/test/data/hover/hie.yaml @@ -1 +1 @@ -cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}} +cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax", "GotoImplementation"]}} diff --git a/ghcide/test/exe/Config.hs b/ghcide/test/exe/Config.hs index 56e9af103a..75e33d3579 100644 --- a/ghcide/test/exe/Config.hs +++ b/ghcide/test/exe/Config.hs @@ -110,6 +110,7 @@ data Expect | ExpectHoverTextRegex T.Text -- the hover message must match this pattern | ExpectExternFail -- definition lookup in other file expected to fail | ExpectNoDefinitions + | ExpectNoImplementations | ExpectNoHover -- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples deriving Eq @@ -134,6 +135,8 @@ checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpecta canonActualLoc <- canonicalizeLocation def canonExpectedLoc <- canonicalizeLocation expectedLocation canonActualLoc @?= canonExpectedLoc + check ExpectNoImplementations = do + liftIO $ assertBool "Expecting no implementations" $ null defs check ExpectNoDefinitions = do liftIO $ assertBool "Expecting no definitions" $ null defs check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file" diff --git a/ghcide/test/exe/FindImplementationAndHoverTests.hs b/ghcide/test/exe/FindImplementationAndHoverTests.hs new file mode 100644 index 0000000000..0bbc400e34 --- /dev/null +++ b/ghcide/test/exe/FindImplementationAndHoverTests.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module FindImplementationAndHoverTests (tests) where + +import Control.Monad +import Data.Foldable +import Data.Maybe +import qualified Data.Text as T +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Test +import Text.Regex.TDFA ((=~)) + +import Config +import Control.Category ((>>>)) +import Control.Lens ((^.)) +import Data.Text (Text) +import Development.IDE.Test (standardizeQuotes) +import Test.Hls +import Test.Hls.FileSystem (copyDir) + +tests :: TestTree +tests = let + tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree + tst (get, check) pos sfp targetRange title = + testWithDummyPlugin title (mkIdeTestFs [copyDir "hover"]) $ do + doc <- openDoc sfp "haskell" + waitForProgressDone + _x <- waitForTypecheck doc + found <- get doc pos + check found targetRange + + checkHover :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session () + checkHover hover expectations = traverse_ check =<< expectations where + + check :: (HasCallStack) => Expect -> Session () + check expected = + case hover of + Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" + Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> 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 + ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets + ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool) + 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 + + extractLineColFromHoverMsg :: T.Text -> [T.Text] + extractLineColFromHoverMsg = + -- Hover messages contain multiple lines, and we are looking for the definition + -- site + T.lines + -- The line we are looking for looks like: "*Defined at /tmp/GotoHover.hs:22:3*" + -- So filter by the start of the line + >>> mapMaybe (T.stripPrefix "*Defined at") + -- There can be multiple definitions per hover message! + -- See the test "field in record definition" for example. + -- The tests check against the last line that contains the above line. + >>> last + -- [" /tmp/", "22:3*"] + >>> T.splitOn (sourceFileName <> ":") + -- "22:3*" + >>> last + -- ["22:3", ""] + >>> T.splitOn "*" + -- "22:3" + >>> head + -- ["22", "3"] + >>> T.splitOn ":" + + checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () + checkHoverRange expectedRange rangeInHover msg = + let + lineCol = extractLineColFromHoverMsg msg + -- looks like hovers use 1-based numbering while definitions use 0-based + -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. + adjust Position{_line = l, _character = c} = + Position{_line = l + 1, _character = c + 1} + in + case map (read . T.unpack) lineCol of + [l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c + _ -> liftIO $ assertFailure $ + "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> + "\n but got: " <> show (msg, rangeInHover) + + assertFoundIn :: T.Text -> T.Text -> Assertion + assertFoundIn part whole = assertBool + (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) + (part `T.isInfixOf` whole) + + assertNotFoundIn :: T.Text -> T.Text -> Assertion + assertNotFoundIn part whole = assertBool + (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole) + (not . T.isInfixOf part $ whole) + + sourceFilePath = T.unpack sourceFileName + sourceFileName = "GotoImplementation.hs" + + mkFindTests tests = testGroup "goto implementation" + [ testGroup "implementation" $ mapMaybe fst allTests + , testGroup "hover" $ mapMaybe snd allTests + ] + where + allTests = tests ++ recordDotSyntaxTests + + recordDotSyntaxTests = + -- We get neither new hover information nor 'Goto Implementation' locations for record-dot-syntax + [ test' "RecordDotSyntax.hs" yes yes (Position 17 6) [ExpectNoImplementations, ExpectHoverText ["_ :: [Char]"]] "hover over parent" + , test' "RecordDotSyntax.hs" yes yes (Position 17 18) [ExpectNoImplementations, ExpectHoverText ["_ :: Integer"]] "hover over dot shows child" + , test' "RecordDotSyntax.hs" yes yes (Position 17 25) [ExpectNoImplementations, ExpectHoverText ["_ :: MyChild"]] "hover over child" + , test' "RecordDotSyntax.hs" yes yes (Position 17 27) [ExpectNoImplementations, ExpectHoverText ["_ :: [Char]"]] "hover over grandchild" + ] + + test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b) + test runImpl runHover look expect = testM runImpl runHover look (return expect) + + testM :: (HasCallStack) => (TestTree -> a) + -> (TestTree -> b) + -> Position + -> Session [Expect] + -> String + -> (a, b) + testM = testM' sourceFilePath + + test' :: (HasCallStack) => FilePath -> (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b) + test' sourceFile runImpl runHover look expect = testM' sourceFile runImpl runHover look (return expect) + + testM' :: (HasCallStack) + => FilePath + -> (TestTree -> a) + -> (TestTree -> b) + -> Position + -> Session [Expect] + -> String + -> (a, b) + testM' sourceFile runImpl runHover look expect title = + ( runImpl $ tst impl look sourceFile expect title + , runHover $ tst hover look sourceFile expect title ) where + impl = (getImplementations, checkDefs) + hover = (getHover , checkHover) + + aaaL = Position 8 15; aaaR = mkRange 5 9 5 16; + aaa = + [ ExpectRanges [aaaR] + , ExpectHoverText (evidenceBoundByConstraint "Num" "AAA") + ] + + bbbL = Position 15 8; bbbR = mkRange 12 9 12 16; + bbb = + [ ExpectRanges [bbbR] + , ExpectHoverText (evidenceBoundByConstraint "BBB" "AAA") + ] + cccL = Position 18 11; + ccc = + [ ExpectNoImplementations + , ExpectHoverText (evidenceBySignatureOrPattern "Show" "a") + ] + dddShowR = mkRange 21 26 21 30; dddEqR = mkRange 21 22 21 24 + dddL1 = Position 23 16; + ddd1 = + [ ExpectRanges [dddEqR] + , ExpectHoverText + [ constraintEvidence "Eq" "(Q k)" + , evidenceGoal' "'forall k. Eq k => Eq (Q k)'" + , boundByInstanceOf "Eq" + , evidenceGoal "Eq" "k" + , boundByTypeSigOrPattern + ] + ] + dddL2 = Position 23 29; + ddd2 = + [ ExpectNoImplementations + , ExpectHoverText (evidenceBySignatureOrPattern "Show" "k") + ] + dddL3 = Position 24 8; + ddd3 = + [ ExpectRanges [dddEqR, dddShowR] + , ExpectHoverText + [ constraintEvidence "Show" "(Q Integer)" + , evidenceGoal' "'forall k. Show k => Show (Q k)'" + , boundByInstance + , evidenceGoal "Show" "Integer" + , usingExternalInstance + , constraintEvidence "Eq" "(Q Integer)" + , evidenceGoal' "'forall k. Eq k => Eq (Q k)'" + , boundByInstance + , evidenceGoal "Eq" "Integer" + , usingExternalInstance + ] + ] + gadtL = Position 29 35; + gadt = + [ ExpectNoImplementations + , ExpectHoverText + [ constraintEvidence "Show" "Int" + , evidenceGoal "Show" "a" + , boundByTypeSigOrPattern + , evidenceGoal' "'a ~ Int'" + , boundByPattern + ] + ] + in + mkFindTests + -- impl hover look expect + [ + test yes yes aaaL aaa "locally defined class instance" + , test yes yes bbbL bbb "locally defined class and instance" + , test yes yes cccL ccc "bound by type signature" + , test yes yes dddL1 ddd1 "newtype Eq evidence" + , test yes yes dddL2 ddd2 "Show evidence" + , test yes yes dddL3 ddd3 "evidence construction" + , test yes yes gadtL gadt "GADT evidence" + ] + where yes :: (TestTree -> Maybe TestTree) + yes = Just -- test should run and pass + no = const Nothing -- don't run this test at all + +-- ---------------------------------------------------------------------------- +-- Helper functions for creating hover message verification +-- ---------------------------------------------------------------------------- + +evidenceBySignatureOrPattern :: Text -> Text -> [Text] +evidenceBySignatureOrPattern tyclass varname = + [ constraintEvidence tyclass varname + , boundByTypeSigOrPattern + ] + +evidenceBoundByConstraint :: Text -> Text -> [Text] +evidenceBoundByConstraint tyclass varname = + [ constraintEvidence tyclass varname + , boundByInstanceOf tyclass + ] + +boundByTypeSigOrPattern :: Text +boundByTypeSigOrPattern = "bound by type signature or pattern" + +boundByInstance :: Text +boundByInstance = + "bound by an instance of" + +boundByInstanceOf :: Text -> Text +boundByInstanceOf tyvar = + "bound by an instance of class " <> tyvar + +boundByPattern :: Text +boundByPattern = + "bound by a pattern" + +usingExternalInstance :: Text +usingExternalInstance = + "using an external instance" + +constraintEvidence :: Text -> Text -> Text +constraintEvidence tyclass varname = "Evidence of constraint " <> quotedName tyclass varname + +-- | A goal in the evidence tree. +evidenceGoal :: Text -> Text -> Text +evidenceGoal tyclass varname = "- " <> quotedName tyclass varname + +evidenceGoal' :: Text -> Text +evidenceGoal' t = "- " <> t + +quotedName :: Text -> Text -> Text +quotedName tyclass varname = "'" <> tyclass <> " " <> varname <> "'" diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 6c8091840d..6bca4245be 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -45,12 +45,13 @@ import DependentFileTest import DiagnosticTests import ExceptionTests import FindDefinitionAndHoverTests +import FindImplementationAndHoverTests import GarbageCollectionTests import HaddockTests import HighlightTests import IfaceTests import InitializeResponseTests -import LogType () +import LogType () import NonLspCommandLine import OpenCloseTest import OutlineTests @@ -78,6 +79,7 @@ main = do , OutlineTests.tests , HighlightTests.tests , FindDefinitionAndHoverTests.tests + , FindImplementationAndHoverTests.tests , PluginSimpleTests.tests , PreprocessorTests.tests , THTests.tests diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 1f5fce4b5f..6f0aec554e 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -2186,6 +2186,7 @@ test-suite ghcide-tests DiagnosticTests ExceptionTests FindDefinitionAndHoverTests + FindImplementationAndHoverTests FuzzySearch GarbageCollectionTests HaddockTests From eed6ba421522de954d2154db502e391aad48d996 Mon Sep 17 00:00:00 2001 From: Fendor Date: Fri, 18 Oct 2024 19:06:20 +0200 Subject: [PATCH 6/8] Add pretty link for source location to hover --- ghcide/src/Development/IDE/Spans/AtPoint.hs | 8 +-- ghcide/src/Development/IDE/Spans/Common.hs | 56 ++++++++++++++++++--- 2 files changed, 54 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index ee59883dcd..7d4004fb7e 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -335,7 +335,7 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D -- 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, + -- However, if the root constraint is simply a expandType evidenceType O.<> "`") 2 $ - vcat $ printDets evidenceSpan evidenceDetails : map (text . T.unpack) (maybeToList $ 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" printDets ospn (Just (src,_,mspn)) = pprSrc - $$ text "at" <+> ppr spn + $$ text "at" <+> text (T.unpack $ srcSpanToMdLink location) where + location = realSrcSpanToLocation $ traceShowId spn -- Use the bind span if we have one, else use the occurrence span spn = fromMaybe ospn mspn pprSrc = case src of diff --git a/ghcide/src/Development/IDE/Spans/Common.hs b/ghcide/src/Development/IDE/Spans/Common.hs index e265a617f6..ee8a8c18bc 100644 --- a/ghcide/src/Development/IDE/Spans/Common.hs +++ b/ghcide/src/Development/IDE/Spans/Common.hs @@ -13,22 +13,26 @@ module Development.IDE.Spans.Common ( , spanDocToMarkdownForTest , DocMap , TyThingMap +, srcSpanToMdLink ) where import Control.DeepSeq +import Data.Bifunctor (second) import Data.List.Extra import Data.Maybe import qualified Data.Text as T -import GHC.Generics - +import Development.IDE.GHC.Util +import qualified Documentation.Haddock.Parser as H +import qualified Documentation.Haddock.Types as H import GHC +import GHC.Generics +import System.FilePath -import Data.Bifunctor (second) +import Control.Lens import Development.IDE.GHC.Compat import Development.IDE.GHC.Orphans () -import Development.IDE.GHC.Util -import qualified Documentation.Haddock.Parser as H -import qualified Documentation.Haddock.Types as H +import qualified Language.LSP.Protocol.Lens as JL +import Language.LSP.Protocol.Types type DocMap = NameEnv SpanDoc type TyThingMap = NameEnv TyThing @@ -109,7 +113,13 @@ spanDocUrisToMarkdown (SpanDocUris mdoc msrc) = catMaybes [ linkify "Documentation" <$> mdoc , linkify "Source" <$> msrc ] - where linkify title uri = "[" <> title <> "](" <> uri <> ")" + +-- | Generate a markdown link. +-- +-- >>> linkify "Title" "uri" +-- "[Title](Uri)" +linkify :: T.Text -> T.Text -> T.Text +linkify title uri = "[" <> title <> "](" <> uri <> ")" spanDocToMarkdownForTest :: String -> String spanDocToMarkdownForTest @@ -215,3 +225,35 @@ splitForList s = case lines s of [] -> "" (first:rest) -> unlines $ first : map ((" " ++) . trimStart) rest + +-- | Generate a source link for the 'Location' according to VSCode's supported form: +-- https://github.com/microsoft/vscode/blob/b3ec8181fc49f5462b5128f38e0723ae85e295c2/src/vs/platform/opener/common/opener.ts#L151-L160 +-- +srcSpanToMdLink :: Location -> T.Text +srcSpanToMdLink location = + let + uri = location ^. JL.uri + range = location ^. JL.range + -- LSP 'Range' starts at '0', but link locations start at '1'. + intText n = T.pack $ show (n + 1) + srcRangeText = + T.concat + [ "L" + , intText (range ^. JL.start . JL.line) + , "," + , intText (range ^. JL.start . JL.character) + , "-L" + , intText (range ^. JL.end . JL.line) + , "," + , intText (range ^. JL.end . JL.character) + ] + + -- If the 'Location' is a 'FilePath', display it in shortened form. + -- This avoids some redundancy and better readability for the user. + title = case uriToFilePath uri of + Just fp -> T.pack (takeFileName fp) <> ":" <> intText (range ^. JL.start . JL.line) + Nothing -> getUri uri + + srcLink = getUri uri <> "#" <> srcRangeText + in + linkify title srcLink From cfd73c77f47d64581bc721cc8fa5512c5508f905 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sun, 20 Oct 2024 18:50:19 +0200 Subject: [PATCH 7/8] Improve documentation for Evidence tree rendering Also, add extensive note about skipping 'EvLetBinding' evidence nodes. --- ghcide/src/Development/IDE/Spans/AtPoint.hs | 57 +++++++++++++++++---- 1 file changed, 48 insertions(+), 9 deletions(-) diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs index 7d4004fb7e..4fafa3e952 100644 --- a/ghcide/src/Development/IDE/Spans/AtPoint.hs +++ b/ghcide/src/Development/IDE/Spans/AtPoint.hs @@ -269,12 +269,26 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D prettyName :: (Either ModuleName Name, IdentifierDetails hietype) -> IO T.Text prettyName (Right n, dets) -- We want to print evidence variable using a readable tree structure. - | any isEvidenceUse (identInfo dets) = pure $ maybe "" (printOutputable . renderEvidenceTree) (getEvidenceTree rf n) <> "\n" - | otherwise = pure $ T.unlines $ - wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) - : maybeToList (pretty (definedAt n) (prettyPackageName n)) - ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n - ] + -- Evidence variables contain information why a particular instance or + -- type equality was chosen, paired with location information. + | any isEvidenceUse (identInfo dets) = + let + -- The evidence tree may not be present for some reason, e.g., the 'Name' is not + -- present in the tree. + -- Thus, we need to handle it here, but in practice, this should never be 'Nothing'. + evidenceTree = maybe "" (printOutputable . renderEvidenceTree) (getEvidenceTree rf n) + in + pure $ evidenceTree <> "\n" + -- Identifier details that are not evidence variables are used to display type information and + -- documentation of that name. + | otherwise = + let + typeSig = wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind)) + definitionLoc = maybeToList (pretty (definedAt n) (prettyPackageName n)) + docs = maybeToList (T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n) + in + pure $ T.unlines $ + [typeSig] ++ definitionLoc ++ docs where maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n pretty Nothing Nothing = Nothing pretty (Just define) Nothing = Just $ define <> "\n" @@ -337,6 +351,31 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D renderEvidenceTree :: Tree (EvidenceInfo a) -> SDoc -- However, if the root constraint is simply a (Show (,), Show [], Show Int, Show Bool)@ + -- + -- It is also quite helpful to look at the @.hie@ file directly to see how the + -- evidence information is presented on disk. @hiedb dump @ renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) [x]) = renderEvidenceTree x renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_), ..}) xs) @@ -351,15 +390,15 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D = 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) + 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" <+> text (T.unpack $ srcSpanToMdLink location) where - location = realSrcSpanToLocation $ traceShowId spn + location = realSrcSpanToLocation spn -- Use the bind span if we have one, else use the occurrence span spn = fromMaybe ospn mspn pprSrc = case src of From 8ce5ec53b4073fcfadf64b6cf81c459685890c89 Mon Sep 17 00:00:00 2001 From: Fendor Date: Wed, 23 Oct 2024 16:58:45 +0200 Subject: [PATCH 8/8] Remove unused test code with helpful error message --- .../exe/FindImplementationAndHoverTests.hs | 57 +++---------------- 1 file changed, 8 insertions(+), 49 deletions(-) diff --git a/ghcide/test/exe/FindImplementationAndHoverTests.hs b/ghcide/test/exe/FindImplementationAndHoverTests.hs index 0bbc400e34..221be90dd2 100644 --- a/ghcide/test/exe/FindImplementationAndHoverTests.hs +++ b/ghcide/test/exe/FindImplementationAndHoverTests.hs @@ -7,18 +7,15 @@ module FindImplementationAndHoverTests (tests) where import Control.Monad import Data.Foldable import Data.Maybe -import qualified Data.Text as T -import qualified Language.LSP.Protocol.Lens as L +import Data.Text (Text) +import qualified Data.Text as T import Language.LSP.Test -import Text.Regex.TDFA ((=~)) +import Text.Regex.TDFA ((=~)) import Config -import Control.Category ((>>>)) -import Control.Lens ((^.)) -import Data.Text (Text) -import Development.IDE.Test (standardizeQuotes) +import Development.IDE.Test (standardizeQuotes) import Test.Hls -import Test.Hls.FileSystem (copyDir) +import Test.Hls.FileSystem (copyDir) tests :: TestTree tests = let @@ -39,10 +36,10 @@ tests = let case hover of Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg}) - ,_range = rangeInHover } -> + ,_range = _rangeInHover } -> case expected of - ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectRange _expectedRange -> liftIO $ assertFailure $ "ExpectRange assertion not implemented, yet." + ExpectHoverRange _expectedRange -> liftIO $ assertFailure $ "ExpectHoverRange assertion not implemented, yet." ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool) @@ -50,44 +47,6 @@ tests = let _ -> pure () -- all other expectations not relevant to hover _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover - extractLineColFromHoverMsg :: T.Text -> [T.Text] - extractLineColFromHoverMsg = - -- Hover messages contain multiple lines, and we are looking for the definition - -- site - T.lines - -- The line we are looking for looks like: "*Defined at /tmp/GotoHover.hs:22:3*" - -- So filter by the start of the line - >>> mapMaybe (T.stripPrefix "*Defined at") - -- There can be multiple definitions per hover message! - -- See the test "field in record definition" for example. - -- The tests check against the last line that contains the above line. - >>> last - -- [" /tmp/", "22:3*"] - >>> T.splitOn (sourceFileName <> ":") - -- "22:3*" - >>> last - -- ["22:3", ""] - >>> T.splitOn "*" - -- "22:3" - >>> head - -- ["22", "3"] - >>> T.splitOn ":" - - checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () - checkHoverRange expectedRange rangeInHover msg = - let - lineCol = extractLineColFromHoverMsg msg - -- looks like hovers use 1-based numbering while definitions use 0-based - -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. - adjust Position{_line = l, _character = c} = - Position{_line = l + 1, _character = c + 1} - in - case map (read . T.unpack) lineCol of - [l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c - _ -> liftIO $ assertFailure $ - "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> - "\n but got: " <> show (msg, rangeInHover) - assertFoundIn :: T.Text -> T.Text -> Assertion assertFoundIn part whole = assertBool (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole)