From: Javier Sagredo <javier.sagredo@iohk.io>
Date: Thu, 18 Jun 2026 22:26:09 +0000 (+0200)
Subject: Fix correctness, robustness, and tooling issues from code review
X-Git-Url: https://git.sagredo.dev/?a=commitdiff_plain;h=e2aa1bdb1d82ce0c5a4111aaa73d1ac4d30c71ad;p=classgraph.git

Fix correctness, robustness, and tooling issues from code review

Render: escape `<` to < in the embedded JSON so a `</script>` in any
string (e.g. a Haddock comment) can't close the data <script> early or
inject markup.

viewer.js:
  - Haddock markdown links: allowlist http(s)/mailto/relative targets so a
    `javascript:`/`data:` URL in a doc comment can't become a clickable XSS.
  - reduceTypeArg: iterate the family index (which folds in closed-family
    `tfEquations`) instead of only `pdFamInstances`, so closed-family
    applications actually reduce instead of showing as unresolved.
  - matchTypeArg: one-sided matching — a head variable is polymorphic and
    matches anything, but a variable left on the requirement side is
    abstract and no longer matches concrete instances (kills false
    "satisfied" edges).
  - Instance-view node ids use the stable global _idx so the focused and
    superclass-matched representations of one instance collapse to a single
    node and a filtered-out instance can't reappear under a second id.
  - escapeAttr now delegates to escape (one implementation).

Extract:
  - Data-family constructor arg types are substituted from the rep TyCon's
    tyvars to the fam-instance's, so positional TyVarRefs resolve instead of
    degrading to OtherArg.
  - Representational equality renders as the `Coercible a b` constraint
    (prefix) rather than infix.
  - Drop the always-Just Maybe from extractClass.

Merge:
  - Sort dumps by (package, module) before merging so dedup ("first wins")
    and output ordering are reproducible across filesystems.
  - normalisePackageId: treat a segment as a version only when it is
    digits-and-dots, not merely digit-led (avoids truncating names like
    base16-bytestring).

Plugin: document the purePlugin incremental-build behavior and the
clean-build caveat.

classgraph-plugin-flag.sh: collect every candidate .so (local build tree +
each cabal store that actually registers classgraph), offer a numbered
chooser when more than one is found, and stop an expected ghc-pkg failure
from tripping `set -e`.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
---

diff --git a/classgraph-plugin-flag.sh b/classgraph-plugin-flag.sh
index f7a5e0a..7dee35e 100755
--- a/classgraph-plugin-flag.sh
+++ b/classgraph-plugin-flag.sh
@@ -59,41 +59,110 @@ done
 #      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:
diff --git a/data/viewer.js b/data/viewer.js
index d745020..508567b 100644
--- a/data/viewer.js
+++ b/data/viewer.js
@@ -497,11 +497,11 @@
     list.innerHTML = parts.join('');
   }
 
-  function escapeAttr(s) {
-    return String(s).replace(/[&<>"']/g, ch => ({
-      '&':'&amp;','<':'&lt;','>':'&gt;','"':'&quot;',"'":'&#39;',
-    }[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
@@ -868,8 +868,13 @@
 
     // 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,
@@ -1164,8 +1169,12 @@
     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
@@ -1336,10 +1345,13 @@
   }
 
   // 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 = [];
@@ -1360,8 +1372,13 @@
 
   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;
@@ -1781,9 +1798,16 @@
     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>');
diff --git a/src/Classgraph/Extract.hs b/src/Classgraph/Extract.hs
index 660d161..3799513 100644
--- a/src/Classgraph/Extract.hs
+++ b/src/Classgraph/Extract.hs
@@ -82,8 +82,10 @@ import GHC.Core.Type
   ( Type
   , getTyVar_maybe
   , isLitTy
+  , mkTyVarTy
   , splitTyConApp_maybe
   , splitVisibleFunTy_maybe
+  , substTy
   , substTys
   , zipTvSubst
   )
@@ -165,7 +167,7 @@ lookupDoc (Just d) n =
 
 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)
@@ -199,8 +201,8 @@ extractModule mDocs env = ProgramData
 ------------------------------------------------------------------------------
 -- 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)
@@ -314,7 +316,10 @@ predToPredInfos boundTvs predTy = case classifyPredType predTy of
     [ 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{}  -> []
@@ -322,7 +327,7 @@ predToPredInfos boundTvs predTy = case classifyPredType predTy of
 
 eqOpName :: EqRel -> Text
 eqOpName NomEq  = "~"
-eqOpName ReprEq = "Coercible"  -- shows up as "a ~R b" sometimes; closest readable form
+eqOpName ReprEq = "Coercible"
 
 ------------------------------------------------------------------------------
 -- Type families
@@ -404,7 +409,7 @@ extractFamInst mDocs fi = FamInstInfo
   , 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)
   }
 
@@ -412,14 +417,25 @@ extractFamInst mDocs fi = FamInstInfo
 -- 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
diff --git a/src/Classgraph/Merge.hs b/src/Classgraph/Merge.hs
index 034da01..acd75ec 100644
--- a/src/Classgraph/Merge.hs
+++ b/src/Classgraph/Merge.hs
@@ -13,6 +13,7 @@ module Classgraph.Merge
 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)
@@ -60,7 +61,13 @@ readDump fp = do
 -- 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*
@@ -97,14 +104,24 @@ dedupOn key = Map.elems . Map.fromListWith (\_new old -> old) . map (\x -> (key
 -- @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
 
diff --git a/src/Classgraph/Plugin.hs b/src/Classgraph/Plugin.hs
index 98a8649..7eee99a 100644
--- a/src/Classgraph/Plugin.hs
+++ b/src/Classgraph/Plugin.hs
@@ -30,6 +30,19 @@ import GHC.Unit.Module.ModSummary (ModSummary)
 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
diff --git a/src/Classgraph/Render.hs b/src/Classgraph/Render.hs
index 67d283b..83cee0b 100644
--- a/src/Classgraph/Render.hs
+++ b/src/Classgraph/Render.hs
@@ -56,7 +56,7 @@ renderProgram pd = renderProgramWith pd Map.empty
 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)
@@ -338,6 +338,21 @@ safeIndex i xs
       (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