# by GHC version and ask `ghc-pkg` for the library directory.
#
# Override the search by setting CLASSGRAPH_SO directly.
-SO=${CLASSGRAPH_SO:-}
+# Gather *every* candidate .so, then pick one. A single GHC version can
+# have several matching cabal-store directories (cabal namespaces the
+# store per environment, e.g. `ghc-9.14.1-inplace` alongside
+# `ghc-9.14.1-c6c3`), and a local checkout may also have its own build —
+# so we don't commit to the first match. CLASSGRAPH_SO, if set, wins
+# outright and skips discovery entirely.
+GHC_VER=$(ghc --numeric-version 2>/dev/null || true)
+CANDIDATES=()
-if [ -z "$SO" ] && [ -d "dist-newstyle" ]; then
- if [ -z "$(find dist-newstyle -type f -name 'libHSclassgraph-*.so' 2>/dev/null | head -1)" ]; then
- cabal build --silent lib:classgraph 2>/dev/null || true
+if [ -n "${CLASSGRAPH_SO:-}" ]; then
+ CANDIDATES+=("$CLASSGRAPH_SO")
+else
+ # 1. Local build tree. If none is present yet, trigger a build first.
+ if [ -d "dist-newstyle" ]; then
+ if [ -z "$(find dist-newstyle -type f -name 'libHSclassgraph-*.so' 2>/dev/null | head -1)" ]; then
+ cabal build --silent lib:classgraph 2>/dev/null || true
+ fi
+ while IFS= read -r so; do
+ [ -n "$so" ] && CANDIDATES+=("$so")
+ done < <(find dist-newstyle -type f -name 'libHSclassgraph-*.so' 2>/dev/null)
fi
- SO=$(find dist-newstyle -type f -name 'libHSclassgraph-*.so' 2>/dev/null | head -1)
-fi
-if [ -z "$SO" ]; then
- # Fall through to the cabal store (cabal install path).
- GHC_VER=$(ghc --numeric-version 2>/dev/null || true)
- STORE_DIR=$(ls -d "$HOME/.cabal/store/ghc-${GHC_VER}"* 2>/dev/null | head -1)
- if [ -n "$STORE_DIR" ] && [ -d "$STORE_DIR/package.db" ]; then
- LIBDIR=$(ghc-pkg --package-db="$STORE_DIR/package.db" \
- --simple-output field classgraph library-dirs 2>/dev/null \
- | tr ' ' '\n' | head -1)
- UNIT=$(ghc-pkg --package-db="$STORE_DIR/package.db" \
+ # 2. Every cabal-store dir matching this GHC version that actually
+ # registers `classgraph`. We ask ghc-pkg per store (rather than
+ # globbing + head -1) so a store that lacks classgraph is skipped
+ # instead of masking one that has it.
+ if [ -n "$GHC_VER" ]; then
+ for STORE_DIR in "$HOME/.cabal/store/ghc-${GHC_VER}"*; do
+ [ -d "$STORE_DIR/package.db" ] || continue
+ # ghc-pkg exits non-zero for stores that don't register classgraph;
+ # the trailing `|| true` keeps that expected failure from tripping
+ # `set -euo pipefail` so we go on to probe the remaining stores.
+ UNIT=$(ghc-pkg --package-db="$STORE_DIR/package.db" \
--simple-output field classgraph id 2>/dev/null \
- | tr ' ' '\n' | head -1)
- if [ -n "$LIBDIR" ] && [ -n "$UNIT" ]; then
+ | tr ' ' '\n' | head -1 || true)
+ [ -n "$UNIT" ] || continue
+ LIBDIR=$(ghc-pkg --package-db="$STORE_DIR/package.db" \
+ --simple-output field classgraph library-dirs 2>/dev/null \
+ | tr ' ' '\n' | head -1 || true)
candidate="$LIBDIR/libHS${UNIT}-ghc${GHC_VER}.so"
- [ -f "$candidate" ] && SO="$candidate"
- fi
+ [ -f "$candidate" ] && CANDIDATES+=("$candidate")
+ done
fi
fi
-if [ -z "$SO" ] || [ ! -f "$SO" ]; then
+# Canonicalise existing paths and drop duplicates (e.g. a dist-newstyle
+# symlink that resolves into the store).
+declare -A _seen=()
+UNIQUE=()
+if [ "${#CANDIDATES[@]}" -gt 0 ]; then
+ for c in "${CANDIDATES[@]}"; do
+ [ -f "$c" ] || continue
+ abs=$(readlink -f "$c")
+ if [ -z "${_seen[$abs]:-}" ]; then
+ _seen[$abs]=1
+ UNIQUE+=("$abs")
+ fi
+ done
+fi
+
+SO=""
+if [ "${#UNIQUE[@]}" -eq 0 ]; then
echo "Could not find a classgraph plugin .so." >&2
- echo "Tried: ./dist-newstyle/ and ${HOME}/.cabal/store/ghc-${GHC_VER:-?}/." >&2
+ echo "Tried: ./dist-newstyle/ and ${HOME}/.cabal/store/ghc-${GHC_VER:-?}*/." >&2
echo "Build it locally with \`cabal build classgraph\`," >&2
echo "install it with \`cabal install --lib classgraph\`," >&2
echo "or set CLASSGRAPH_SO to the path explicitly." >&2
exit 1
+elif [ "${#UNIQUE[@]}" -eq 1 ]; then
+ SO=${UNIQUE[0]}
+elif [ -r /dev/tty ]; then
+ # More than one — print a numbered list and read the chosen index. The
+ # list and prompt go to stderr and input is read from the controlling
+ # terminal, so a redirected/piped stdout (e.g. `... --cabal >> file`)
+ # still gets a clean flag line.
+ echo "Multiple classgraph plugin .so files found:" >&2
+ i=1
+ for u in "${UNIQUE[@]}"; do
+ printf ' %d) %s\n' "$i" "$u" >&2
+ i=$((i + 1))
+ done
+ while :; do
+ printf 'Enter number [1-%d]: ' "${#UNIQUE[@]}" >&2
+ if ! read -r reply < /dev/tty; then
+ echo >&2
+ echo "No selection made; aborting." >&2
+ exit 1
+ fi
+ if [[ "$reply" =~ ^[0-9]+$ ]] \
+ && [ "$reply" -ge 1 ] && [ "$reply" -le "${#UNIQUE[@]}" ]; then
+ SO=${UNIQUE[$((reply - 1))]}
+ break
+ fi
+ echo "Invalid selection: '$reply'." >&2
+ done
+else
+ # Several candidates but no terminal to prompt on — pick the first and
+ # say so, rather than failing silently.
+ SO=${UNIQUE[0]}
+ echo "Multiple classgraph plugin .so files found; no terminal to prompt." >&2
+ echo "Defaulting to: $SO" >&2
+ echo "(set CLASSGRAPH_SO to choose explicitly)" >&2
fi
+
SO=$(readlink -f "$SO")
# Derive the package-id from the .so file name:
list.innerHTML = parts.join('');
}
- function escapeAttr(s) {
- return String(s).replace(/[&<>"']/g, ch => ({
- '&':'&','<':'<','>':'>','"':'"',"'":''',
- }[ch]));
- }
+ // Attribute-value escaping is identical to text escaping here (both
+ // neutralise & < > " '), so escapeAttr just delegates to escape rather
+ // than duplicating the table. Kept as a named alias for call-site
+ // readability ("this value lands in an attribute").
+ function escapeAttr(s) { return escape(s); }
// ---------------------------------------------------------------------------
// Instance view
// One row of instance nodes, anchored to the focused class.
insts.forEach((inst, idx) => {
+ // Use the instance's stable global _idx for the node id (not the
+ // filtered-row position) so the focused representation and any
+ // superclass-matched representation of the *same* instance collapse
+ // onto one node via seenNodes, and a filtered-out instance can never
+ // reappear through the superclass-match path under a different id.
const instId = ensureInstanceNode(inst, cls.ciName,
- 'inst:focused:' + idx);
+ 'inst:' + inst._idx);
els.push({ group: 'edges', data: {
id: focusedId + '=>' + instId,
source: focusedId,
if (t.tag === 'FamilyApp') {
const [q, args] = t.contents;
const reducedArgs = args.map(reduceTypeArg);
- for (const fi of graph.meta.pdFamInstances) {
- if (qid(fi.fiFamily) !== qid(q)) continue;
+ // Use the family index, which folds in closed-family `tfEquations`
+ // alongside open/associated `pdFamInstances`. Iterating
+ // `pdFamInstances` directly (as this once did) skipped closed-family
+ // equations entirely, so closed-family applications never reduced and
+ // showed up as spurious "unresolved external family" placeholders.
+ for (const fi of (famInstsByFamily.get(qid(q)) || [])) {
// Skip data fam-instances: their fiRhs is opaque (the
// synthetic R: TyCon, or after the data-family rewrite the
// *abstract* FamilyApp form that's structurally equal to the
}
// Search graph.meta.pdInstances for an instance of `classQn` whose head
- // args structurally match `reqArgs`. Variables (TyVarRef) on either side
- // act as wildcards — this is intentionally permissive so the user sees
- // all candidate satisfiers; precise unification is left to the next
- // iteration.
+ // args structurally match `reqArgs`. Matching is one-sided (see
+ // matchTypeArg): a variable in the instance *head* is polymorphic and
+ // covers any requirement, but a variable left in the *requirement* is
+ // still abstract and is only satisfied by another variable — a concrete
+ // instance does not discharge it. This avoids the old behaviour where an
+ // unsubstituted (e.g. uncovered multi-param) requirement variable matched
+ // every instance of the class, drawing false "satisfied" edges.
function findMatchingInstances(classQn, reqArgs) {
const target = qid(classQn);
const matches = [];
function matchTypeArg(h, r) {
if (!h || !r) return false;
- // TyVarRef on either side acts as a wildcard.
- if (h.tag === 'TyVarRef' || r.tag === 'TyVarRef') return true;
+ // A variable in the instance head is polymorphic: it matches anything
+ // on the requirement side (concrete or variable).
+ if (h.tag === 'TyVarRef') return true;
+ // A variable that survives on the requirement side is still abstract;
+ // a concrete instance head does not discharge it. (The head-is-variable
+ // case is already handled above, so reaching here means h is concrete.)
+ if (r.tag === 'TyVarRef') return false;
if (h.tag !== r.tag) return false;
if (h.tag === 'TyConApp' || h.tag === 'FamilyApp') {
const [hq, hargs] = h.contents;
let s = escape(text);
// Markdown link: [text](url). Run before @code@ so @ inside URLs
- // doesn't get swallowed.
+ // doesn't get swallowed. Only http(s)/mailto and relative (#, /, .)
+ // targets are turned into links; anything else (notably `javascript:`
+ // and `data:`) is left as the original literal text, since doc strings
+ // come from arbitrary Haddock comments in scanned packages and an
+ // unescaped scheme here would be an XSS vector.
s = s.replace(/\[([^\]\n]+?)\]\(([^)\n]+?)\)/g,
- (_m, label, url) => `<a href="${url}">${label}</a>`);
+ (_m, label, url) =>
+ /^(https?:|mailto:|[#/.])/i.test(url)
+ ? `<a href="${url}">${label}</a>`
+ : _m);
// Inline code: @text@. Non-greedy, no newlines or @ inside.
s = s.replace(/@([^@\n]+?)@/g, '<code>$1</code>');
( Type
, getTyVar_maybe
, isLitTy
+ , mkTyVarTy
, splitTyConApp_maybe
, splitVisibleFunTy_maybe
+ , substTy
, substTys
, zipTvSubst
)
extractModule :: Maybe Docs -> TcGblEnv -> ProgramData
extractModule mDocs env = ProgramData
- { pdClasses = mapMaybe (extractClass mDocs) localClasses
+ { pdClasses = map (extractClass mDocs) localClasses
, pdInstances = map (extractInstance mDocs) (tcg_insts env)
, pdTypeFamilies = mapMaybe (extractTypeFamily mDocs assocByName) allFams
, pdFamInstances = map (extractFamInst mDocs) (tcg_fam_insts env)
------------------------------------------------------------------------------
-- Classes
-extractClass :: Maybe Docs -> Class -> Maybe ClassInfo
-extractClass mDocs cls = Just ClassInfo
+extractClass :: Maybe Docs -> Class -> ClassInfo
+extractClass mDocs cls = ClassInfo
{ ciName = qualName (className cls)
, ciTyVars = map tyVarInfo (classTyVars cls)
, ciSuperclasses = concatMap (predToSuperEdges boundTvs) (classSCTheta cls)
[ PredInfo
{ piClass = QualName "<builtin>" "GHC.Builtin" (eqOpName eqRel)
, piArgs = [typeArg boundTvs a, typeArg boundTvs b]
- , piIsEq = True
+ -- Nominal equality (@a ~ b@) renders infix; representational
+ -- equality is the @Coercible@ class, which reads naturally as a
+ -- prefix application (@Coercible a b@), not infix.
+ , piIsEq = case eqRel of NomEq -> True; ReprEq -> False
}
]
IrredPred{} -> []
eqOpName :: EqRel -> Text
eqOpName NomEq = "~"
-eqOpName ReprEq = "Coercible" -- shows up as "a ~R b" sometimes; closest readable form
+eqOpName ReprEq = "Coercible"
------------------------------------------------------------------------------
-- Type families
, fiDefinedIn = Nothing -- filled in by Classgraph.Merge
, fiDataCons = case fi_flavor fi of
SynFamilyInst -> []
- DataFamilyInst rep_tc -> map (extractDataCon (fi_tvs fi))
+ DataFamilyInst rep_tc -> map (extractDataCon (fi_tvs fi) rep_tc)
(tyConDataCons rep_tc)
}
-- 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
+--
+-- The constructor's 'dataConOrigArgTys' are expressed in terms of the
+-- /representation/ TyCon's universal tyvars, which are not guaranteed to
+-- be the same 'Var's as the fam-instance's @boundTvs@ (they often are, but
+-- GHC may freshen or reorder them — and for poly-kinded families they
+-- differ). We therefore substitute the rep TyCon's tyvars to @boundTvs@
+-- before converting, so 'typeArg' can resolve them to the correct
+-- positional 'TyVarRef' instead of degrading to an 'OtherArg' (or, worse,
+-- picking up a wrong index).
+extractDataCon :: [Var] -> TyCon -> DataCon -> DataConInfo
+extractDataCon boundTvs repTc dc = DataConInfo
{ dcName = T.pack (occNameString (nameOccName (dataConName dc)))
- , dcArgs = map (\(Scaled _ ty) -> typeArg boundTvs ty)
+ , dcArgs = map (\(Scaled _ ty) -> typeArg boundTvs (substTy sub ty))
(dataConOrigArgTys dc)
, dcFieldLabels = map (T.pack . unpackFS . field_label . flLabel)
(dataConFieldLabels dc)
}
+ where
+ sub = zipTvSubst (tyConTyVars repTc) (map mkTyVarTy boundTvs)
------------------------------------------------------------------------------
-- The structured-type-arg converter
import Control.Monad (filterM)
import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy as BL
+import Data.List (sortOn)
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import Data.Text (Text)
-- raw package ids differ. We strip the version-and-suffix tail.
mergeDumps :: [ModuleDump] -> ProgramData
mergeDumps dumps =
- let normalised = map (mapDumpQNs normalisePackageInQN) dumps
+ let -- 'readDumpsInDir' lists files in filesystem order, which is
+ -- unspecified and varies across machines. Sort dumps by
+ -- (package, module) first so the "first occurrence wins"
+ -- deduplication below — and the order of non-deduplicated
+ -- instances in the rendered output — is reproducible.
+ ordered = sortOn (\d -> (mdPackage d, mdModule d)) dumps
+ normalised = map (mapDumpQNs normalisePackageInQN) ordered
-- For instances and family instances we additionally tag each item
-- with the (normalised) package id of its defining 'ModuleDump'.
-- 'iiClass'/'fiFamily' record the class/family's *defining*
-- @cardano-ledger-shelley-1.18.1.0-inplace@ and
-- @cardano-ledger-shelley-1.18.1.0-734aab…@ both collapse to
-- @cardano-ledger-shelley@. The heuristic: split on @-@, find the first
--- segment that starts with a digit (the version), keep everything before
--- it. Falls back to the original string if no such segment exists.
+-- segment that is a Cabal /version/ (digits and dots only, e.g.
+-- @1.18.1.0@ or @1@), keep everything before it. Falls back to the
+-- original string if no such segment exists.
+--
+-- Testing for a full digits-and-dots segment — rather than merely
+-- "starts with a digit" — avoids truncating legitimate name segments
+-- that happen to begin with a digit (e.g. the @3d@ in a hypothetical
+-- @foo-3d-utils@, or @16@ in @base16-bytestring@'s @base16@), which the
+-- looser rule would mistake for a version boundary.
normalisePackageId :: Text -> Text
normalisePackageId pkg =
let parts = T.splitOn "-" pkg
- isVersionPart t = case T.uncons t of
- Just (c, _) -> c >= '0' && c <= '9'
- Nothing -> False
+ isVersionPart t =
+ not (T.null t)
+ && T.all (\c -> (c >= '0' && c <= '9') || c == '.') t
+ && case T.uncons t of
+ Just (c, _) -> c >= '0' && c <= '9'
+ Nothing -> False
name = T.intercalate "-" (takeWhile (not . isVersionPart) parts)
in if T.null name then pkg else name
import Classgraph.Extract (currentModuleNames, extractModule)
import Classgraph.Schema (ModuleDump (..))
+-- | We declare the plugin 'purePlugin', i.e. its presence does not force
+-- recompilation. 'typeCheckResultAction' therefore runs only when GHC
+-- actually re-typechecks a module (a source/dependency change). That is
+-- the right granularity: a module's class/instance/family declarations
+-- can only change when the module itself is recompiled, and the per-module
+-- JSON dumps are /persistent/ artifacts — an incremental build rewrites
+-- only the changed modules' dumps, while the rest stay on disk from the
+-- previous build, so a subsequent merge still sees every module.
+--
+-- The one caveat: a module that has /never/ been compiled since the output
+-- directory was last cleared produces no dump. If you wipe @.classgraph/@
+-- (or merge a fresh checkout), do a clean build — or at least @touch@ the
+-- relevant sources — before rendering, so every module is visited once.
plugin :: Plugin
plugin = defaultPlugin
{ typeCheckResultAction = collect
renderProgramWith :: ProgramData -> Map.Map Text FilePath -> BL.ByteString
renderProgramWith pd sourceRoots =
let graph = buildGraph pd sourceRoots
- jsonBs = Aeson.encode graph
+ jsonBs = escapeForScript (Aeson.encode graph)
page = TE.decodeUtf8 viewerHtml
pageBuilder = substitutePlaceholders
[ ("/*__VENDOR_CYTOSCAPE__*/", BB.byteString vendorCytoscape)
(x : _) -> Just x
[] -> Nothing
+-- | Escape every @<@ byte as the JSON unicode escape @\\u003c@ before the
+-- encoded program data is spliced into @<script type="application/json">@.
+-- Aeson does not escape @<@ or @/@, so a string containing the literal
+-- @</script>@ (e.g. inside a Haddock comment) would otherwise close the
+-- script element early and corrupt — or inject into — the page. Inside a
+-- JSON string @\\u003c@ decodes back to @<@; outside strings @<@ never
+-- appears in JSON, so replacing the byte unconditionally is safe and keeps
+-- the document valid. @<@ is ASCII (0x3c) and cannot occur inside a UTF-8
+-- multibyte sequence, so a byte-level rewrite is correct.
+escapeForScript :: BL.ByteString -> BL.ByteString
+escapeForScript = BL.concatMap esc
+ where
+ esc 0x3c = BL.pack [0x5c, 0x75, 0x30, 0x30, 0x33, 0x63] -- "<"
+ esc c = BL.singleton c
+
------------------------------------------------------------------------------
-- Substitution helper
projects / classgraph.git / commitdiff