From: Javier Sagredo Date: Wed, 6 May 2026 21:23:23 +0000 (+0200) Subject: Add haddocks to side panel if compiled with -haddock X-Git-Url: https://git.sagredo.dev/?a=commitdiff_plain;h=123616492f325a747ea7d857d616dbc926853e77;p=classgraph.git Add haddocks to side panel if compiled with -haddock --- diff --git a/README.md b/README.md index 4bc5e0f..6942cef 100644 --- a/README.md +++ b/README.md @@ -205,6 +205,24 @@ For an `inplace` (local-checkout cabal-build) the path is dynamic so the compiler and plugin share globals. (The default cabal invocation does the right thing.) +### Optional: Haddocks in the side panel + +If your target is compiled with `-haddock`, classgraph harvests every +class / instance / type-family / family-instance Haddock comment and +shows it in the right-side details panel. + +```cabal +ghc-options: -haddock + -fplugin=Classgraph.Plugin + "-fplugin-opt=Classgraph.Plugin:dir=.classgraph" +``` + +(Or, in the `-fplugin-library` setup: add `-haddock` to the same +`ghc-options:` block — it's a target-side flag, not a plugin option.) + +Without `-haddock` the rest of the data still flows through; you just +won't get a "Documentation" entry in the panel. + ## Combining dumps from multiple packages Big projects often span several cabal packages in the same monorepo or diff --git a/data/viewer.css b/data/viewer.css index 4f8eb05..6632069 100644 --- a/data/viewer.css +++ b/data/viewer.css @@ -515,6 +515,16 @@ body { display: flex; } #selected dd { margin: 4px 0 0; font-family: ui-monospace, "SF Mono", Menlo, Consolas, monospace; font-size: 13px; line-height: 1.5; color: #222; } #selected ul { margin: 4px 0 0; padding-left: 18px; } #selected li { font-family: ui-monospace, "SF Mono", Menlo, Consolas, monospace; font-size: 13px; line-height: 1.5; } +#selected dd.haddock { + font-family: -apple-system, BlinkMacSystemFont, "Segoe UI", Roboto, Helvetica, Arial, sans-serif; + background: #fffbeb; + border-left: 3px solid #f59e0b; + padding: 6px 10px; + border-radius: 0 4px 4px 0; + color: #1f2937; +} +#selected dd.haddock p { margin: 0 0 8px; } +#selected dd.haddock p:last-child { margin-bottom: 0; } footer { margin-top: 24px; padding-top: 12px; border-top: 1px solid #eee; font-size: 11px; color: #999; } diff --git a/data/viewer.js b/data/viewer.js index 666635e..917456f 100644 --- a/data/viewer.js +++ b/data/viewer.js @@ -1286,6 +1286,18 @@ return parts.length === 0 ? '' : `
${parts.join('')}
`; } + // Render a Haddock comment as a simple block of paragraphs. + // Empty strings, plain whitespace, and missing values all collapse to "". + // We do NOT try to interpret Haddock markup (links, code blocks, etc.) — + // we just preserve paragraph breaks and escape HTML. + function renderDocSection(doc) { + if (!doc) return ''; + const text = String(doc).trim(); + if (text === '') return ''; + const paras = text.split(/\n\s*\n/).map(p => `

${escape(p.trim())}

