From: Javier Sagredo Date: Wed, 6 May 2026 22:05:20 +0000 (+0200) Subject: Infer per-package source roots from classgraph-view --input X-Git-Url: https://git.sagredo.dev/?a=commitdiff_plain;h=0bea00aad508aa862533ba2a4a8ab18bc3e5d02a;p=classgraph.git Infer per-package source roots from classgraph-view --input Add a --source-root PKG=PATH override and infer a default per-package root from each --input dir's parent. Schema gains iiDefinedIn / fiDefinedIn (filled in at merge time from the dump's mdPackage), so orphan instances resolve under the *defining* package, not the class's. Render embeds the resulting map; viewer's editor links look up the per-package root before falling back to the localStorage override. Co-Authored-By: Claude Opus 4.7 (1M context) --- diff --git a/README.md b/README.md index fb124d6..046d0fe 100644 --- a/README.md +++ b/README.md @@ -279,13 +279,38 @@ The side panel has an `Editor link` block at the top with two settings | Setting | What it does | |---|---| | **Editor** | Picks a URL scheme — VS Code, VS Code Insiders, Cursor, IntelliJ family, TextMate (`txmt://`), or plain `file://`. Set it to *off* to keep `Defined at` as plain text. | -| **Source root** | Absolute prefix prepended to relative paths. The plugin records source paths as GHC saw them (usually relative to each package's source dir), so this needs to be set for `vscode://` etc. to resolve them. | +| **Source root override** | Absolute prefix prepended to relative paths when no per-package root is known. Usually leave blank — `classgraph-view` infers roots from `--input` (see below). | -Once both are set, every `Defined at` line in the panel becomes a -clickable link that opens the file at the right line in your editor. -Schemes that take a column ( `vscode`, `cursor`, `txmt`) get one; +Once an editor is chosen, every `Defined at` line in the panel becomes +a clickable link that opens the file at the right line in your editor. +Schemes that take a column (`vscode`, `cursor`, `txmt`) get one; `idea` and `file` ignore it. +**Source roots are inferred automatically.** The plugin records source +paths as GHC saw them (usually relative to each package's source dir), +so the viewer needs an absolute prefix to make `vscode://` / +`cursor://` /etc URLs resolvable. `classgraph-view` does this for you: + +- For each `--input DIR`, the *parent* of `DIR` is used as the source + root for every package whose dumps live there. So + `--input ~/code/my-app/.classgraph/` means `~/code/my-app/` is the + root for the `my-app` package. +- Repeat `--input` for multi-package merges; each package gets the + root inferred from its own input dir. +- Override per-package with `--source-root PKG=PATH` (repeatable): + + ```bash + cabal run classgraph-view -- \ + --input ~/code/foo/.classgraph \ + --input ~/code/bar/sub/.classgraph \ + --source-root bar=~/code/bar \ + --output combined.html + ``` + +The "Source root override" field in the panel is a global fallback +applied only when no inferred root exists for the file's package — +useful when you've been handed an HTML file built elsewhere. + ## Schema, data flow, design notes For a deeper walkthrough of where every piece of information comes diff --git a/app/Main.hs b/app/Main.hs index 897ee76..e836a15 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -3,14 +3,23 @@ module Main (main) where import qualified Data.ByteString.Lazy as BL +import qualified Data.Map.Strict as Map +import Data.Maybe (mapMaybe) +import qualified Data.Text as T import Options.Applicative +import System.Directory (canonicalizePath, doesDirectoryExist) +import System.FilePath (dropTrailingPathSeparator, takeDirectory) -import Classgraph.Merge (mergeDirs) -import Classgraph.Render (renderProgram) +import Classgraph.Merge (mergeDirs, normalisePackageId, readDumpsInDir) +import Classgraph.Render (renderProgramWith) +import Classgraph.Schema (ModuleDump (..)) data Opts = Opts - { optInputs :: ![FilePath] - , optOutput :: !FilePath + { optInputs :: ![FilePath] + , optOutput :: !FilePath + , optSourceRoots :: ![(T.Text, FilePath)] + -- ^ Explicit @--source-root pkg=PATH@ overrides. Take precedence over + -- the per-input-dir default inferred below. } opts :: Parser Opts @@ -30,6 +39,21 @@ opts = Opts <> value "classgraph.html" <> showDefault <> help "Path to write the self-contained HTML viewer." ) + <*> many + (option (eitherReader parseSourceRoot) + ( long "source-root" + <> metavar "PKG=PATH" + <> help "Override the source-root prefix used by the viewer's \ + \\"open in editor\" links for a single package. PKG is \ + \the (normalised) package id (no -version-hash suffix); \ + \PATH is an absolute filesystem path. May be repeated. \ + \When omitted, the viewer infers each package's root \ + \from its --input directory's parent." )) + where + parseSourceRoot s = case break (== '=') s of + (pkg, '=' : path) | not (null pkg), not (null path) -> + Right (T.pack pkg, path) + _ -> Left "expected --source-root PKG=PATH" main :: IO () main = do @@ -40,8 +64,63 @@ main = do let inputs = case optInputs o of [] -> [".classgraph"] xs -> xs - pd <- mergeDirs inputs - BL.writeFile (optOutput o) (renderProgram pd) + pd <- mergeDirs inputs + sourceRoots <- discoverSourceRoots inputs (optSourceRoots o) + BL.writeFile (optOutput o) (renderProgramWith pd sourceRoots) putStrLn $ "Wrote " <> optOutput o <> " (merged " <> show (length inputs) <> " input dir" <> (if length inputs == 1 then ")" else "s)") + putStrLn $ " source roots: " <> show (Map.size sourceRoots) <> + " package(s) with editor-link prefixes" + +-- | Build the per-package source-root map. For each input directory, we +-- read its dumps, see which (normalised) packages they belong to, and +-- assign that input dir's parent as the default source root for those +-- packages. Explicit @--source-root@ overrides win. +-- +-- /First-wins/ at each layer: if multiple input dirs report the same +-- package, the first one's parent is kept. CLI overrides win over any +-- inferred value. +discoverSourceRoots + :: [FilePath] -- ^ input dirs + -> [(T.Text, FilePath)] -- ^ explicit --source-root overrides + -> IO (Map.Map T.Text FilePath) +discoverSourceRoots inputs overrides = do + inferred <- inferFromInputs inputs + overrideAbs <- mapM canonicaliseEntry overrides + -- Map.union is left-biased — overrides take precedence. + pure (Map.union (Map.fromList overrideAbs) inferred) + where + canonicaliseEntry (pkg, path) = do + ok <- doesDirectoryExist path + abs' <- if ok then canonicalizePath path else pure path + pure (pkg, abs') + +inferFromInputs :: [FilePath] -> IO (Map.Map T.Text FilePath) +inferFromInputs [] = pure Map.empty +inferFromInputs (dir:rest) = do + -- Default root = the input directory's parent (cabal projects keep + -- their @.classgraph/@ directly under the package source dir). + exists <- doesDirectoryExist dir + rootAbs <- if exists + then canonicalizePath (takeDirectory (dropTrailingPathSeparator dir)) + else pure (takeDirectory (dropTrailingPathSeparator dir)) + pkgs <- packagesIn dir + let here = Map.fromList [ (p, rootAbs) | p <- pkgs ] + later <- inferFromInputs rest + -- Map.union is left-biased: first occurrence wins, matching the + -- "first --input that mentions a package decides its root" rule. + pure (Map.union here later) + +packagesIn :: FilePath -> IO [T.Text] +packagesIn dir = do + exists <- doesDirectoryExist dir + if not exists + then pure [] + else do + dumps <- readDumpsInDir dir + pure (uniq (mapMaybe pkgOf dumps)) + where + pkgOf d = let p = normalisePackageId (mdPackage d) + in if T.null p then Nothing else Just p + uniq = Map.keys . Map.fromList . map (\x -> (x, ())) diff --git a/classgraph.cabal b/classgraph.cabal index a3dc0ab..8718f03 100644 --- a/classgraph.cabal +++ b/classgraph.cabal @@ -53,5 +53,8 @@ executable classgraph-view build-depends: base , classgraph , bytestring + , containers + , directory + , filepath , optparse-applicative ^>=0.19 , text diff --git a/data/viewer.html b/data/viewer.html index 8b99c44..b99b056 100644 --- a/data/viewer.html +++ b/data/viewer.html @@ -89,10 +89,10 @@
- - + +
-

