diff options
author | Aaron Allen <aaron@flipstone.com> | 2020-12-23 21:43:54 -0600 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-01-27 17:39:11 -0500 |
commit | 93ae0e2a95ff57b587d673aa8946ee710012b37e (patch) | |
tree | 45b0a2769861aa3e993717b21ca9c3a792b9bd0e | |
parent | 925738839891b320b9436e7383d55dce2b8d4543 (diff) | |
download | haskell-93ae0e2a95ff57b587d673aa8946ee710012b37e.tar.gz |
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.
-rw-r--r-- | ghc/GHCi/UI.hs | 67 | ||||
-rw-r--r-- | testsuite/tests/ghci/scripts/ghci065.hs | 13 | ||||
-rw-r--r-- | testsuite/tests/ghci/scripts/ghci065.script | 3 | ||||
-rw-r--r-- | testsuite/tests/ghci/scripts/ghci065.stdout | 20 | ||||
-rw-r--r-- | testsuite/tests/ghci/scripts/ghci066.stdout | 2 |
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. |