diff --git a/test/dune b/test/dune index d8bff55..70257aa 100644 --- a/test/dune +++ b/test/dune @@ -65,6 +65,9 @@ ; fourth file beside those three is a type error in an unrelated program. ; embed-dir does not descend and neither does a glob, so this is its own line. (glob_files programs/assets/edn/*) + ; And the config programs/json-provide.flan derives a struct from, under + ; assets/ for the same reason and needing its own line for the same one. + (glob_files programs/assets/json/*) ; The reload primitive's host: a C main that dlopens what Build.shared made. (file reload_host.c) ; A shared object that is not a redefinition module, for the agent's refusal @@ -97,6 +100,7 @@ (glob_files programs/*.flan) (glob_files programs/assets/*) (glob_files programs/assets/edn/*) + (glob_files programs/assets/json/*) ; The raylib bindings and the ported example the raylib case builds. The ; example imports examples/digits.flan, so the directory comes whole. (glob_files %{workspace_root}/vendor/raylib/*) @@ -138,7 +142,8 @@ (glob_files %{workspace_root}/examples/*) (glob_files programs/*.flan) (glob_files programs/assets/*) - (glob_files programs/assets/edn/*)) + (glob_files programs/assets/edn/*) + (glob_files programs/assets/json/*)) (action (run ./test_sanitize.exe))) ; The corpus a third time, under Valgrind's memcheck. Its own alias for the @@ -175,6 +180,7 @@ (glob_files programs/*.flan) (glob_files programs/assets/*) (glob_files programs/assets/edn/*) + (glob_files programs/assets/json/*) ; The package tree the multi-level cases import, as in the test stanza ; above: a glob per directory, because dune's glob does not descend. (glob_files programs/pkgs/shape/*) @@ -233,6 +239,7 @@ (glob_files programs/*.flan) (glob_files programs/assets/*) (glob_files programs/assets/edn/*) + (glob_files programs/assets/json/*) ; A glob per package directory, because dune's glob does not descend. (glob_files programs/pkgs/shape/*) (glob_files programs/pkgs/area/*) @@ -396,6 +403,7 @@ (glob_files programs/*.flan) (glob_files programs/assets/*) (glob_files programs/assets/edn/*) + (glob_files programs/assets/json/*) (glob_files programs/pkgs/shape/*) (glob_files programs/pkgs/area/*) (glob_files programs/pkgs/draw/*) diff --git a/test/programs/assets/json/config.json b/test/programs/assets/json/config.json new file mode 100644 index 0000000..62a9230 --- /dev/null +++ b/test/programs/assets/json/config.json @@ -0,0 +1,12 @@ +{ + "name": "tileset\nrunner", + "port": 8080, + "scale": 1.5, + "debug": true, + "layers": [3, 1, 4, 1, 5], + "window": { + "w": 1280, + "h": 720, + "origin": { "x": -2, "y": 0 } + } +} diff --git a/test/programs/json-provide.flan b/test/programs/json-provide.flan new file mode 100644 index 0000000..ecb9441 --- /dev/null +++ b/test/programs/json-provide.flan @@ -0,0 +1,53 @@ +;;;; defjson over a config file, and the escape that says it is not defedn. +;;;; +;;;; The same idea as edn-provide.flan and a different package: json depends on +;;;; edn for nothing and this program imports only json. +;;;; +;;;; "name" is the line that matters. Its value in the file is written +;;;; "tileset\nrunner", and JSON's `.text` is the RAW interior — escapes +;;;; undecoded — so a reader built on `.text` prints one line with a backslash +;;;; and an n in it. This prints two lines, which is `string-of` having been +;;;; used where a field is filled. + +(import json "vendor:json") + +(json/defjson Config "assets/json/config.json") + +(defconst config (embed "assets/json/config.json")) + +(defn main [] i32 + (let [a (heap-allocator) + cfg (Config-of-bytes config a)] + ;; Two lines, not one with a backslash in it. + (println (.name cfg)) + (println (.port cfg)) + (println (.scale cfg)) + (println (if (.debug cfg) "yes" "no")) + (println (len (.layers cfg))) + ;; 3 + 1 + 4 + 1 + 5. A length alone would pass on a Vec that was allocated + ;; and never filled, so the sum is the claim. + (let [total (i64 0)] + (dotimes [i (len (.layers cfg))] + (set total (+ total (at (.layers cfg) i)))) + (println total)) + ;; The nested structs, by the names the paths give them: Config-window and + ;; Config-window-origin. Ordinary field loads, two deep. + (println (.w (.window cfg))) + (println (.h (.window cfg))) + (println (.x (.origin (.window cfg)))) + (println (.y (.origin (.window cfg)))) + (println "") + ;; Drift, the same contract defedn's reader carries: the struct says "port" + ;; and these bytes do not, and they carry a "host" it has never heard of. + (handler-bind + [(json/SchemaDrift [d] + (do (print (if (.extra? d) "extra " "missing ")) + (print (.field d)) + (print " in ") + (println (.struct d))))] + (let [c2 (Config-of-bytes + (bytes "{\"name\":\"x\",\"host\":\"h\",\"scale\":2.0,\"debug\":false,\"layers\":[1],\"window\":{\"w\":1,\"h\":1,\"origin\":{\"x\":0,\"y\":0}}}") + a)] + (println (.name c2)) + (println (.port c2))))) + 0) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index 1a8dfb8..0d8ac70 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -677,6 +677,31 @@ let () = outputs ~opt:"-O0" "defedn over the tileset and a tuning file, -O0" "programs/edn-provide.flan" edn_provide_out; + (* The same idea in the other package, over a config file. json depends on + edn for nothing and this program imports only json: what the two share + is the design, not a line of code. + + The first two lines are the claim that separates them. "name" is written + "tileset\nrunner" in the file, and json.flan's .text is the RAW interior + with escapes undecoded — so a reader built on it prints one line with a + backslash and an n in it. Two lines is string-of having been used where + a field is filled, which is the one call in that package that allocates + and the one that is correct. + + Then the shape matrix — a number that is an integer because the file + wrote it as one, a number that is a float because the file wrote a + point, a boolean, an array summed rather than counted, and an object + inside an object read two field loads deep — and drift, where the bytes + have a "host" the struct never heard of and no "port" it expects. *) + let json_provide_out = + "tileset\nrunner\n8080\n1.5\nyes\n5\n14\n1280\n720\n-2\n0\n\n\ + extra host in Config\nmissing port in Config\nx\n0\n" + in + outputs "defjson over a config file" "programs/json-provide.flan" + json_provide_out; + outputs ~opt:"-O0" "defjson over a config file, -O0" + "programs/json-provide.flan" json_provide_out; + (* What a provider refuses, and where it says the trouble is. A data file the compiler could not make sense of is one the program would have read wrongly, so each of these is a compile that stops rather @@ -694,15 +719,15 @@ let () = a test that checked the refusal alone, and a line and column into a file the compiler is not reading is the whole of what the refusal had to be given a facility for. *) - let provider_refusal name edn needle = + let refusal ~pkg ~mac ~ext name data needle = let base = "programs/refuse-" ^ name in - let ednp = base ^ ".edn" and flanp = base ^ ".flan" in - Out_channel.with_open_bin ednp (fun ch -> Out_channel.output_string ch edn); + let datap = base ^ "." ^ ext and flanp = base ^ ".flan" in + Out_channel.with_open_bin datap (fun ch -> Out_channel.output_string ch data); Out_channel.with_open_bin flanp (fun ch -> Out_channel.output_string ch (Printf.sprintf - "(import edn \"vendor:edn\")\n(edn/defedn T \"refuse-%s.edn\")\n\ - (defn main [] i32 0)\n" name)); + "(import p \"vendor:%s\")\n(p/%s T \"refuse-%s.%s\")\n\ + (defn main [] i32 0)\n" pkg mac name ext)); (match let l = Load.program ~file:flanp (Reader.read_file flanp) in Check.program l.Load.decls @@ -716,8 +741,10 @@ let () = Printf.printf "FAIL %s\n said: %S\n wanted: %S in it\n" name m needle end); - List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ ednp; flanp ] + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ datap; flanp ] in + let provider_refusal = refusal ~pkg:"edn" ~mac:"defedn" ~ext:"edn" in + let json_refusal = refusal ~pkg:"json" ~mac:"defjson" ~ext:"json" in (* The element positions are named, both of them, because "heterogeneous" on its own sends someone to read the whole file. *) provider_refusal "mixed-vector" "{:xs [1 2 \"three\"]}" "element 2 is string"; @@ -762,6 +789,27 @@ let () = end); (try Sys.remove flanp with Sys_error _ -> ())); + (* And what defjson refuses, which is the same walk over a different + grammar. The first three are the ones it shares; the last two are its + own, and both are about a member name. + + A struct's fields are names, and JSON's are arbitrary strings — so + "a b" has no field it could become, and an escaped one is refused + because the generated reader compares against the bytes as written. The + comparison costs no allocation per key, which is the whole reason it is + written that way, and it is only the same question as "is this the + field" when the name has no escape in it. Refusing is what keeps those + two facts from quietly disagreeing. *) + json_refusal "json-mixed-array" "{\"xs\": [1, 2, \"three\"]}" + "element 2 is string"; + json_refusal "json-null" "{\"a\": null}" "has no type to derive"; + json_refusal "json-empty-array" "{\"xs\": []}" + "has no element to derive an element type from"; + json_refusal "json-spaced-key" "{\"a b\": 1}" + "is not a name a program could write"; + json_refusal "json-escaped-key" "{\"a\\nb\": 1}" + "has an escape in it"; + (* And the branch that makes it safe, which needs a program that dies to say anything — the shape bounds.flan uses, and for the same reason. Run 0 is the control and must not trap: a (Vec (Vec i32)) in the region diff --git a/vendor/json/provide.flan b/vendor/json/provide.flan new file mode 100644 index 0000000..842dd5c --- /dev/null +++ b/vendor/json/provide.flan @@ -0,0 +1,445 @@ +;;;; defjson: a struct derived from a JSON file, at compile time. +;;;; +;;;; `(json/defjson Config "config.json")` reads config.json while the program +;;;; is being compiled, derives the struct its shape implies, and emits that +;;;; struct with a reader over the tokenizer next door. `(.port cfg)` is then a +;;;; field load: no Value, no match, no runtime tag, nothing looked up by name. +;;;; +;;;; It is the same idea as vendor/edn's defedn and deliberately not the same +;;;; code. Neither package imports the other: json depends on edn for nothing, +;;;; and borrowing a shape walk across that line would be a dependency for the +;;;; sake of a resemblance. What carries over is the design — one walk that +;;;; answers a type, the declarations that type needs and the expression that +;;;; reads one; a refusal carried in a field rather than raised; a typed +;;;; one-line constructor per collection; and a `compile-error` wrapped in a +;;;; defn nothing calls. +;;;; +;;;; ── What is different, and why ─────────────────────────────────────── +;;;; +;;;; **Strings go through `string-of` and never through `.text`.** json.flan's +;;;; `.text` is the RAW interior of a string token, escapes undecoded, so a +;;;; field read off it would hold a literal backslash-n where the file meant a +;;;; newline. `string-of` is the one call in that package that allocates, and +;;;; it is the one that is correct. +;;;; +;;;; **Commas and colons are tokens.** In EDN a comma is whitespace; here a +;;;; member is a string, a colon, a value, and a comma if another follows. +;;;; +;;;; **An object's keys are strings, not keywords**, so the refusal a map of +;;;; the wrong shape gets is about a string, and a key has to look like a name +;;;; a program could write — `{"a b": 1}` is a legal object and `a b` is not a +;;;; field. +;;;; +;;;; **There are no sets**, so there is no map-key path and no fixed array: +;;;; every collection here is a `(Vec T)`. defjson is strictly the smaller of +;;;; the two. +;;;; +;;;; JSON has no integer type of its own — the tokenizer draws the line at +;;;; whether a number has a fraction or an exponent, which is the only line +;;;; there is — so a number written 1 is an i64 here and one written 1.0 is an +;;;; f64. That is the file's own distinction and the honest one to derive from; +;;;; a tuning value that will sometimes be fractional should be written 1.0. + +;; ── Small string work ─────────────────────────────────────────────── + +(defn joined [a string b string] string + (let [v (vec-new u8)] + (append (addr v) (bytes a)) + (append (addr v) (bytes b)) + (string (as-slice v)))) + +(defn joined3 [a string b string c string] string + (joined a (joined b c))) + +;; Copied out, and not `(string (i64->bytes n))`: the prelude's note over +;; append-i64 is the reason — i64->bytes renders into one shared static buffer +;; in the runtime, so two of its results cannot be held at once, and `where` +;; holds a line and a column at the same time. +(defn i64->string [n i64] string + (let [v (vec-new u8)] + (append-i64 (addr v) n) + (string (as-slice v)))) + +;; The tokenizer answers byte offsets. A person reading a refusal wants a line +;; and a column, so the newlines before the offset are counted here — once per +;; refusal, which is as often as this is ever called. +(defn where [src [u8] pos i32] string + (let [line (i64 1) + col (i64 1) + i (i32 0)] + (while (< i pos) + (if (= (at src i) \newline) + (do (set line (+ line 1)) (set col 1)) + (set col (+ col 1))) + (set i (+ i 1))) + (joined3 "line " (i64->string line) (joined " column " (i64->string col))))) + +;; ── What a value came to ──────────────────────────────────────────── +;; +;; One walk answers three things: the type the value implies, the struct +;; declarations that type needs, and the expression that reads one — written +;; against a cursor named `c` and an allocator named `a`, which is what every +;; generated reader binds. `bad` is the refusal, carried rather than raised, +;; because there is no exception to throw out of a recursive walk. +(defstruct Derived + [ty Form + decls [Form] + reader Form + bad string]) + +(defn derived-bad [msg string] Derived + (Derived {.ty `i64 .decls (form-nil) .reader `0 .bad msg})) + +(defn ok-derived [ty Form decls [Form] reader Form] Derived + (Derived {.ty ty .decls decls .reader reader .bad ""})) + +(defn bad? [d Derived] bool + (> (len (bytes (.bad d))) 0)) + +(defn with-decl [decls [Form] d Form] [Form] + (form-append decls (form-cons d (form-nil)))) + +;; ── The scalars a generated reader calls ──────────────────────────── +;; +;; Functions and not inlined expansions, so that `C-c C-m` over a defjson shows +;; a reader somebody can read. Each is `expect` plus the conversion, and a +;; failure leaves the value at zero with the cursor not ok? — so a whole struct +;; is a straight line of assignments with one test at the end. + +(defn need-int [c (Ptr Cursor)] i64 + (match (int-of (expect c tok-int)) (Some v) v None 0)) + +;; Both number kinds are acceptable, because 2 and 2.0 are the same number and +;; a file written by hand has both. `float-of` answers Some for either. +(defn need-float [c (Ptr Cursor)] f64 + (let [t (next c)] + (match (float-of t) + (Some x) x + None (do (fail c err-unexpected-token (.pos t)) 0.0)))) + +(defn need-bool [c (Ptr Cursor)] bool + (match (bool-of (expect c tok-bool)) (Some v) v None false)) + +;; `string-of` and not `.text`. The header says why: `.text` is the raw +;; interior and an escape in it has not been decoded, so a field read off it +;; would hold a backslash and an n where the file meant a newline. +(defn need-string [c (Ptr Cursor)] string + (match (string-of (expect c tok-string)) (Some s) s None "")) + +;; Whether the next thing, past whitespace, is this byte. Enough of a peek for +;; every loop below — "is this over" and "is there another member" are the only +;; lookaheads a reader of a known shape needs — and it consumes nothing. +(defn at-byte? [c (Ptr Cursor) b u8] bool + (skip-trivia c) + (and (not (at-end? c)) (= (at (.src c) (.pos c)) b))) + +;; The comma between two members, taken when there is one. A trailing comma is +;; json.flan's err-trailing-comma and is the tokenizer's to refuse, not this +;; loop's: taking it here and then meeting the closer is exactly the shape that +;; refusal is written against. +(defn comma [c (Ptr Cursor)] () + (when (at-byte? c \,) + (next c))) + +;; ── The condition a reader signals when the file moved ────────────── +;; +;; The case the whole feature exists to catch, and the same one defedn carries: +;; the struct was derived from the file as it was when the program was +;; compiled, and a key that has gone or arrived since is a program reading +;; something other than what it was built for. Silence is the alternative and +;; it is the bad one — a missing key leaves a field at zero, which is a port of +;; 0 and a path of "", and the program fails for a reason nothing reports. +;; +;; Its own type and not edn's, because these two packages do not depend on each +;; other. A program reading both files binds two clauses, which is the honest +;; shape: the two conditions carry different provenance. +(defstruct SchemaDrift + [field string + struct string + extra? bool + pos i32]) + +;; ── Deriving ──────────────────────────────────────────────────────── + +(defn derive [c (Ptr Cursor) name string src [u8]] Derived + (let [t (next c)] + (when (not (ok? c)) + (return (derived-bad + (joined3 "the data file could not be read at " (where src (error-pos c)) + (joined ": " (error-message (.err c))))))) + (cond + (= (.kind t) tok-int) (ok-derived `i64 (form-nil) `(need-int c)) + (= (.kind t) tok-float) (ok-derived `f64 (form-nil) `(need-float c)) + (= (.kind t) tok-bool) (ok-derived `bool (form-nil) `(need-bool c)) + (= (.kind t) tok-string) (ok-derived `string (form-nil) `(need-string c)) + + (= (.kind t) tok-object-open) (derive-object c name (.pos t) src) + (= (.kind t) tok-array-open) (derive-array c name (.pos t) src) + + (= (.kind t) tok-null) + (derived-bad + (joined3 "the null at " (where src (.pos t)) + " has no type to derive — a field that is sometimes absent is not something a struct can hold, so give it a value in the file or take the key out")) + + :else + (derived-bad + (joined3 "the value at " (where src (.pos t)) + " is not one defjson derives a type from — an object, an array, a number, a boolean or a string"))))) + +;; An array, whose elements must all come to the same type. The first decides; +;; every one after it is compared against that, and both positions are named +;; when they disagree — "heterogeneous" on its own sends someone to read the +;; whole file. +(defn derive-array [c (Ptr Cursor) name string at-pos i32 src [u8]] Derived + (when (at-byte? c \]) + (return (derived-bad + (joined3 "the empty array at " (where src at-pos) + " has no element to derive an element type from — defjson reads the shape out of the data, and an empty collection carries none")))) + (let [head (derive c (joined name "-item") src)] + (when (bad? head) + (return head)) + (comma c) + (let [n (i64 1)] + (while (and (ok? c) (not (at-byte? c \]))) + (let [item (derive c (joined name "-item") src)] + (when (bad? item) + (return item)) + (when (not (same-type? (.ty head) (.ty item))) + (return (derived-bad + (joined3 (joined3 "the array at " (where src at-pos) + " holds more than one shape: element 0 is ") + (render (.ty head)) + (joined3 (joined3 " and element " (i64->string n) " is ") + (render (.ty item)) + ". Every element of an array has to be the same shape, because the (Vec T) it becomes has one element type"))))) + (comma c) + (set n (+ n 1)))) + (expect c tok-array-close) + (let [elem (.ty head) + read1 (.reader head) + ty `(Vec ~elem) + cn (Form.Sym {.s (joined name "-new")})] + ;; The constructor states the type so the bare (vec-new a) in its body + ;; can take it from `want`. (vec-new) has to be *told* what it builds by + ;; naming a type, and `(Vec i64)` has no name to be — but a signature is + ;; a type position where anything can be written. The reader reads + ;; better for it too. + (ok-derived ty (with-decl (.decls head) `(defn ~cn [a Allocator] ~ty + (vec-new a))) + `(let [xs (~cn a)] + (expect c tok-array-open) + (while (and (ok? c) (not (at-byte? c \]))) + (push xs ~read1) + (comma c)) + (expect c tok-array-close) + xs)))))) + +;; ── An object, which is a struct ──────────────────────────────────── + +(defn derive-object [c (Ptr Cursor) name string at-pos i32 src [u8]] Derived + (when (at-byte? c \}) + (return (derived-bad + (joined3 "the empty object at " (where src at-pos) + " has no members to derive fields from — a struct with no fields is not a shape anything can be read into")))) + (let [fields (vec-new Form) ; the defstruct's [name type ...] vector + clauses (vec-new Form) ; the reader's cond: test, body, test, body + missing (vec-new Form) ; one per field, checked when the object closes + decls (vec-new Form) ; nested structs, innermost first + idx (i64 0)] + (while (and (ok? c) (not (at-byte? c \}))) + (let [k (next c)] + (when (not (ok? c)) + (return (derived-bad + (joined3 "the data file could not be read at " (where src (error-pos c)) + (joined ": " (error-message (.err c))))))) + (when (!= (.kind k) tok-string) + (return (derived-bad + (joined3 "the object at " (joined3 (where src at-pos) " has a member at " (where src (.pos k))) + " whose name is not a string, which JSON requires")))) + ;; The comparison in the generated reader is against the token's RAW + ;; text, which costs no allocation per key. That is only the same + ;; question as "is this the field" when the name has no escape in it — + ;; so a name that has one is refused here rather than silently compared + ;; wrongly. Nothing writes "port" for "port"; what this catches is + ;; the file where it would have mattered. + (let [raw (.text k)] + (when (has-escape? raw) + (return (derived-bad + (joined3 "the member name at " (where src (.pos k)) + " has an escape in it. A generated reader compares a key against the bytes as written, which costs nothing per key and is only the same question when the name is written plainly — so this one is refused rather than matched wrongly")))) + (when (not (name-like? raw)) + (return (derived-bad + (joined3 "the member name at " (where src (.pos k)) + " is not a name a program could write, so there is no field it can become. A struct's fields are named; letters, digits, - and ? are what a name is made of")))) + (expect c tok-colon) + (let [fname (copy-of raw) + d (derive c (joined3 name "-" fname) src)] + (when (bad? d) + (return d)) + (dotimes [i (len (.decls d))] + (push decls (at (.decls d) i))) + (push fields (Form.Sym {.s fname})) + (push fields (.ty d)) + (let [dot (Form.Sym {.s (joined "." fname)}) + lit (Form.Str {.s fname}) + bit (Form.Int {.i (<< (i64 1) idx)}) + read1 (.reader d)] + (push clauses `(key=? k ~lit)) + (push clauses `(do (set (~dot out) ~read1) + (set seen (bit-or seen ~bit)))) + ;; Checked where the object closes. The bit is decided here, + ;; beside the field, so the two cannot fall out of step the way a + ;; parallel list of names would. + (push missing + `(when (= (bit-and seen ~bit) 0) + (signal (SchemaDrift {.field ~lit + .struct ~(Form.Str {.s name}) + .extra? false + .pos (.pos close)}))))) + (comma c) + (set idx (+ idx 1)))))) + (expect c tok-object-close) + ;; A member the struct has no field for: the struct *is* the file, so an + ;; unknown name is the file having moved. Reported and then skipped, so a + ;; program that declines to handle the condition still reads the rest. + (push clauses `:else) + (push clauses + `(do (signal (SchemaDrift {.field (match (string-of k) (Some s) s None "") + .struct ~(Form.Str {.s name}) + .extra? true + .pos (.pos k)})) + (when (not (skip-value c)) + (return out)))) + (let [sname (Form.Sym {.s name}) + rname (Form.Sym {.s (joined "read-" name)}) + struct `(defstruct ~sname ~(Form.Vec {.xs (as-slice fields)})) + reader + `(defn ~rname [c (Ptr Cursor) a Allocator] ~sname + (let [out (~sname {}) + seen 0] + (expect c tok-object-open) + (while (and (ok? c) (not (at-byte? c \}))) + (let [k (expect c tok-string)] + (expect c tok-colon) + (cond ~@(as-slice clauses)) + (comma c))) + (let [close (expect c tok-object-close)] + ~@(as-slice missing)) + out))] + (push decls struct) + (push decls reader) + (ok-derived sname (as-slice decls) `(~rname c a))))) + +;; ── The small predicates the refusals are written against ─────────── + +;; The generated reader's key test. Against the raw interior, which is the +;; whole of why a name with an escape in it is refused above. +(defn key=? [t Token s string] bool + (bytes=? (.text t) (bytes s))) + +(defn has-escape? [s [u8]] bool + (dotimes [i (len s)] + (when (= (at s i) \\) + (return true))) + false) + +;; What a field name may be made of. Deliberately narrower than what the reader +;; would accept: this is the set a *person* would recognise as a name, and a +;; member called "a b" or "x.y" has no field it could become. +(defn name-like? [s [u8]] bool + (when (= (len s) 0) + (return false)) + (dotimes [i (len s)] + (let [b (at s i)] + (when (not (or (alpha? b) + (or (digit? b) + (or (= b \-) (or (= b \?) (or (= b \_) (= b \!))))))) + (return false)))) + true) + +;; A copy of a token's raw text as a string. The Vec header is dropped here on +;; purpose: this runs inside the compiler, where an expansion is bounded by the +;; size of the program being compiled. +(defn copy-of [s [u8]] string + (let [b (vec-new u8)] + (append (addr b) s) + (string (as-slice b)))) + +;; ── Comparing and rendering a type form ───────────────────────────── + +(defn same-type? [a Form b Form] bool + (bytes=? (bytes (render a)) (bytes (render b)))) + +;; A type form as text, for the refusals. Only the shapes this file builds — a +;; name and `(Vec T)` — because nothing else ever reaches it. +(defn render [f Form] string + (match f + (Form.Sym s) s + (Form.Int i) (i64->string i) + (Form.List xs) (joined3 "(" (render-items xs) ")") + (Form.Vec xs) (joined3 "[" (render-items xs) "]") + _ "?")) + +(defn render-items [xs [Form]] string + (let [out ""] + (dotimes [i (len xs)] + (set out (if (= i 0) + (render (at xs i)) + (joined3 out " " (render (at xs i)))))) + out)) + +;; ── The macro ─────────────────────────────────────────────────────── +;; +;; `(json/defjson Config "config.json")`. The path is relative to the file this +;; is written in, exactly as `(embed "config.json")` is — see `macro-slurp` in +;; the prelude, and check.ml's `embed_path`, which is the rule it copies. +;; +;; It answers a `do`, which the top level splices: the nested structs innermost +;; first, then the struct named here, a reader per struct, and the two entry +;; points over the whole thing. +(defmacro defjson [args] + (if (!= (len args) 2) + (refuse "defjson is (defjson Name \"path.json\") — a name for the struct, and a path to the file its shape is read out of") + (match (at args 1) + (Form.Str path) + (match (at args 0) + (Form.Sym name) + (match (macro-slurp path) + (Some src) (provide name path src) + None (refuse + (joined3 "there is no file at " path + ", read relative to the file this defjson is written in — the same place (embed \"...\") would look"))) + _ (refuse "defjson's first argument is the name of the struct to declare, written as a name")) + _ (refuse "defjson's second argument is the path to the data file, written as a string literal — the file is read while this is being compiled, so there is nothing here to compute a path from")))) + +(defn provide [name string path string src [u8]] Form + (let [cur (cursor src) + d (derive (addr cur) name src)] + (if (bad? d) + (refuse (.bad d)) + (if (not (= (.kind (next (addr cur))) tok-eof)) + (refuse (joined path " holds more than one value, and a defjson derives one struct from one")) + (let [sname (Form.Sym {.s name}) + rname (Form.Sym {.s (joined "read-" name)}) + bname (Form.Sym {.s (joined name "-of-bytes")}) + fname (Form.Sym {.s (joined name "-read-file")})] + `(do + ~@(.decls d) + ;; Both entry points take the allocator the struct's own fields are + ;; built in: a string field is a copy and a Vec field is an + ;; allocation, and spec-memory's rule is that the destination is + ;; never implicit. + (defn ~bname [b [u8] a Allocator] ~sname + (let [c (cursor b)] + (~rname (addr c) a))) + (defn ~fname [p string a Allocator] ~sname + (let [b (slurp p a)] + (~bname (as-slice b) a))))))))) + +;; A refusal, as a declaration. `compile-error` is an expression and a top-level +;; position takes a declaration, so it goes in the body of a function nothing +;; calls: the checker walks it, the arm fires, and `Loc.from_macro` has already +;; put the report on the `defjson` the author wrote. The name is a gensym, so +;; two refusals in one file are two reports rather than a name defined twice. +(defn refuse [msg string] Form + `(defn ~(gensym) [] () (compile-error ~(Form.Str {.s msg}))))