Most schemes (vscode, cursor, idea, …) need absolute paths. The plugin records source paths as GHC saw them — usually relative to the package's source dir; prefix that here.

+

Most schemes (vscode, cursor, idea, …) need absolute paths. classgraph-view infers a per-package source root from each --input directory's parent (and any explicit --source-root pkg=PATH arg). Use this field only when the inferred root is wrong or missing.

Muted classes (0) diff --git a/data/viewer.js b/data/viewer.js index efb0844..f932981 100644 --- a/data/viewer.js +++ b/data/viewer.js @@ -8,6 +8,12 @@ const raw = document.getElementById('graph-data').textContent; const graph = JSON.parse(raw); + // Per-package source-root prefixes inferred at render time from the + // CLI's --input arguments (and any explicit --source-root overrides). + // The viewer prefers these over the localStorage override; they're + // baked into the HTML so a freshly-built page already has working + // editor links without any client-side configuration. + const inferredSourceRoots = (graph && graph.sourceRoots) || {}; // --------------------------------------------------------------------------- // Indexes over the program data @@ -1315,15 +1321,33 @@ }; } + // Pick the source root to use for a relative file path: per-package + // root (inferred from --input at render time) wins; the localStorage + // override only applies when no per-package root is known. The + // override is global, so it's a poor fit for multi-package merges — + // we keep it strictly as a fallback. + function pickSourceRoot(pkg, fallbackRoot) { + if (pkg && Object.prototype.hasOwnProperty.call(inferredSourceRoots, pkg)) { + return inferredSourceRoots[pkg]; + } + return fallbackRoot; + } + // Build the editor URL for the given file:line:col. Returns null when - // no scheme is configured (caller falls back to plain text). - function buildEditorUrl(file, line, col) { - const { scheme, root } = readEditorSettings(); + // no scheme is configured (caller falls back to plain text). @pkg@ is + // the (normalised) package id whose source root should be applied to + // any relative @file@; pass @null@ to use only the localStorage + // override. + function buildEditorUrl(file, line, col, pkg) { + const { scheme, root: overrideRoot } = readEditorSettings(); if (!scheme || !file) return null; let abs = file; - if (!/^([a-zA-Z]:)?\//.test(file) && root) { - // Relative path — prepend the configured root. - abs = root.replace(/\/+$/, '') + '/' + file.replace(/^\/+/, ''); + if (!/^([a-zA-Z]:)?\//.test(file)) { + // Relative path — prepend whichever root applies. + const root = pickSourceRoot(pkg, overrideRoot); + if (root) { + abs = root.replace(/\/+$/, '') + '/' + file.replace(/^\/+/, ''); + } } const enc = encodeURI(abs); switch (scheme) { @@ -1343,11 +1367,13 @@ } // Render a SrcSpanInfo as a `
` cell — clickable when an editor - // scheme is configured, plain text otherwise. - function renderDefinedAt(src) { + // scheme is configured, plain text otherwise. @pkg@ should be the + // (normalised) defining-package id of the entity whose source span + // this is, so per-package source-root inference works. + function renderDefinedAt(src, pkg) { if (!src) return '
unknown
'; const text = `${src.ssFile}:${src.ssStartLine}:${src.ssStartCol}`; - const url = buildEditorUrl(src.ssFile, src.ssStartLine, src.ssStartCol); + const url = buildEditorUrl(src.ssFile, src.ssStartLine, src.ssStartCol, pkg); if (!url) return `
${escape(text)}
`; return `
${escape(text)}
`; } @@ -1393,7 +1419,7 @@ c.ciAssocTypes.map(a => `
${escape(a.qnName)}
`).join(''); const meths = c.ciMethods.length === 0 ? '
none
' : `
${c.ciMethods.map(escape).join(', ')}
`; - const src = renderDefinedAt(c.ciSrc); + const src = renderDefinedAt(c.ciSrc, c.ciName.qnPackage); const numInsts = (instancesByClass.get(cid) || []).length; return `

