|
22 | 22 | ;; [--module <name>] restrict to ONE module by name substring (the flip |
23 | 23 | ;; experiment ingests ONLY schema; this is how) |
24 | 24 | ;; [--append] append to an existing log (default: TRUNCATE+write) |
| 25 | +;; [--root <dir>] source root module names are derived from (default: |
| 26 | +;; the common ancestor dir of the ingested files) |
25 | 27 | ;; |
26 | 28 | ;; The default ingests every .bclj it finds (staged adoption uses this); the flip |
27 | 29 | ;; experiment passes `--module schema` so ONLY schema.bclj is folded. |
|
55 | 57 |
|
56 | 58 | ;; --- args -------------------------------------------------------------------- |
57 | 59 | (defn- parse-args [args] |
58 | | - (loop [a args, opts {:srcs [] :out nil :module nil :append false}] |
| 60 | + (loop [a args, opts {:srcs [] :out nil :module nil :append false :root nil}] |
59 | 61 | (cond |
60 | 62 | (empty? a) opts |
61 | 63 | (= "--out" (first a)) (recur (drop 2 a) (assoc opts :out (second a))) |
62 | 64 | (= "--module" (first a)) (recur (drop 2 a) (assoc opts :module (second a))) |
63 | 65 | (= "--append" (first a)) (recur (rest a) (assoc opts :append true)) |
| 66 | + (= "--root" (first a)) (recur (drop 2 a) (assoc opts :root (second a))) |
64 | 67 | :else (recur (rest a) (update opts :srcs conj (first a)))))) |
65 | 68 |
|
66 | 69 | ;; Any Beagle source extension — the extension only selects the EMIT TARGET |
|
79 | 82 | sort vec) |
80 | 83 | :else []))) |
81 | 84 |
|
82 | | -;; module name from a Beagle path: basename without the .b* extension. schema.bclj |
83 | | -;; -> "schema". This is the @<module># prefix the resolver groups by (name->module). |
84 | | -(defn- module-of [path] (-> path io/file .getName (str/replace beagle-ext-re ""))) |
| 85 | +;; module name from a Beagle path: the path RELATIVE to the ingest root (--root, |
| 86 | +;; default: common ancestor dir of all ingested files), DOT-joined, .b* stripped. |
| 87 | +;; This is the @<module># prefix the resolver groups by (name->module) — its regex |
| 88 | +;; (@([^#]+)#) admits any separator, but downstream builds flat filenames from the |
| 89 | +;; key (fram_mcp's edited-<mod>.bclj / <src>/<mod>.bclj views), so dots, not slashes. |
| 90 | +;; One dir of files keeps bare basenames (src/fram/schema.bclj -> "schema", as |
| 91 | +;; before); a TREE qualifies (tabs/index.bjs -> "tabs.index"), so duplicate |
| 92 | +;; basenames across dirs never collide into one module. |
| 93 | +(defn- path-segs [p] (vec (remove str/blank? (str/split p #"/")))) |
| 94 | +(defn- common-prefix [a b] |
| 95 | + (loop [i 0] |
| 96 | + (if (and (< i (count a)) (< i (count b)) (= (nth a i) (nth b i))) |
| 97 | + (recur (inc i)) |
| 98 | + (subvec a 0 i)))) |
| 99 | +(defn- infer-root-segs [paths] |
| 100 | + (reduce common-prefix (map #(vec (butlast (path-segs %))) paths))) |
| 101 | +(defn- module-of [root-segs path] |
| 102 | + (let [segs (path-segs path) |
| 103 | + n (count root-segs) |
| 104 | + rel (if (and (<= n (count segs)) (= root-segs (subvec segs 0 n))) |
| 105 | + (subvec segs n) |
| 106 | + segs) ; not under root: full path qualifies |
| 107 | + rel (if (seq rel) rel [(peek segs)])] |
| 108 | + (str/replace (str/join "." rel) beagle-ext-re ""))) |
85 | 109 |
|
86 | 110 | ;; --- emit-edn one module, parse to [s p o] triples --------------------------- |
87 | 111 | ;; emit-edn prints `@file <path>` then one `[s "pred" o]` per line. o is an INTEGER |
|
104 | 128 | ;; object -> :r the string (a LITERAL). Predicate passes through verbatim. |
105 | 129 | ;; PLUS one bookkeeping claim @<mod>#root file "<path>" so render-from-log knows the |
106 | 130 | ;; source path (the @file wrapper analogue; "root" never collides with an int id). |
107 | | -(defn- module->claims [path] |
108 | | - (let [module (module-of path) |
| 131 | +(defn- module->claims [root-segs path] |
| 132 | + (let [module (module-of root-segs path) |
109 | 133 | triples (emit-edn-triples path) |
110 | 134 | node-claims |
111 | 135 | (mapv (fn [[s p o]] |
|
118 | 142 | node-claims))) |
119 | 143 |
|
120 | 144 | ;; --- main -------------------------------------------------------------------- |
121 | | -(let [{:keys [srcs out module append]} (parse-args *command-line-args*) |
| 145 | +(let [{:keys [srcs out module append root]} (parse-args *command-line-args*) |
122 | 146 | out-path (or out (str (System/getProperty "user.dir") "/.fram/code.log"))] |
123 | | - (when (empty? srcs) (die "usage: bin/fram-ingest-code <src> [<src>...] [--out <log>] [--module <name>] [--append]")) |
| 147 | + (when (empty? srcs) (die "usage: bin/fram-ingest-code <src> [<src>...] [--out <log>] [--module <name>] [--append] [--root <dir>]")) |
124 | 148 | (when-not (.exists (io/file roundtrip-rkt)) |
125 | 149 | (die "missing claims-roundtrip.rkt at" roundtrip-rkt "(set FRAM_ROUNDTRIP / BEAGLE_HOME)")) |
126 | 150 | (let [files (->> srcs (mapcat beagle-files) distinct sort |
127 | 151 | (filter (fn [p] (or (nil? module) (str/includes? p module)))))] |
128 | 152 | (when (empty? files) (die "no Beagle modules matched" (pr-str srcs) (when module (str "(module filter: " module ")")))) |
129 | 153 | (log! "fram-ingest-code: folding" (count files) "module(s) ->" out-path |
130 | 154 | (when module (str "(module filter: " module ")"))) |
131 | | - (let [all-claims (mapcat module->claims files) |
| 155 | + (let [root-segs (if root (path-segs root) (infer-root-segs files)) |
| 156 | + all-claims (mapcat (partial module->claims root-segs) files) |
132 | 157 | ;; monotone :tx across the whole log; existing daemon seeds :next-seq to max. |
133 | 158 | base (if (and append (.exists (io/file out-path))) |
134 | 159 | (->> (str/split-lines (slurp out-path)) |
|
149 | 174 | (spit out-path body)) |
150 | 175 | (log! "fram-ingest-code: wrote" (count all-claims) "AST claims" |
151 | 176 | (str "(" (count files) " module(s); ids re-keyed @<mod>#<n>)")) |
152 | | - (doseq [f files] (log! " +" (module-of f) "<-" f)) |
| 177 | + (doseq [f files] (log! " +" (module-of root-segs f) "<-" f)) |
153 | 178 | (log! "DONE — the Beagle source is now downstream of" out-path)))) |
0 commit comments