From 37d3b89e2aade5b2c24c12118e41b6f1c44637ec Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Thu, 7 May 2026 02:32:36 +0200 Subject: [PATCH] Extract data-family RHS constructors and show them in the viewer MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit 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) --- data/viewer.css | 12 +++++++++ data/viewer.js | 52 +++++++++++++++++++++++++++++++-------- src/Classgraph/Extract.hs | 29 ++++++++++++++++++++++ src/Classgraph/Schema.hs | 42 +++++++++++++++++++++++++++++++ 4 files changed, 125 insertions(+), 10 deletions(-) diff --git a/data/viewer.css b/data/viewer.css index 92cc21a..bbb9108 100644 --- a/data/viewer.css +++ b/data/viewer.css @@ -142,6 +142,18 @@ body { display: flex; } .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; } diff --git a/data/viewer.js b/data/viewer.js index c58b110..0f81a65 100644 --- a/data/viewer.js +++ b/data/viewer.js @@ -1381,10 +1381,35 @@ 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 @@ -1934,15 +1959,22 @@ `
    ${fi.fiTyVars.map(v => `
  • ${escape(v.tvName)} :: ${escape(v.tvKind)}
    • `).join('')}
`; 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 - ? '' - : `
Right-hand side
${escape(renderArg(fi.fiRhs, fi.fiTyVars))}
`; + // 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 => + `
  • ${escape(renderDataCon(dc, fi.fiTyVars))}
    • `).join(''); + rhsEntry = `
    Constructors
      ${lis}
    `; + } + } else { + rhsEntry = `
    Right-hand side
    ${escape(renderArg(fi.fiRhs, fi.fiTyVars))}
    `; + } return `

    ${head}

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

    diff --git a/src/Classgraph/Extract.hs b/src/Classgraph/Extract.hs index ebd0b8d..660d161 100644 --- a/src/Classgraph/Extract.hs +++ b/src/Classgraph/Extract.hs @@ -58,6 +58,7 @@ import GHC.Core.TyCon , isFamilyTyCon , isInvisibleTyConBinder , tyConBinders + , tyConDataCons , tyConFamInst_maybe , tyConName , tyConResKind @@ -65,6 +66,16 @@ import GHC.Core.TyCon , 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 @@ -361,6 +372,7 @@ extractClosedBranch tc br = FamInstInfo -- 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 @@ -390,6 +402,23 @@ extractFamInst mDocs fi = 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) } ------------------------------------------------------------------------------ diff --git a/src/Classgraph/Schema.hs b/src/Classgraph/Schema.hs index 89dd488..af427be 100644 --- a/src/Classgraph/Schema.hs +++ b/src/Classgraph/Schema.hs @@ -19,6 +19,7 @@ module Classgraph.Schema , TypeFamilyFlavor (..) , TypeFamilyInfo (..) , FamInstInfo (..) + , DataConInfo (..) , SrcSpanInfo (..) ) where @@ -273,6 +274,11 @@ data FamInstInfo = FamInstInfo , 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) @@ -286,6 +292,7 @@ instance ToJSON FamInstInfo where , "fiIsData" .= fiIsData fi , "fiDoc" .= fiDoc fi , "fiDefinedIn" .= fiDefinedIn fi + , "fiDataCons" .= fiDataCons fi ] instance FromJSON FamInstInfo where @@ -298,6 +305,41 @@ 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 -- 2.54.0