${escape(c.ciName.qnName)}

@@ -1427,7 +1453,7 @@ .join(''); const flav = (typeof f.tfFlavor === 'string') ? f.tfFlavor : (f.tfFlavor.tag || JSON.stringify(f.tfFlavor)); - const src = renderDefinedAt(f.tfSrc); + const src = renderDefinedAt(f.tfSrc, f.tfName.qnPackage); return `

${escape(f.tfName.qnName)}

${escape(f.tfName.qnPackage)} · ${escape(f.tfName.qnModule)}

@@ -1454,7 +1480,10 @@ const tvs = inst.iiTyVars.length === 0 ? '
none
' : `
    ${inst.iiTyVars.map(v => `
  • ${escape(v.tvName)} :: ${escape(v.tvKind)}
    • `).join('')}
`; - const src = renderDefinedAt(inst.iiSrc); + // For the instance, prefer iiDefinedIn (the *defining* package) over + // the class's package — for orphan instances those differ, and the + // source path is recorded relative to the defining package. + const src = renderDefinedAt(inst.iiSrc, inst.iiDefinedIn || inst.iiClass.qnPackage); return `

${head}

${escape(inst.iiClass.qnPackage)} · ${escape(inst.iiClass.qnModule)}

@@ -1481,7 +1510,7 @@ const tvs = fi.fiTyVars.length === 0 ? '
none
' : `
    ${fi.fiTyVars.map(v => `
  • ${escape(v.tvName)} :: ${escape(v.tvKind)}
    • `).join('')}
