Jump to instance definition and explain typeclass evidence for GHC 9

ghcide/src/Development/IDE/Core/Actions.hs

@@ -86,7 +86,7 @@ getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
 getDefinition file pos = runMaybeT $ do
     ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
     opts <- liftIO $ getIdeOptionsIO ide
-    (HAR _ hf _ _ _, mapping) <- useE GetHieAst file
+    (hf, mapping) <- useE GetHieAst file
     (ImportMap imports, _) <- useE GetImportMap file
     !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)
     toCurrentLocations mapping <$> AtPoint.gotoDefinition withHieDb (lookupMod hiedbWriter) opts imports hf pos'

ghcide/src/Development/IDE/Spans/AtPoint.hs

@@ -49,14 +49,23 @@ import qualified Data.Text                            as T
 
 import qualified Data.Array                           as A
 import           Data.Either
-import           Data.List                            (isSuffixOf)
 import           Data.List.Extra                      (dropEnd1, nubOrd)
 
 import           Data.Version                         (showVersion)
 import           Development.IDE.Types.Shake          (WithHieDb)
 import           HieDb                                hiding (pointCommand)
 import           System.Directory                     (doesFileExist)
 
+#if MIN_VERSION_ghc(9,0,1)
+import qualified GHC.Utils.Outputable                           as O
+import           GHC.Data.FastString                            (lengthFS)
+import Data.Tree
+import qualified Data.Tree as T
+import           Data.List                            (isSuffixOf, sortOn)
+#else
+import           Data.List                            (isSuffixOf)
+#endif
+
 -- | Gives a Uri for the module, given the .hie file location and the the module info
 -- The Bool denotes if it is a boot module
 type LookupModule m = FilePath -> ModuleName -> Unit -> Bool -> MaybeT m Uri
@@ -171,14 +180,18 @@ documentHighlight hf rf pos = pure highlights
     highlights = do
       n <- ns
       ref <- fromMaybe [] (M.lookup (Right n) rf)
-      pure $ makeHighlight ref
-    makeHighlight (sp,dets) =
-      DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets)
+      maybeToList (makeHighlight n ref)
+    makeHighlight n (sp,dets)
+      | isTvNameSpace (nameNameSpace n) && isBadSpan n sp = Nothing
+      | otherwise = Just $ DocumentHighlight (realSrcSpanToRange sp) (Just $ highlightType $ identInfo dets)
     highlightType s =
       if any (isJust . getScopeFromContext) s
         then HkWrite
         else HkRead
 
+    isBadSpan :: Name -> RealSrcSpan -> Bool
+    isBadSpan n sp = srcSpanStartLine sp /= srcSpanEndLine sp || (srcSpanEndCol sp - srcSpanStartCol sp > lengthFS (occNameFS $ nameOccName n))
+
 gotoTypeDefinition
   :: MonadIO m
   => WithHieDb
@@ -197,7 +210,7 @@ gotoDefinition
   -> LookupModule m
   -> IdeOptions
   -> M.Map ModuleName NormalizedFilePath
-  -> HieASTs a
+  -> HieAstResult
   -> Position
   -> MaybeT m [Location]
 gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos
@@ -211,7 +224,7 @@ atPoint
   -> HscEnv
   -> Position
   -> Maybe (Maybe Range, [T.Text])
-atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ pointCommand hf pos hoverInfo
+atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) _rf _ kind) (DKMap dm km) env pos = listToMaybe $ pointCommand hf pos hoverInfo
   where
     -- Hover info for values/data
     hoverInfo ast = (Just range, prettyNames ++ pTypes)
@@ -224,12 +237,21 @@ atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ p
 
         wrapHaskell x = "\n```haskell\n"<>x<>"\n```\n"
         info = nodeInfoH kind ast
-        names = M.assocs $ nodeIdentifiers info
+        names =
+#if MIN_VERSION_ghc(9,0,1)
+          sortOn (any isEvidenceUse . identInfo . snd) $
+#endif
+          M.assocs $ nodeIdentifiers info
         types = nodeType info
 
         prettyNames :: [T.Text]
         prettyNames = map prettyName names
-        prettyName (Right n, dets) = T.unlines $
+        prettyName (Right n, dets)
+#if MIN_VERSION_ghc(9,0,1)
+          | any isEvidenceUse (identInfo dets) = maybe "" (printOutputable . renderEvidenceTree) (getEvidenceTree _rf n) <> "\n"
+          | otherwise
+#endif
+          = T.unlines $
           wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind))
           : maybeToList (pretty (definedAt n) (prettyPackageName n))
           ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n
@@ -250,9 +272,12 @@ atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ p
           pure $ "*(" <> pkgName <> "-" <> version <> ")*"
 
         prettyTypes = map (("_ :: "<>) . prettyType) types
-        prettyType t = case kind of
-          HieFresh -> printOutputable t
-          HieFromDisk full_file -> printOutputable $ hieTypeToIface $ recoverFullType t (hie_types full_file)
+        prettyType = printOutputable . expandType
+
+        expandType :: a -> SDoc
+        expandType t = case kind of
+          HieFresh -> ppr t
+          HieFromDisk full_file -> ppr $ hieTypeToIface $ recoverFullType t (hie_types full_file)
 
         definedAt name =
           -- do not show "at <no location info>" and similar messages
@@ -261,6 +286,42 @@ atPoint IdeOptions{} (HAR _ hf _ _ kind) (DKMap dm km) env pos = listToMaybe $ p
             UnhelpfulLoc {} | isInternalName name || isSystemName name -> Nothing
             _ -> Just $ "*Defined " <> printOutputable (pprNameDefnLoc name) <> "*"
 
