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
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);
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);
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);
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) || [];
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);
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());
}
} else if (evt.key === 'f' || evt.key === 'F') {
evt.preventDefault();
fitGraph();
+ } else if (evt.key === 'l' || evt.key === 'L') {
+ evt.preventDefault();
+ toggleDirection();
}
});
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
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)
(visibleArgs (classTyCon cls) args)
}
]
- EqPred{} -> []
+ EqPred eqRel a b ->
+ [ SuperclassEdge
+ { seSuperclass = QualName "<builtin>" "GHC.Builtin" (eqOpName eqRel)
+ , seArgs = [typeArg boundTvs a, typeArg boundTvs b]
+ }
+ ]
IrredPred{} -> []
ForAllPred{} -> []
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
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
| 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)
projects / classgraph.git / commitdiff