Add additional context to :doc output (#19055)

With this change, the type/kind of an object as well as it's category
and definition site are added to the output of the :doc command for each
object matching the argument string.

5 files changed, 96 insertions, 9 deletions

diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index f78faae40d..b2909c2441 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -45,6 +45,9 @@ import GHC.Runtime.Interpreter.Types
 import GHCi.RemoteTypes
 import GHCi.BreakArray
 import GHC.ByteCode.Types
+import GHC.Core.DataCon
+import GHC.Core.ConLike
+import GHC.Core.PatSyn
 import GHC.Driver.Errors
 import GHC.Driver.Phases
 import GHC.Driver.Session as DynFlags
@@ -67,6 +70,7 @@ import GHC.Types.TyThing.Ppr
 import GHC.Types.SafeHaskell ( getSafeMode )
 import GHC.Types.Name
 import GHC.Types.SourceText
+import GHC.Types.Var ( varType )
 import GHC.Iface.Syntax ( showToHeader )
 import GHC.Builtin.Names
 import GHC.Builtin.Types( stringTyCon_RDR )
@@ -1806,33 +1810,78 @@ docCmd "" =
 docCmd s  = do
   -- TODO: Maybe also get module headers for module names
   names <- GHC.parseName s
-  e_docss <- sequence <$> mapM GHC.getDocs names
-  sdocs <- either handleGetDocsFailure (pure . pprDocs) e_docss
-  let sdocs' = vcat (intersperse (text "") sdocs)
+
+  docs <- traverse (buildDocComponents s) names
+
+  let sdocs = pprDocs docs
+      sdocs' = vcat (intersperse (text "") sdocs)
   unqual <- GHC.getPrintUnqual
   dflags <- getDynFlags
   unit_state <- hsc_units <$> GHC.getSession
   (liftIO . putStrLn . showSDocForUser dflags unit_state unqual) sdocs'
 
-pprDocs :: [(Maybe HsDocString, Map Int HsDocString)] -> [SDoc]
+data DocComponents =
+  DocComponents
+    { docs      :: Maybe HsDocString   -- ^ subject's haddocks
+    , sigAndLoc :: Maybe SDoc          -- ^ type signature + category + location
+    , argDocs   :: Map Int HsDocString -- ^ haddocks for arguments
+    }
+
+buildDocComponents :: GHC.GhcMonad m => String -> Name -> m DocComponents
+buildDocComponents str name = do
+  mbThing <- GHC.lookupName name
+  let sigAndLoc = sigAndLocDoc str <$> mbThing
+  (docs, argDocs)
+    <- either handleGetDocsFailure pure
+         =<< GHC.getDocs name
+
+  pure DocComponents{..}
+
+-- | Produce output containing the type/kind signature, category, and definiton
+-- location of a TyThing.
+sigAndLocDoc :: String -> TyThing -> SDoc
+sigAndLocDoc str tyThing =
+  let tyThingTyDoc :: TyThing -> SDoc
+      tyThingTyDoc = \case
+        AnId i                      -> pprTypeForUser $ varType i
+        AConLike (RealDataCon dc)   -> pprTypeForUser $ dataConDisplayType False dc
+        AConLike (PatSynCon patSyn) -> pprPatSynType patSyn
+        ATyCon tyCon                -> pprTypeForUser $ GHC.tyConKind tyCon
+        ACoAxiom _                  -> empty
+
+      tyDoc = tyThingTyDoc tyThing
+      sigDoc = text str <+> nest 2 (dcolon <+> tyDoc)
+      comment =
+        hsep [ char '\t' <> text "--"
+             , pprTyThingCategory tyThing
+             , text "defined" <+> pprNameDefnLoc (getName tyThing)
+             ]
+   in hang sigDoc 2 comment
+
+pprDocs :: [DocComponents] -> [SDoc]
 pprDocs docs
   | null nonEmptyDocs = pprDoc <$> take 1 docs
   -- elide <has no documentation> if there's at least one non-empty doc (#15784)
   | otherwise = pprDoc <$> nonEmptyDocs
   where
-    empty (mb_decl_docs, arg_docs)
+    empty DocComponents{docs = mb_decl_docs, argDocs = arg_docs}
       = isNothing mb_decl_docs && null arg_docs
     nonEmptyDocs = filter (not . empty) docs
 
 -- TODO: also print arg docs.
-pprDoc :: (Maybe HsDocString, Map Int HsDocString) -> SDoc
-pprDoc (mb_decl_docs, _arg_docs) =
+pprDoc :: DocComponents -> SDoc
+pprDoc DocComponents{sigAndLoc = mb_sig_loc, docs = mb_decl_docs} =
   maybe
     (text "<has no documentation>")
-    (text . unpackHDS)
+    formatDoc
     mb_decl_docs
+  where
+    formatDoc doc =
+      vcat [ fromMaybe empty mb_sig_loc -- print contextual info (#19055)
+           , text $ unpackHDS doc
+           ]
 
-handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m [SDoc]
+handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m a
 handleGetDocsFailure no_docs = do
   dflags <- getDynFlags
   let msg = showPpr dflags no_docs
diff --git a/testsuite/tests/ghci/scripts/ghci065.hs b/testsuite/tests/ghci/scripts/ghci065.hs
index 7d6d0cc497..eb3a4a9829 100644
--- a/testsuite/tests/ghci/scripts/ghci065.hs
+++ b/testsuite/tests/ghci/scripts/ghci065.hs
@@ -6,6 +6,8 @@
 --
 
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeFamilies #-}
 module Test where
 
 -- | This is the haddock comment of a data declaration for Data1.
@@ -46,3 +48,14 @@ func2 x y = x + y
 -- Here's multiple line comment for func3.
 func3 :: Int -> Int -> Int
 func3 x y = x + y
+
+-- | This is the haddock comment of a pattern synonym
+pattern PatSyn :: Int
+pattern PatSyn = 1
+
+-- | This is the haddock comment of a type class
+class TyCl a where
+
+-- | This is the haddock comment of a type family
+type family TyFam a where
+  TyFam Int = Bool
diff --git a/testsuite/tests/ghci/scripts/ghci065.script b/testsuite/tests/ghci/scripts/ghci065.script
index 12d03b1d91..76a241ce8b 100644
--- a/testsuite/tests/ghci/scripts/ghci065.script
+++ b/testsuite/tests/ghci/scripts/ghci065.script
@@ -12,3 +12,6 @@
 :doc func1
 :doc func2
 :doc func3
+:doc PatSyn
+:doc TyCl
+:doc TyFam
diff --git a/testsuite/tests/ghci/scripts/ghci065.stdout b/testsuite/tests/ghci/scripts/ghci065.stdout
index 2ea0831856..4c6f40c72c 100644
--- a/testsuite/tests/ghci/scripts/ghci065.stdout
+++ b/testsuite/tests/ghci/scripts/ghci065.stdout
@@ -1,12 +1,32 @@
+Data1 :: * 	-- Type constructor defined at ghci065.hs:14:1
  This is the haddock comment of a data declaration for Data1.
+Val2a :: Data2 	-- Data constructor defined at ghci065.hs:16:14
  This is the haddock comment of a data value for Val2a
+Val2b :: Data2 	-- Data constructor defined at ghci065.hs:17:14
  This is the haddock comment of a data value for Val2b
+Data3 :: * 	-- Type constructor defined at ghci065.hs:20:1
  This is the haddock comment of a data declaration for Data3.
+Data4 :: Int -> Data4
+  	-- Data constructor defined at ghci065.hs:25:3
  This is the haddock comment of a data constructor for Data4.
+dupeField :: DupeFields2 -> Int
+  	-- Identifier defined at ghci065.hs:32:9
  This is the second haddock comment of a duplicate record field.
 
+dupeField :: DupeFields1 -> Int
+  	-- Identifier defined at ghci065.hs:28:9
  This is the first haddock comment of a duplicate record field.
+func1 :: Int -> Int -> Int
+  	-- Identifier defined at ghci065.hs:41:1
  This is the haddock comment of a function declaration for func1.
 <has no documentation>
+func3 :: Int -> Int -> Int
+  	-- Identifier defined at ghci065.hs:50:1
  This is the haddock comment of a function declaration for func3.
  Here's multiple line comment for func3.
+PatSyn :: Int 	-- Pattern synonym defined at ghci065.hs:54:1
+ This is the haddock comment of a pattern synonym
+TyCl :: * -> Constraint 	-- Class defined at ghci065.hs:57:1
+ This is the haddock comment of a type class
+TyFam :: * -> * 	-- Type constructor defined at ghci065.hs:60:1
+ This is the haddock comment of a type family
diff --git a/testsuite/tests/ghci/scripts/ghci066.stdout b/testsuite/tests/ghci/scripts/ghci066.stdout
index ab85afa1a6..f56daddbdb 100644
--- a/testsuite/tests/ghci/scripts/ghci066.stdout
+++ b/testsuite/tests/ghci/scripts/ghci066.stdout
@@ -1 +1,3 @@
+GHC.Prim.byteSwap# :: GHC.Prim.Word# -> GHC.Prim.Word#
+  	-- Identifier defined in ‘GHC.Prim’
 Swap bytes in a word.