+#if MIN_VERSION_ghc(9,0,1)
+        -- We want to render the root constraint even if it is a let,
+        -- but we don't want to render any subsequent lets
+        renderEvidenceTree :: Tree (EvidenceInfo a) -> SDoc
+        -- However, if the root constraint is simply an indirection (via let) to a single other constraint,
+        -- we can still skip rendering it
+        renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) [x])
+          = renderEvidenceTree x
+        renderEvidenceTree (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_), ..}) xs)
+          = hang (text "Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $
+                 vcat $ text "constructed using:" : map renderEvidenceTree' xs
+        renderEvidenceTree (T.Node (EvidenceInfo{..}) _)
+          = hang (text "Evidence of constraint `" O.<> expandType evidenceType O.<> "`") 2 $
+                 vcat $ printDets evidenceSpan evidenceDetails : map (text . T.unpack) (maybeToList $ definedAt evidenceVar)
+
+        -- renderEvidenceTree' skips let bound evidence variables and prints the children directly
+        renderEvidenceTree' (T.Node (EvidenceInfo{evidenceDetails=Just (EvLetBind _,_,_)}) xs)
+          = vcat (map renderEvidenceTree' xs)
+        renderEvidenceTree' (T.Node (EvidenceInfo{..}) _)
+          = hang (text "- `" O.<> expandType evidenceType O.<> "`") 2 $
+                 vcat $ printDets evidenceSpan evidenceDetails : map (text . T.unpack) (maybeToList $ definedAt evidenceVar)
+
+        printDets :: RealSrcSpan -> Maybe (EvVarSource, Scope, Maybe Span) -> SDoc
+        printDets _    Nothing = text "using an external instance"
+        printDets ospn (Just (src,_,mspn)) = pprSrc
+                                      $$ text "at" <+> ppr spn
+          where
+            -- Use the bind span if we have one, else use the occurence span
+            spn = fromMaybe ospn mspn
+            pprSrc = case src of
+              -- Users don't know what HsWrappers are
+              EvWrapperBind -> "bound by a context"
+              _ -> ppr src
+#endif
+
+
 typeLocationsAtPoint
   :: forall m
    . MonadIO m
@@ -276,7 +337,7 @@ typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKi
       let arr = hie_types hf
           ts = concat $ pointCommand ast pos getts
           unfold = map (arr A.!)
-          getts x = nodeType ni  ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni)
+          getts x = nodeType ni  ++ mapMaybe identType (M.elems $ nodeIdentifiers ni)
             where ni = nodeInfo' x
           getTypes ts = flip concatMap (unfold ts) $ \case
             HTyVarTy n -> [n]
@@ -295,12 +356,12 @@ typeLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _ _ hieKi
             HQualTy a b -> getTypes [a,b]
             HCastTy a -> getTypes [a]
             _ -> []
-        in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts)
+        in nubOrd <$> concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts)
     HieFresh ->
       let ts = concat $ pointCommand ast pos getts
-          getts x = nodeType ni  ++ (mapMaybe identType $ M.elems $ nodeIdentifiers ni)
+          getts x = nodeType ni  ++ mapMaybe identType (M.elems $ nodeIdentifiers ni)
             where ni = nodeInfo x
-        in fmap nubOrd $ concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts)
+        in nubOrd <$> concatMapM (fmap (fromMaybe []) . nameToLocation withHieDb lookupModule) (getTypes ts)
 
 namesInType :: Type -> [Name]
 namesInType (TyVarTy n)      = [varName n]
@@ -313,24 +374,30 @@ namesInType (LitTy _)        = []
 namesInType _                = []
 
 getTypes :: [Type] -> [Name]
-getTypes ts = concatMap namesInType ts
+getTypes = concatMap namesInType
 
 locationsAtPoint
-  :: forall m a
+  :: forall m
    . MonadIO m
   => WithHieDb
   -> LookupModule m
   -> IdeOptions
   -> M.Map ModuleName NormalizedFilePath
   -> Position
-  -> HieASTs a
+  -> HieAstResult
   -> m [Location]
-locationsAtPoint withHieDb lookupModule _ideOptions imports pos ast =
+locationsAtPoint withHieDb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) =
   let ns = concat $ pointCommand ast pos (M.keys . getNodeIds)
+#if MIN_VERSION_ghc(9,0,1)
+      evTrees = mapMaybe (either (const Nothing) $ getEvidenceTree _rm) ns
+      evNs = concatMap (map (Right . evidenceVar) . T.flatten) evTrees
+#else
+      evNs = []
+#endif
       zeroPos = Position 0 0
       zeroRange = Range zeroPos zeroPos
-      modToLocation m = fmap (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) $ M.lookup m imports
-    in fmap (nubOrd . concat) $ mapMaybeM (either (pure . modToLocation) $ nameToLocation withHieDb lookupModule) ns
+      modToLocation m = (\fs -> pure $ Location (fromNormalizedUri $ filePathToUri' fs) zeroRange) <$> M.lookup m imports
+    in nubOrd . concat <$> mapMaybeM (either (pure . modToLocation) $ nameToLocation withHieDb lookupModule) (ns ++ evNs)
 
 -- | Given a 'Name' attempt to find the location where it is defined.
 nameToLocation :: MonadIO m => WithHieDb -> LookupModule m -> Name -> m (Maybe [Location])