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/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` diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 20c86c8280..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 @@ -98,7 +99,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' @@ -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 88c6570b23..4fafa3e952 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 @@ -23,6 +24,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 @@ -52,9 +57,13 @@ 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.Either.Extra (eitherToMaybe) +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 HieDb hiding (pointCommand, @@ -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 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 @@ -198,12 +211,25 @@ gotoDefinition -> LookupModule m -> IdeOptions -> M.Map ModuleName NormalizedFilePath - -> HieASTs a + -> HieAstResult -> Position -> MaybeT m [(Location, Identifier)] 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 @@ -212,13 +238,13 @@ 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 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] @@ -235,24 +261,34 @@ atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env 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 = 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 + names = sortOn (any isEvidenceUse . identInfo . snd) $ M.assocs $ nodeIdentifiers info 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) + -- We want to print evidence variable using a readable tree structure. + -- 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" @@ -286,7 +322,7 @@ atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env 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 @@ -295,9 +331,12 @@ atPoint IdeOptions{} (HAR _ hf _ _ (kind :: HieKind hietype)) (DKMap dm km) env 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 + + 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 +346,66 @@ 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 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) + = 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" <+> text (T.unpack $ srcSpanToMdLink location) + where + location = realSrcSpanToLocation spn + -- 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 + 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 +422,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 +436,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,20 +451,20 @@ 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 - -> HieASTs a + -> HieAstResult -> m [(Location, Identifier)] -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) zeroPos = Position 0 0 zeroRange = Range zeroPos zeroPos @@ -375,6 +474,24 @@ locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast = (\n -> fmap (fmap $ fmap (,Right n)) (nameToLocation withHieDb lookupModule n))) 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]) nameToLocation withHieDb lookupModule name = runMaybeT $ 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 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/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/FindImplementationAndHoverTests.hs b/ghcide/test/exe/FindImplementationAndHoverTests.hs new file mode 100644 index 0000000000..221be90dd2 --- /dev/null +++ b/ghcide/test/exe/FindImplementationAndHoverTests.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module FindImplementationAndHoverTests (tests) where + +import Control.Monad +import Data.Foldable +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Language.LSP.Test +import Text.Regex.TDFA ((=~)) + +import Config +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 -> 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) + 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 + + 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/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/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 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