From b7858140e2806d7ce3f0c6e928bb4f55af6ae53b Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 19 Jun 2026 17:58:47 +0200 Subject: [PATCH] Add LR/TD layout toggle and render equality superclasses as arrows MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit Two pieces of showcase feedback: 1. Layout direction toggle. Class/method names are usually wider than tall, so a left-to-right flow often packs the graph more readably than the default top-to-bottom. Add a #dir-btn control (and `L` shortcut) that flips the shared dagre rankDir and re-lays-out the current view. 2. Equality superclass constraints as arrows. Previously `class (a ~ b) => C` dropped the equality entirely (predToSuperEdges returned no edge for the boxed `~`/`~~` classes and for EqPred). Now they become a superclass edge to the equality operator's node, carrying both operands as positional args, so the classes view draws `-{a}-{b}-> (~)` the same way any multi-param superclass renders. External operator node labels are parenthesised (`~` -> `(~)`). Instance-context equalities are unchanged — they still surface as chips on the instance node. The demo gains a NormIsInt class exercising the new superclass-equality path. Co-Authored-By: Claude Opus 4.8 (1M context) --- data/viewer.css | 6 ++-- data/viewer.html | 3 +- data/viewer.js | 45 ++++++++++++++++++++++++++---- examples/demo/src/Demo/Equality.hs | 9 ++++++ src/Classgraph/Extract.hs | 33 +++++++++++++++++----- src/Classgraph/Render.hs | 13 ++++++++- 6 files changed, 91 insertions(+), 18 deletions(-) diff --git a/data/viewer.css b/data/viewer.css index 953de09..07c345e 100644 --- a/data/viewer.css +++ b/data/viewer.css @@ -21,7 +21,7 @@ body { display: flex; } z-index: 10; } -#fit-btn { +#fit-btn, #dir-btn { appearance: none; background: #fff; border: 1px solid #cbd5e1; @@ -32,8 +32,8 @@ body { display: flex; } color: #1f2937; box-shadow: 0 1px 3px rgba(15, 23, 42, 0.1); } -#fit-btn:hover { background: #f1f5f9; } -#fit-btn:active { background: #e2e8f0; } +#fit-btn:hover, #dir-btn:hover { background: #f1f5f9; } +#fit-btn:active, #dir-btn:active { background: #e2e8f0; } #help-panel { background: #fff; diff --git a/data/viewer.html b/data/viewer.html index 6db75b5..8ebeee9 100644 --- a/data/viewer.html +++ b/data/viewer.html @@ -18,6 +18,7 @@
+
Help / legend @@ -51,7 +52,7 @@

Controls