`).join(''); + return `
Documentation
${paras}
`; + } + function renderClassPanel(c) { const cid = qid(c.ciName); const tvs = c.ciTyVars @@ -1324,6 +1336,7 @@

${escape(c.ciName.qnPackage)} · ${escape(c.ciName.qnModule)}

${panelButtons(cid, { canPin: true, canMute: true })}
+ ${renderDocSection(c.ciDoc)}
Type variables
    ${tvs}
Superclasses
${supers}
Subclasses (in this program)
${subs} @@ -1354,6 +1367,7 @@

${escape(f.tfName.qnName)}

${escape(f.tfName.qnPackage)} · ${escape(f.tfName.qnModule)}

+ ${renderDocSection(f.tfDoc)}
Flavor
${escape(String(flav))}
Type variables
    ${tvs}
Result kind
${escape(f.tfResultKind)}
@@ -1381,6 +1395,7 @@

${head}

${escape(inst.iiClass.qnPackage)} · ${escape(inst.iiClass.qnModule)}

+ ${renderDocSection(inst.iiDoc)}
Orphan
${inst.iiOrphan ? 'yes' : 'no'}
Context (required to typecheck)
${ctx}
Type variables
${tvs} @@ -1407,6 +1422,7 @@

${head}

${escape(fi.fiFamily.qnPackage)} · ${escape(fi.fiFamily.qnModule)}

+ ${renderDocSection(fi.fiDoc)}
Right-hand side
${rhs}
Type variables
${tvs}
Defined at
${src} diff --git a/examples/demo/demo.cabal b/examples/demo/demo.cabal index eaa8c0b..8b8f550 100644 --- a/examples/demo/demo.cabal +++ b/examples/demo/demo.cabal @@ -23,5 +23,6 @@ library build-depends: base ^>=4.22 , classgraph ghc-options: -Wall + -haddock -fplugin=Classgraph.Plugin "-fplugin-opt=Classgraph.Plugin:dir=.classgraph" diff --git a/examples/demo/src/Demo/AssocFamily.hs b/examples/demo/src/Demo/AssocFamily.hs index 44b9c00..d363211 100644 --- a/examples/demo/src/Demo/AssocFamily.hs +++ b/examples/demo/src/Demo/AssocFamily.hs @@ -5,7 +5,12 @@ -- @assoc@ edge from the class to the family node. module Demo.AssocFamily where +-- | A container indexed by its element type. +-- +-- Demonstrates an /associated/ type family ('Element'): each instance of +-- 'Collection' must also pick a concrete @Element c@. class Collection c where + -- | The element type stored in the collection. type Element c singleton :: Element c -> c toList :: c -> [Element c] diff --git a/examples/demo/src/Demo/Basic.hs b/examples/demo/src/Demo/Basic.hs index 5a8806e..653f1bb 100644 --- a/examples/demo/src/Demo/Basic.hs +++ b/examples/demo/src/Demo/Basic.hs @@ -3,17 +3,28 @@ -- | A small linear class hierarchy: Pretty -> Renderable -> Display. module Demo.Basic where +-- | Things that can be turned into a human-readable string. +-- +-- This is the root of the demo's display hierarchy. Every other class in +-- this module ultimately requires a 'Pretty' instance. class Pretty a where pretty :: a -> String +-- | Something that can be /rendered/ — one step further than 'Pretty'. +-- +-- The default implementation just falls back to 'pretty'; more elaborate +-- instances can override 'render' to add framing, indentation, ANSI +-- escape codes, etc. class Pretty a => Renderable a where render :: a -> String render = pretty +-- | Side-effecting display. Prints the rendered value to stdout. class Renderable a => Display a where display :: a -> IO () display = putStrLn . render +-- | 'Pretty' for 'Int' delegates to 'show'. instance Pretty Int where pretty = show diff --git a/examples/demo/src/Demo/OpenFamily.hs b/examples/demo/src/Demo/OpenFamily.hs index 0ecab17..da68cfa 100644 --- a/examples/demo/src/Demo/OpenFamily.hs +++ b/examples/demo/src/Demo/OpenFamily.hs @@ -13,8 +13,16 @@ module Demo.OpenFamily where import Demo.Basic (Pretty (..)) +-- | An open type family that picks a /normal form/ for the given type. +-- +-- Open families can be extended with new equations from any module, so +-- the viewer surfaces each @type instance Norm T = …@ separately. type family Norm a +-- | Things whose normal form is itself 'Pretty'. +-- +-- The superclass constraint @Pretty (Norm a)@ goes through the type +-- family 'Norm', which the viewer marks as a dashed \"via family\" edge. class Pretty (Norm a) => Normalised a where normalise :: a -> Norm a diff --git a/src/Classgraph/Extract.hs b/src/Classgraph/Extract.hs index 8b4ffa8..7e5d7c6 100644 --- a/src/Classgraph/Extract.hs +++ b/src/Classgraph/Extract.hs @@ -73,7 +73,10 @@ import GHC.Core.Type , splitTyConApp_maybe , splitVisibleFunTy_maybe ) +import GHC.Hs.Doc (Docs (..), HsDoc, hsDocString) +import GHC.Hs.DocString (renderHsDocString) import GHC.Tc.Types (TcGblEnv (..)) +import GHC.Types.Unique.Map (lookupUniqMap) import GHC.Types.Name ( Name , nameModule_maybe @@ -132,12 +135,26 @@ currentModuleNames env = , T.pack (unitString (moduleUnit m)) ) -extractModule :: TcGblEnv -> ProgramData -extractModule env = ProgramData - { pdClasses = mapMaybe extractClass localClasses - , pdInstances = map extractInstance (tcg_insts env) - , pdTypeFamilies = mapMaybe (extractTypeFamily assocByName) allFams - , pdFamInstances = map extractFamInst (tcg_fam_insts env) +-- | Look up the Haddock comment(s) for a 'Name' in the docs map (if +-- the user compiled with @-haddock@). Multiple successive @-- |@ / +-- @-- ^@ comments on one declaration are concatenated with a blank +-- line between them, mirroring how Haddock itself stitches them. +lookupDoc :: Maybe Docs -> Name -> Maybe Text +lookupDoc Nothing _ = Nothing +lookupDoc (Just d) n = + case lookupUniqMap (docs_decls d) n of + Just (h : hs) -> Just (renderDoc h <> mconcat [ "\n\n" <> renderDoc x | x <- hs ]) + _ -> Nothing + where + renderDoc :: HsDoc pass -> Text + renderDoc = T.strip . T.pack . renderHsDocString . hsDocString + +extractModule :: Maybe Docs -> TcGblEnv -> ProgramData +extractModule mDocs env = ProgramData + { pdClasses = mapMaybe (extractClass mDocs) localClasses + , pdInstances = map (extractInstance mDocs) (tcg_insts env) + , pdTypeFamilies = mapMaybe (extractTypeFamily mDocs assocByName) allFams + , pdFamInstances = map (extractFamInst mDocs) (tcg_fam_insts env) } where localTcs = tcg_tcs env @@ -168,14 +185,15 @@ extractModule env = ProgramData ------------------------------------------------------------------------------ -- Classes -extractClass :: Class -> Maybe ClassInfo -extractClass cls = Just ClassInfo +extractClass :: Maybe Docs -> Class -> Maybe ClassInfo +extractClass mDocs cls = Just ClassInfo { ciName = qualName (className cls) , ciTyVars = map tyVarInfo (classTyVars cls) , ciSuperclasses = concatMap (predToSuperEdges boundTvs) (classSCTheta cls) , ciAssocTypes = [ qualName (tyConName atTc) | atTc <- classATs cls ] , ciMethods = map (T.pack . occNameString . nameOccName . varName) (classMethods cls) , ciSrc = srcSpanInfo (nameSrcSpan (className cls)) + , ciDoc = lookupDoc mDocs (className cls) } where boundTvs = classTyVars cls @@ -218,9 +236,10 @@ isEqClass cls = ------------------------------------------------------------------------------ -- Instances -extractInstance :: ClsInst -> InstanceInfo -extractInstance inst = +extractInstance :: Maybe Docs -> ClsInst -> InstanceInfo +extractInstance mDocs inst = let (tvs, theta, cls, args) = instanceSig inst + dfunName = varName (is_dfun inst) in InstanceInfo { iiClass = qualName (className cls) , iiArgs = map (typeArg tvs) args @@ -234,7 +253,8 @@ extractInstance inst = -- to read here — points at the *class declaration*, which for -- classes loaded from another package's interface file has an -- UnhelpfulSpan, hence "unknown" in the side panel. - , iiSrc = srcSpanInfo (nameSrcSpan (varName (is_dfun inst))) + , iiSrc = srcSpanInfo (nameSrcSpan dfunName) + , iiDoc = lookupDoc mDocs dfunName } orphanFlag :: IsOrphan -> Bool @@ -288,8 +308,8 @@ eqOpName ReprEq = "Coercible" -- shows up as "a ~R b" sometimes; closest readab ------------------------------------------------------------------------------ -- Type families -extractTypeFamily :: [(Name, Class)] -> TyCon -> Maybe TypeFamilyInfo -extractTypeFamily assocByName tc +extractTypeFamily :: Maybe Docs -> [(Name, Class)] -> TyCon -> Maybe TypeFamilyInfo +extractTypeFamily mDocs assocByName tc | not (isFamilyTyCon tc) = Nothing | otherwise = Just TypeFamilyInfo { tfName = qualName (tyConName tc) @@ -298,6 +318,7 @@ extractTypeFamily assocByName tc , tfResultKind = pprText (tyConResKind tc) , tfSrc = srcSpanInfo (nameSrcSpan (tyConName tc)) , tfEquations = closedEquations + , tfDoc = lookupDoc mDocs (tyConName tc) } where flavor = case lookup (tyConName tc) assocByName of @@ -327,10 +348,14 @@ extractClosedBranch tc br = FamInstInfo , fiRhs = typeArg (cab_tvs br) (cab_rhs br) , fiSrc = srcSpanInfo (cab_loc br) , fiIsData = False + , fiDoc = Nothing + -- Closed-family branches don't have their own Haddock-targeted Name; + -- documentation on the family declaration itself ends up on tfDoc + -- of the enclosing TypeFamilyInfo. } -extractFamInst :: FamInst -> FamInstInfo -extractFamInst fi = FamInstInfo +extractFamInst :: Maybe Docs -> FamInst -> FamInstInfo +extractFamInst mDocs fi = FamInstInfo { fiFamily = qualName (fi_fam fi) , fiTyVars = map tyVarInfo (fi_tvs fi) -- Strip invisible (kind) args that GHC bakes into fi_tys. Without this @@ -350,6 +375,11 @@ extractFamInst fi = FamInstInfo , fiIsData = case fi_flavor fi of SynFamilyInst -> False DataFamilyInst _ -> True + , fiDoc = lookupDoc mDocs (fi_fam fi) + -- The dump's docs_decls map keys family instances by the family + -- TyCon's Name. If multiple instances of the same family carry + -- separate Haddocks, all of them surface here on every instance — + -- a known limitation of the GHC docs map's structure. } ------------------------------------------------------------------------------ diff --git a/src/Classgraph/Plugin.hs b/src/Classgraph/Plugin.hs index 8109191..98a8649 100644 --- a/src/Classgraph/Plugin.hs +++ b/src/Classgraph/Plugin.hs @@ -22,6 +22,8 @@ import GHC.Driver.Plugins , defaultPlugin , purePlugin ) +import GHC.Driver.Session (getDynFlags) +import GHC.HsToCore.Docs (extractDocs) import GHC.Tc.Types (TcGblEnv, TcM) import GHC.Unit.Module.ModSummary (ModSummary) @@ -36,12 +38,17 @@ plugin = defaultPlugin collect :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv collect opts _summ env = do + dflags <- getDynFlags + -- Will be Nothing unless the target package is compiled with + -- @-haddock@. We're tolerant: missing docs just means no doc fields + -- in the dumps. + mDocs <- extractDocs dflags env let outDir = parseOpts opts (modName, pkgName) = currentModuleNames env dump = ModuleDump { mdModule = modName , mdPackage = pkgName - , mdData = extractModule env + , mdData = extractModule mDocs env } liftIO $ writeDump outDir dump pure env diff --git a/src/Classgraph/Schema.hs b/src/Classgraph/Schema.hs index e6fb238..c3bcde5 100644 --- a/src/Classgraph/Schema.hs +++ b/src/Classgraph/Schema.hs @@ -72,9 +72,33 @@ data ClassInfo = ClassInfo , ciAssocTypes :: ![QualName] , ciMethods :: ![Text] , ciSrc :: !(Maybe SrcSpanInfo) + , ciDoc :: !(Maybe Text) + -- ^ Haddock comment attached to the class declaration, if the + -- target package was compiled with @-haddock@. 'Nothing' if no doc + -- exists or the flag wasn't set. } deriving stock (Generic, Show, Eq) - deriving anyclass (ToJSON, FromJSON) + +instance ToJSON ClassInfo where + toJSON c = object + [ "ciName" .= ciName c + , "ciTyVars" .= ciTyVars c + , "ciSuperclasses" .= ciSuperclasses c + , "ciAssocTypes" .= ciAssocTypes c + , "ciMethods" .= ciMethods c + , "ciSrc" .= ciSrc c + , "ciDoc" .= ciDoc c + ] + +instance FromJSON ClassInfo where + parseJSON = withObject "ClassInfo" $ \o -> ClassInfo + <$> o .: "ciName" + <*> o .: "ciTyVars" + <*> o .: "ciSuperclasses" + <*> o .: "ciAssocTypes" + <*> o .: "ciMethods" + <*> o .: "ciSrc" + <*> o .:? "ciDoc" -- | A direct superclass constraint: @class (Super arg1 arg2) => Sub a b@ -- becomes a 'SuperclassEdge' on the @Sub@ class with @seArgs = [arg1, arg2]@. @@ -119,9 +143,35 @@ data InstanceInfo = InstanceInfo , iiOrphan :: !Bool , iiOverlap :: !(Maybe Text) , iiSrc :: !(Maybe SrcSpanInfo) + , iiDoc :: !(Maybe Text) + -- ^ Haddock attached to the @instance ...@ declaration, if the + -- target was compiled with @-haddock@. Looked up via the dfun's + -- 'Name'. } deriving stock (Generic, Show, Eq) - deriving anyclass (ToJSON, FromJSON) + +instance ToJSON InstanceInfo where + toJSON i = object + [ "iiClass" .= iiClass i + , "iiArgs" .= iiArgs i + , "iiContext" .= iiContext i + , "iiTyVars" .= iiTyVars i + , "iiOrphan" .= iiOrphan i + , "iiOverlap" .= iiOverlap i + , "iiSrc" .= iiSrc i + , "iiDoc" .= iiDoc i + ] + +instance FromJSON InstanceInfo where + parseJSON = withObject "InstanceInfo" $ \o -> InstanceInfo + <$> o .: "iiClass" + <*> o .: "iiArgs" + <*> o .: "iiContext" + <*> o .: "iiTyVars" + <*> o .: "iiOrphan" + <*> o .: "iiOverlap" + <*> o .: "iiSrc" + <*> o .:? "iiDoc" data PredInfo = PredInfo { piClass :: !QualName @@ -169,9 +219,31 @@ data TypeFamilyInfo = TypeFamilyInfo -- ^ For 'ClosedFam' families, the equations of the closed family -- (extracted from the underlying 'CoAxiom Branched'). Empty for open -- and associated families — those are populated via 'pdFamInstances'. + , tfDoc :: !(Maybe Text) + -- ^ Haddock for the family declaration, when @-haddock@ is on. } deriving stock (Generic, Show, Eq) - deriving anyclass (ToJSON, FromJSON) + +instance ToJSON TypeFamilyInfo where + toJSON tf = object + [ "tfName" .= tfName tf + , "tfTyVars" .= tfTyVars tf + , "tfFlavor" .= tfFlavor tf + , "tfResultKind" .= tfResultKind tf + , "tfSrc" .= tfSrc tf + , "tfEquations" .= tfEquations tf + , "tfDoc" .= tfDoc tf + ] + +instance FromJSON TypeFamilyInfo where + parseJSON = withObject "TypeFamilyInfo" $ \o -> TypeFamilyInfo + <$> o .: "tfName" + <*> o .: "tfTyVars" + <*> o .: "tfFlavor" + <*> o .: "tfResultKind" + <*> o .: "tfSrc" + <*> o .: "tfEquations" + <*> o .:? "tfDoc" data FamInstInfo = FamInstInfo { fiFamily :: !QualName @@ -187,6 +259,8 @@ data FamInstInfo = FamInstInfo -- synthetic @R:…@ data-constructor TyCon, not a meaningful type to -- show); 'False' for a regular @type instance F … = …@. The viewer -- hides the RHS for data-family rows. + , fiDoc :: !(Maybe Text) + -- ^ Haddock for this family instance, when @-haddock@ is on. } deriving stock (Generic, Show, Eq) @@ -198,6 +272,7 @@ instance ToJSON FamInstInfo where , "fiRhs" .= fiRhs fi , "fiSrc" .= fiSrc fi , "fiIsData" .= fiIsData fi + , "fiDoc" .= fiDoc fi ] instance FromJSON FamInstInfo where @@ -208,6 +283,7 @@ instance FromJSON FamInstInfo where <*> o .: "fiRhs" <*> o .: "fiSrc" <*> o .:? "fiIsData" .!= False + <*> o .:? "fiDoc" data SrcSpanInfo = SrcSpanInfo { ssFile :: !Text