Adds a DataConInfo record (dcName + dcArgs + dcFieldLabels) and a
fiDataCons :: [DataConInfo] field on FamInstInfo. Schema/JSON
encoding is backwards-compatible: missing fiDataCons defaults to [].
Extract.hs's extractFamInst now walks the rep TyCon's
tyConDataCons (pulled directly out of the DataFamilyInst flavour
constructor — famInstTyCon turned out to be the family TyCon, not
the rep, on at least 9.14.1) and turns each DataCon into a
DataConInfo. The data constructor's arg types are extracted with
the fam-instance's tyvars in scope, so positional TyVarRefs resolve
to the right fiTyVars entries.
Viewer:
* renderFamInstHead now shows `Family args = Con1 t1 t2 | Con2 …`
for data fam-instances (record syntax: `Con { f1 :: t1, f2 :: t2 }`).
* The fam-instance side panel grows a Constructors entry listing
each data constructor with its fields.
Demo: the existing Crate Int / Crate Bool / Crate [a] data
fam-instances now render with their CrateInt / CrateBool / CrateList
constructors visible.
Co-Authored-By: Claude Opus 4.7 (1M context) <[email protected]>
.swatch-pred { background: #eef2ff; color: #3730a3; border-color: #6366f1; }
.swatch-faminst { background: #f5f3ff; color: #5b21b6; border-color: #a78bfa; font-style: italic; }
.swatch-faminst-unres { background: #f3f4f6; color: #374151; border-color: #9ca3af; font-style: italic; border-style: dashed; }
+ul.datacons {
+ margin: 4px 0 0;
+ padding-left: 0;
+ list-style: none;
+}
+ul.datacons li {
+ font-family: ui-monospace, "SF Mono", Menlo, Consolas, monospace;
+ font-size: 12px;
+ line-height: 1.5;
+ padding: 2px 0;
+ color: #1e293b;
+}
.swatch-external { background: #e5e7eb; color: #374151; border-color: #9ca3af; border-style: dashed; }
.swatch-ghost { background: #dbeafe; color: #1e3a8a; border-color: #1d4ed8; border-style: dashed; opacity: 0.85; }
.swatch-orphan { background: #ecfdf5; color: #065f46; border: 1px dashed #dc2626; }
function renderFamInstHead(fi) {
const args = renderArgsCompact(fi.fiArgs, fi.fiTyVars);
const head = fi.fiFamily.qnName + (args ? ' ' + args : '');
- if (fi.fiIsData) return head;
+ if (fi.fiIsData) {
+ // Show the user-declared data constructors on the right-hand
+ // side, using `|` between alternatives. Empty fiDataCons (older
+ // dumps, or extraction edge cases) just degrade to the bare
+ // head with no `=`.
+ const dcs = fi.fiDataCons || [];
+ if (dcs.length === 0) return head;
+ const cons = dcs.map(dc => renderDataCon(dc, fi.fiTyVars)).join(' | ');
+ return head + ' = ' + cons;
+ }
return head + ' = ' + renderArg(fi.fiRhs, fi.fiTyVars);
}
+ // Render a single data constructor as `Name arg1 arg2` for positional
+ // syntax or `Name { f1 :: arg1, f2 :: arg2 }` for record syntax.
+ function renderDataCon(dc, boundTvs) {
+ const name = dc.dcName || '?';
+ const args = dc.dcArgs || [];
+ const labels = dc.dcFieldLabels || [];
+ if (args.length === 0) return name;
+ if (labels.length === args.length) {
+ // Record syntax: pair each arg with its field label.
+ const fields = args.map((a, i) =>
+ labels[i] + ' :: ' + renderArg(a, boundTvs)).join(', ');
+ return name + ' { ' + fields + ' }';
+ }
+ return name + ' ' + args.map(a => renderArg(a, boundTvs)).join(' ');
+ }
+
// Render the argument list of a class/family/instance application as
// it would appear in source: space-separated, with each individual arg
// self-parenthesising when it's a multi-arg tycon (handled by
`<dd><ul>${fi.fiTyVars.map(v =>
`<li>${escape(v.tvName)}<span style="color:#888"> :: ${escape(v.tvKind)}</span></li>`).join('')}</ul></dd>`;
const src = renderDefinedAt(fi.fiSrc, fi.fiDefinedIn || fi.fiFamily.qnPackage);
- // Data fam-instances: omit the "Right-hand side" row entirely.
- // What GHC stores as the rhs is the synthetic R: TyCon, and our
- // R: rewrite turns it into a copy of the LHS — neither is the
- // user's actual data-constructor declaration. We don't extract
- // the data constructors themselves into the schema, so we have
- // nothing useful to show.
- const rhsEntry = fi.fiIsData
- ? ''
- : `<dt>Right-hand side</dt><dd>${escape(renderArg(fi.fiRhs, fi.fiTyVars))}</dd>`;
+ // Type fam-instances show their RHS directly. Data fam-instances
+ // get a "Constructors" entry listing each user-declared data
+ // constructor with its arg types (or record fields).
+ let rhsEntry;
+ if (fi.fiIsData) {
+ const dcs = fi.fiDataCons || [];
+ if (dcs.length === 0) {
+ rhsEntry = '';
+ } else {
+ const lis = dcs.map(dc =>
+ `<li>${escape(renderDataCon(dc, fi.fiTyVars))}</li>`).join('');
+ rhsEntry = `<dt>Constructors</dt><dd><ul class="datacons">${lis}</ul></dd>`;
+ }
+ } else {
+ rhsEntry = `<dt>Right-hand side</dt><dd>${escape(renderArg(fi.fiRhs, fi.fiTyVars))}</dd>`;
+ }
return `
<h2>${head}</h2>
<p class="pkgmod">${escape(fi.fiFamily.qnPackage)} · ${escape(fi.fiFamily.qnModule)}</p>
, isFamilyTyCon
, isInvisibleTyConBinder
, tyConBinders
+ , tyConDataCons
, tyConFamInst_maybe
, tyConName
, tyConResKind
, tyConTyVars
, tyConClass_maybe
)
+import GHC.Core.DataCon
+ ( DataCon
+ , dataConFieldLabels
+ , dataConName
+ , dataConOrigArgTys
+ )
+import GHC.Core.TyCo.Rep (Scaled (..))
+import GHC.Types.FieldLabel (flLabel)
+import Language.Haskell.Syntax.Basic (field_label)
+import GHC.Data.FastString (unpackFS)
import GHC.Core.Class (classTyCon)
import GHC.Types.Basic (TupleSort (..))
import GHC.Core.Type
-- documentation on the family declaration itself ends up on tfDoc
-- of the enclosing TypeFamilyInfo.
, fiDefinedIn = Nothing -- filled in by Classgraph.Merge
+ , fiDataCons = [] -- closed branches are always type-family equations
}
extractFamInst :: Maybe Docs -> FamInst -> FamInstInfo
-- separate Haddocks, all of them surface here on every instance —
-- a known limitation of the GHC docs map's structure.
, fiDefinedIn = Nothing -- filled in by Classgraph.Merge
+ , fiDataCons = case fi_flavor fi of
+ SynFamilyInst -> []
+ DataFamilyInst rep_tc -> map (extractDataCon (fi_tvs fi))
+ (tyConDataCons rep_tc)
+ }
+
+-- | Extract a 'DataConInfo' from a 'DataCon'. @boundTvs@ is the
+-- enclosing fam-instance's tyvars (so positional 'TyVarRef' indices
+-- inside the constructor's arg types resolve to the right 'fiTyVars'
+-- entries).
+extractDataCon :: [Var] -> DataCon -> DataConInfo
+extractDataCon boundTvs dc = DataConInfo
+ { dcName = T.pack (occNameString (nameOccName (dataConName dc)))
+ , dcArgs = map (\(Scaled _ ty) -> typeArg boundTvs ty)
+ (dataConOrigArgTys dc)
+ , dcFieldLabels = map (T.pack . unpackFS . field_label . flLabel)
+ (dataConFieldLabels dc)
}
------------------------------------------------------------------------------
, TypeFamilyFlavor (..)
, TypeFamilyInfo (..)
, FamInstInfo (..)
+ , DataConInfo (..)
, SrcSpanInfo (..)
) where
, fiDefinedIn :: !(Maybe Text)
-- ^ Defining-package id (normalised), set at merge time. Used the
-- same way as 'iiDefinedIn' for editor-link source-root lookup.
+ , fiDataCons :: ![DataConInfo]
+ -- ^ For data fam-instances: the user-declared data constructors
+ -- on the right-hand side of @data instance F … = …@. Always
+ -- empty for type fam-instances (where the RHS is a type, not a
+ -- list of constructors).
}
deriving stock (Generic, Show, Eq)
, "fiIsData" .= fiIsData fi
, "fiDoc" .= fiDoc fi
, "fiDefinedIn" .= fiDefinedIn fi
+ , "fiDataCons" .= fiDataCons fi
]
instance FromJSON FamInstInfo where
<*> o .:? "fiIsData" .!= False
<*> o .:? "fiDoc"
<*> o .:? "fiDefinedIn"
+ <*> o .:? "fiDataCons" .!= []
+
+-- | Data constructor of a @data instance@ declaration.
+--
+-- For @data instance Crate Int = CrateInt Int Bool@:
+-- * @dcName = "CrateInt"@
+-- * @dcArgs = [TyConApp Int [], TyConApp Bool []]@ (positional)
+-- * @dcFieldLabels = []@ (no record syntax)
+--
+-- For @data instance Foo Int = Foo { x :: Int, y :: Bool }@:
+-- * @dcName = "Foo"@
+-- * @dcArgs = [TyConApp Int [], TyConApp Bool []]@
+-- * @dcFieldLabels = ["x", "y"]@ (parallel to dcArgs)
+--
+-- @TyVarRef i@ inside @dcArgs@ refers to the enclosing 'fiTyVars' of
+-- the 'FamInstInfo'.
+data DataConInfo = DataConInfo
+ { dcName :: !Text
+ , dcArgs :: ![TypeArg]
+ , dcFieldLabels :: ![Text]
+ }
+ deriving stock (Generic, Show, Eq)
+
+instance ToJSON DataConInfo where
+ toJSON d = object
+ [ "dcName" .= dcName d
+ , "dcArgs" .= dcArgs d
+ , "dcFieldLabels" .= dcFieldLabels d
+ ]
+
+instance FromJSON DataConInfo where
+ parseJSON = withObject "DataConInfo" $ \o -> DataConInfo
+ <$> o .: "dcName"
+ <*> o .: "dcArgs"
+ <*> o .:? "dcFieldLabels" .!= []
data SrcSpanInfo = SrcSpanInfo
{ ssFile :: !Text
projects / classgraph.git / commitdiff