Click → highlight + side panel
Double-click a class → instances; a family → type instances
-
/ focuses search · F fits the graph
+
/ focuses search · F fits the graph · L flips layout (top-down ⇄ left-right)
Focus / mute via the right-side buttons (chips appear in the topbar)
diff --git a/data/viewer.js b/data/viewer.js index 1d9067e..15a30c9 100644 --- a/data/viewer.js +++ b/data/viewer.js @@ -93,6 +93,12 @@ const state = { view: null, classId: null }; + // Layout direction for the dagre layout, shared by every view. Class/method + // names are usually wider than tall, so a left-to-right ('LR') flow often + // packs the graph more readably than the default top-to-bottom ('TB'). The + // #dir-btn toggle (and the `L` shortcut) flip this and re-run the layout. + let rankDir = 'TB'; + // Replace the cytoscape elements wholesale. We don't use cy.json({elements}) // because that *merges* by id, which causes per-view data attributes // (e.g. `focused: true` on a class node in the instance view) to bleed @@ -124,7 +130,7 @@ state.classId = null; state.familyId = null; loadGraph(buildClassesView()); - cy.layout({ name: 'dagre', rankDir: 'TB', nodeSep: 50, rankSep: 90 }).run(); + cy.layout({ name: 'dagre', rankDir, nodeSep: 50, rankSep: 90 }).run(); setTopbar('classgraph', ''); setHint('classes'); setBackVisible(false); @@ -143,7 +149,7 @@ state.classId = classId; state.familyId = null; loadGraph(els); - cy.layout({ name: 'dagre', rankDir: 'TB', nodeSep: 30, rankSep: 80 }).run(); + cy.layout({ name: 'dagre', rankDir, nodeSep: 30, rankSep: 80 }).run(); const cls = classById.get(classId); const subtitle = cls ? `${cls.ciName.qnPackage} · ${cls.ciName.qnModule}` : ''; setTopbar(`Instances of ${cls ? cls.ciName.qnName : classId}`, subtitle); @@ -168,7 +174,7 @@ const pan = cy.pan(); const zoom = cy.zoom(); loadGraph(buildInstanceView(state.classId)); - cy.layout({ name: 'dagre', rankDir: 'TB', nodeSep: 30, rankSep: 80 }).run(); + cy.layout({ name: 'dagre', rankDir, nodeSep: 30, rankSep: 80 }).run(); cy.pan(pan); cy.zoom(zoom); const cls = classById.get(state.classId); @@ -305,7 +311,7 @@ const pan = cy.pan(); const zoom = cy.zoom(); loadGraph(buildFamilyView(state.familyId)); - cy.layout({ name: 'dagre', rankDir: 'TB', nodeSep: 30, rankSep: 80 }).run(); + cy.layout({ name: 'dagre', rankDir, nodeSep: 30, rankSep: 80 }).run(); cy.pan(pan); cy.zoom(zoom); const fis = famInstsByFamily.get(state.familyId) || []; @@ -322,7 +328,7 @@ state.classId = null; state.familyId = familyId; loadGraph(els); - cy.layout({ name: 'dagre', rankDir: 'TB', nodeSep: 30, rankSep: 80 }).run(); + cy.layout({ name: 'dagre', rankDir, nodeSep: 30, rankSep: 80 }).run(); const fam = familyById.get(familyId); const subtitle = fam ? `${fam.tfName.qnPackage} · ${fam.tfName.qnModule}` : ''; setTopbar(`Type instances of ${fam ? fam.tfName.qnName : familyId}`, subtitle); @@ -449,7 +455,7 @@ function relayoutClassesView() { if (state.view !== 'classes') return; loadGraph(buildClassesView()); - cy.layout({ name: 'dagre', rankDir: 'TB', nodeSep: 50, rankSep: 90 }).run(); + cy.layout({ name: 'dagre', rankDir, nodeSep: 50, rankSep: 90 }).run(); setCounts(focusCountsLine()); } @@ -2629,6 +2635,9 @@ } else if (evt.key === 'f' || evt.key === 'F') { evt.preventDefault(); fitGraph(); + } else if (evt.key === 'l' || evt.key === 'L') { + evt.preventDefault(); + toggleDirection(); } }); @@ -2638,6 +2647,30 @@ document.getElementById('fit-btn').addEventListener('click', fitGraph); + // Layout-direction toggle. Re-runs the dagre layout on the *current* + // elements (no rebuild) with the flipped rankDir, then fits. The classes + // view uses slightly looser spacing than the drill-in views, mirroring the + // per-view layout calls above. + const dirBtn = document.getElementById('dir-btn'); + function syncDirButton() { + if (!dirBtn) return; + dirBtn.textContent = rankDir === 'TB' ? '⬍ Top-down' : '⬌ Left-right'; + } + function toggleDirection() { + rankDir = rankDir === 'TB' ? 'LR' : 'TB'; + syncDirButton(); + if (state.view === null) return; + const opts = state.view === 'classes' + ? { name: 'dagre', rankDir, nodeSep: 50, rankSep: 90 } + : { name: 'dagre', rankDir, nodeSep: 30, rankSep: 80 }; + cy.layout(opts).run(); + fitGraph(); + } + if (dirBtn) { + syncDirButton(); + dirBtn.addEventListener('click', toggleDirection); + } + // --------------------------------------------------------------------------- // Helpers diff --git a/examples/demo/src/Demo/Equality.hs b/examples/demo/src/Demo/Equality.hs index f66a9cd..93b24f0 100644 --- a/examples/demo/src/Demo/Equality.hs +++ b/examples/demo/src/Demo/Equality.hs @@ -34,3 +34,12 @@ class NormalisesToInt a where instance (Norm a ~ Int, Pretty a) => NormalisesToInt a where toInt _ = 0 + +-- An equality constraint in *superclass* position (not an instance +-- context). Unlike the instance-context equalities above — which surface +-- as chips on the instance node — a superclass equality is part of the +-- class hierarchy, so the classes view draws it as an arrow to a synthetic +-- @(~)@ node labelled @{Norm a} {Int}@. +class (Norm a ~ Int) => NormIsInt a where + normInt :: a -> Int + normInt _ = 0 diff --git a/src/Classgraph/Extract.hs b/src/Classgraph/Extract.hs index 0d5cf38..453731e 100644 --- a/src/Classgraph/Extract.hs +++ b/src/Classgraph/Extract.hs @@ -215,16 +215,30 @@ extractClass mDocs cls = ClassInfo boundTvs = classTyVars cls -- | Decompose one PredType into 0..n 'SuperclassEdge's. Class predicates --- become a single edge; constraint tuples are flattened recursively; --- the boxed equality "classes" @(~)@ and @(~~)@ produce no edge (they --- don't map onto a meaningful class node — they're handled at the --- 'PredInfo' level instead). Quantified/irreducible predicates produce --- no edge either. +-- become a single edge; constraint tuples are flattened recursively. +-- +-- Equality constraints — both the boxed equality "classes" @(~)@ / @(~~)@ +-- and the unboxed 'EqPred' form — become an edge to the equality operator's +-- node (@~@, @~~@, or @Coercible@ for representational equality), carrying +-- both operands as positional args. The two-arg edge then renders the way +-- any multi-param superclass does, e.g. @-{a}-{b}-> (~)@. Quantified / +-- irreducible predicates produce no edge. predToSuperEdges :: [Var] -> Type -> [SuperclassEdge] predToSuperEdges boundTvs predTy = case classifyPredType predTy of ClassPred cls args | isCTupleClass cls -> concatMap (predToSuperEdges boundTvs) args - | isEqClass cls -> [] + | isEqClass cls -> + -- Boxed equality carries leading kind arg(s) before the two + -- operands; keep only the trailing pair (mirrors 'predToPredInfos'). + let ops = if length args >= 2 then drop (length args - 2) args else args + in case ops of + [a, b] -> + [ SuperclassEdge + { seSuperclass = qualName (className cls) + , seArgs = [typeArg boundTvs a, typeArg boundTvs b] + } + ] + _ -> [] | otherwise -> [ SuperclassEdge { seSuperclass = qualName (className cls) @@ -232,7 +246,12 @@ predToSuperEdges boundTvs predTy = case classifyPredType predTy of (visibleArgs (classTyCon cls) args) } ] - EqPred{} -> [] + EqPred eqRel a b -> + [ SuperclassEdge + { seSuperclass = QualName "" "GHC.Builtin" (eqOpName eqRel) + , seArgs = [typeArg boundTvs a, typeArg boundTvs b] + } + ] IrredPred{} -> [] ForAllPred{} -> [] diff --git a/src/Classgraph/Render.hs b/src/Classgraph/Render.hs index 50d2353..0358dfb 100644 --- a/src/Classgraph/Render.hs +++ b/src/Classgraph/Render.hs @@ -16,6 +16,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as BB +import qualified Data.Char as Char import Data.FileEmbed (embedFile) import Data.List (nub, sortOn) import qualified Data.Map.Strict as Map @@ -228,7 +229,7 @@ buildGraph pd sourceRoots = CyGraph externalNodes = [ CyNode $ Aeson.object [ "id" Aeson..= renderQualName q - , "label" Aeson..= qnName q + , "label" Aeson..= externalLabel q , "kind" Aeson..= externalKind q -- Family refs (associated types and FamilyApp use sites) -- are tagged "family" so they get the grey-diamond @@ -248,6 +249,16 @@ buildGraph pd sourceRoots = CyGraph | Set.member (renderQualName q) externalFamilyIds = "family" :: Text | otherwise = "class" + -- Symbolic operator names (the equality operators @~@ / @~~@ reach + -- the canvas as external nodes via equality superclass edges) read + -- better parenthesised, the way they'd appear in prefix position. + externalLabel q = + let nm = qnName q + in if not (T.null nm) && isOperatorChar (T.head nm) + then "(" <> nm <> ")" + else nm + isOperatorChar c = not (Char.isLetter c || c == '_' || c == '(' || c == '[') + -- Helper: like collectFamilyApps but applied to a list of TypeArgs. collectFamilyAppsInArgs as = nub (concatMap collectFamilyApps as) -- 2.54.0