`; - const src = renderDefinedAt(fi.fiSrc); + const src = renderDefinedAt(fi.fiSrc, fi.fiDefinedIn || fi.fiFamily.qnPackage); return `

${head}

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

diff --git a/src/Classgraph/Extract.hs b/src/Classgraph/Extract.hs index 7e5d7c6..5de9e1a 100644 --- a/src/Classgraph/Extract.hs +++ b/src/Classgraph/Extract.hs @@ -255,6 +255,11 @@ extractInstance mDocs inst = -- UnhelpfulSpan, hence "unknown" in the side panel. , iiSrc = srcSpanInfo (nameSrcSpan dfunName) , iiDoc = lookupDoc mDocs dfunName + , iiDefinedIn = Nothing + -- ^ Filled in by 'Classgraph.Merge' from the enclosing + -- 'ModuleDump's package id (after normalisation). The plugin + -- itself doesn't bother — at extraction time the package id is + -- already known via 'currentModuleNames' / 'mdPackage'. } orphanFlag :: IsOrphan -> Bool @@ -352,6 +357,7 @@ extractClosedBranch tc br = FamInstInfo -- Closed-family branches don't have their own Haddock-targeted Name; -- documentation on the family declaration itself ends up on tfDoc -- of the enclosing TypeFamilyInfo. + , fiDefinedIn = Nothing -- filled in by Classgraph.Merge } extractFamInst :: Maybe Docs -> FamInst -> FamInstInfo @@ -380,6 +386,7 @@ extractFamInst mDocs fi = FamInstInfo -- TyCon's Name. If multiple instances of the same family carry -- 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 } ------------------------------------------------------------------------------ diff --git a/src/Classgraph/Merge.hs b/src/Classgraph/Merge.hs index 9e05642..034da01 100644 --- a/src/Classgraph/Merge.hs +++ b/src/Classgraph/Merge.hs @@ -6,6 +6,8 @@ module Classgraph.Merge ( mergeDir , mergeDirs , mergeDumps + , readDumpsInDir + , normalisePackageId ) where import Control.Monad (filterM) @@ -59,14 +61,30 @@ readDump fp = do mergeDumps :: [ModuleDump] -> ProgramData mergeDumps dumps = let normalised = map (mapDumpQNs normalisePackageInQN) dumps + -- 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* + -- package, which for orphans is unrelated to the instance's source + -- file — so we can't recover this information after the merge. + tagged = map tagDefinedIn normalised in ProgramData - { pdClasses = dedupOn ciName (concatMap (pdClasses . mdData) normalised) - , pdInstances = concatMap (pdInstances . mdData) normalised + { pdClasses = dedupOn ciName (concatMap (pdClasses . mdData) tagged) + , pdInstances = concatMap (pdInstances . mdData) tagged -- Instances aren't deduplicated: each is uniquely identified by class -- + arg types, but its serialised form already contains everything we -- need; collisions are unlikely except for re-extracted modules. - , pdTypeFamilies = dedupOn tfName (concatMap (pdTypeFamilies . mdData) normalised) - , pdFamInstances = concatMap (pdFamInstances . mdData) normalised + , pdTypeFamilies = dedupOn tfName (concatMap (pdTypeFamilies . mdData) tagged) + , pdFamInstances = concatMap (pdFamInstances . mdData) tagged + } + +tagDefinedIn :: ModuleDump -> ModuleDump +tagDefinedIn d = + let pkg = normalisePackageId (mdPackage d) + pd = mdData d + in d { mdData = pd + { pdInstances = [ i { iiDefinedIn = Just pkg } | i <- pdInstances pd ] + , pdFamInstances = [ fi { fiDefinedIn = Just pkg } | fi <- pdFamInstances pd ] + } } dedupOn :: Ord k => (a -> k) -> [a] -> [a] diff --git a/src/Classgraph/Render.hs b/src/Classgraph/Render.hs index 10931ed..b6e9436 100644 --- a/src/Classgraph/Render.hs +++ b/src/Classgraph/Render.hs @@ -8,6 +8,7 @@ -- emitted HTML page works fully offline as a single file. module Classgraph.Render ( renderProgram + , renderProgramWith ) where import qualified Data.Aeson as Aeson @@ -44,8 +45,17 @@ vendorCytoscapeDagre = $(embedFile "data/vendor/cytoscape-dagre.min.js") -- | Produce a self-contained HTML document visualising the superclass DAG -- and associated-type-family relationships in the given 'ProgramData'. renderProgram :: ProgramData -> BL.ByteString -renderProgram pd = - let graph = buildGraph pd +renderProgram pd = renderProgramWith pd Map.empty + +-- | Like 'renderProgram', but additionally records a per-package +-- /source root/ map. The viewer uses these absolute paths to turn the +-- relative file paths in @ssFile@ entries into clickable links that +-- open in the user's editor. Keys are normalised package ids +-- (matching 'iiDefinedIn' and 'qnPackage' after 'normalisePackageInQN'); +-- values are absolute filesystem paths. +renderProgramWith :: ProgramData -> Map.Map Text FilePath -> BL.ByteString +renderProgramWith pd sourceRoots = + let graph = buildGraph pd sourceRoots jsonBs = Aeson.encode graph page = TE.decodeUtf8 viewerHtml pageBuilder = substitutePlaceholders @@ -64,14 +74,16 @@ renderProgram pd = -- | The element list shape expected by Cytoscape.js. data CyGraph = CyGraph - { cyElements :: ![CyElement] - , cyMeta :: !Aeson.Value -- raw program data (used by side panel) + { cyElements :: ![CyElement] + , cyMeta :: !Aeson.Value -- raw program data (used by side panel) + , cySourceRoots :: !(Map.Map Text FilePath) } instance Aeson.ToJSON CyGraph where toJSON g = Aeson.object - [ "elements" Aeson..= cyElements g - , "meta" Aeson..= cyMeta g + [ "elements" Aeson..= cyElements g + , "meta" Aeson..= cyMeta g + , "sourceRoots" Aeson..= cySourceRoots g ] data CyElement @@ -82,11 +94,12 @@ instance Aeson.ToJSON CyElement where toJSON (CyNode v) = Aeson.object ["group" Aeson..= ("nodes" :: Text), "data" Aeson..= v] toJSON (CyEdge v) = Aeson.object ["group" Aeson..= ("edges" :: Text), "data" Aeson..= v] -buildGraph :: ProgramData -> CyGraph -buildGraph pd = CyGraph - { cyElements = classNodes <> familyNodes <> externalNodes - <> superEdges <> assocEdges - , cyMeta = Aeson.toJSON pd +buildGraph :: ProgramData -> Map.Map Text FilePath -> CyGraph +buildGraph pd sourceRoots = CyGraph + { cyElements = classNodes <> familyNodes <> externalNodes + <> superEdges <> assocEdges + , cyMeta = Aeson.toJSON pd + , cySourceRoots = sourceRoots } where -- "Leaf" = no other class has this class as a (direct) superclass. diff --git a/src/Classgraph/Schema.hs b/src/Classgraph/Schema.hs index c3bcde5..89dd488 100644 --- a/src/Classgraph/Schema.hs +++ b/src/Classgraph/Schema.hs @@ -147,19 +147,27 @@ data InstanceInfo = InstanceInfo -- ^ Haddock attached to the @instance ...@ declaration, if the -- target was compiled with @-haddock@. Looked up via the dfun's -- 'Name'. + , iiDefinedIn :: !(Maybe Text) + -- ^ The package id of the module that /defined/ this instance, + -- after package-id normalisation (so @demo-0.1.0.0-inplace@ becomes + -- @demo@). Set by the merge step from the enclosing 'ModuleDump'; + -- distinct from 'qnPackage' on 'iiClass' for orphan instances. Used + -- by the viewer to look up the right source-root prefix when + -- building \"open in editor\" links. } deriving stock (Generic, Show, Eq) instance ToJSON InstanceInfo where toJSON i = object - [ "iiClass" .= iiClass i - , "iiArgs" .= iiArgs i - , "iiContext" .= iiContext i - , "iiTyVars" .= iiTyVars i - , "iiOrphan" .= iiOrphan i - , "iiOverlap" .= iiOverlap i - , "iiSrc" .= iiSrc i - , "iiDoc" .= iiDoc i + [ "iiClass" .= iiClass i + , "iiArgs" .= iiArgs i + , "iiContext" .= iiContext i + , "iiTyVars" .= iiTyVars i + , "iiOrphan" .= iiOrphan i + , "iiOverlap" .= iiOverlap i + , "iiSrc" .= iiSrc i + , "iiDoc" .= iiDoc i + , "iiDefinedIn" .= iiDefinedIn i ] instance FromJSON InstanceInfo where @@ -172,6 +180,7 @@ instance FromJSON InstanceInfo where <*> o .: "iiOverlap" <*> o .: "iiSrc" <*> o .:? "iiDoc" + <*> o .:? "iiDefinedIn" data PredInfo = PredInfo { piClass :: !QualName @@ -261,18 +270,22 @@ data FamInstInfo = FamInstInfo -- hides the RHS for data-family rows. , fiDoc :: !(Maybe Text) -- ^ Haddock for this family instance, when @-haddock@ is on. + , fiDefinedIn :: !(Maybe Text) + -- ^ Defining-package id (normalised), set at merge time. Used the + -- same way as 'iiDefinedIn' for editor-link source-root lookup. } deriving stock (Generic, Show, Eq) instance ToJSON FamInstInfo where toJSON fi = object - [ "fiFamily" .= fiFamily fi - , "fiTyVars" .= fiTyVars fi - , "fiArgs" .= fiArgs fi - , "fiRhs" .= fiRhs fi - , "fiSrc" .= fiSrc fi - , "fiIsData" .= fiIsData fi - , "fiDoc" .= fiDoc fi + [ "fiFamily" .= fiFamily fi + , "fiTyVars" .= fiTyVars fi + , "fiArgs" .= fiArgs fi + , "fiRhs" .= fiRhs fi + , "fiSrc" .= fiSrc fi + , "fiIsData" .= fiIsData fi + , "fiDoc" .= fiDoc fi + , "fiDefinedIn" .= fiDefinedIn fi ] instance FromJSON FamInstInfo where @@ -284,6 +297,7 @@ instance FromJSON FamInstInfo where <*> o .: "fiSrc" <*> o .:? "fiIsData" .!= False <*> o .:? "fiDoc" + <*> o .:? "fiDefinedIn" data SrcSpanInfo = SrcSpanInfo { ssFile :: !Text