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
#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; }
return parts.length === 0 ? '' : `<div class="panel-actions">${parts.join('')}</div>`;
}
+ // 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 => `<p>${escape(p.trim())}</p>`).join('');
+ return `<dt>Documentation</dt><dd class="haddock">${paras}</dd>`;
+ }
+
function renderClassPanel(c) {
const cid = qid(c.ciName);
const tvs = c.ciTyVars
<p class="pkgmod">${escape(c.ciName.qnPackage)} · ${escape(c.ciName.qnModule)}</p>
${panelButtons(cid, { canPin: true, canMute: true })}
<dl>
+ ${renderDocSection(c.ciDoc)}
<dt>Type variables</dt><dd><ul>${tvs}</ul></dd>
<dt>Superclasses</dt>${supers}
<dt>Subclasses (in this program)</dt>${subs}
<h2>${escape(f.tfName.qnName)}</h2>
<p class="pkgmod">${escape(f.tfName.qnPackage)} · ${escape(f.tfName.qnModule)}</p>
<dl>
+ ${renderDocSection(f.tfDoc)}
<dt>Flavor</dt><dd>${escape(String(flav))}</dd>
<dt>Type variables</dt><dd><ul>${tvs}</ul></dd>
<dt>Result kind</dt><dd>${escape(f.tfResultKind)}</dd>
<h2>${head}</h2>
<p class="pkgmod">${escape(inst.iiClass.qnPackage)} · ${escape(inst.iiClass.qnModule)}</p>
<dl>
+ ${renderDocSection(inst.iiDoc)}
<dt>Orphan</dt><dd>${inst.iiOrphan ? 'yes' : 'no'}</dd>
<dt>Context (required to typecheck)</dt>${ctx}
<dt>Type variables</dt>${tvs}
<h2>${head}</h2>
<p class="pkgmod">${escape(fi.fiFamily.qnPackage)} · ${escape(fi.fiFamily.qnModule)}</p>
<dl>
+ ${renderDocSection(fi.fiDoc)}
<dt>Right-hand side</dt><dd>${rhs}</dd>
<dt>Type variables</dt>${tvs}
<dt>Defined at</dt>${src}
build-depends: base ^>=4.22
, classgraph
ghc-options: -Wall
+ -haddock
-fplugin=Classgraph.Plugin
"-fplugin-opt=Classgraph.Plugin:dir=.classgraph"
-- @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]
-- | 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
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
, 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
, 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
------------------------------------------------------------------------------
-- 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
------------------------------------------------------------------------------
-- 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
-- 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
------------------------------------------------------------------------------
-- 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)
, tfResultKind = pprText (tyConResKind tc)
, tfSrc = srcSpanInfo (nameSrcSpan (tyConName tc))
, tfEquations = closedEquations
+ , tfDoc = lookupDoc mDocs (tyConName tc)
}
where
flavor = case lookup (tyConName tc) assocByName of
, 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
, 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.
}
------------------------------------------------------------------------------
, defaultPlugin
, purePlugin
)
+import GHC.Driver.Session (getDynFlags)
+import GHC.HsToCore.Docs (extractDocs)
import GHC.Tc.Types (TcGblEnv, TcM)
import GHC.Unit.Module.ModSummary (ModSummary)
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
, 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]@.
, 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
-- ^ 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
-- 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)
, "fiRhs" .= fiRhs fi
, "fiSrc" .= fiSrc fi
, "fiIsData" .= fiIsData fi
+ , "fiDoc" .= fiDoc fi
]
instance FromJSON FamInstInfo where
<*> o .: "fiRhs"
<*> o .: "fiSrc"
<*> o .:? "fiIsData" .!= False
+ <*> o .:? "fiDoc"
data SrcSpanInfo = SrcSpanInfo
{ ssFile :: !Text
projects / classgraph.git / commitdiff