JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

defjson, which shares the design and not a line of the code

Browse Source 
vendor:json depends on vendor: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 shape of the answer — one walk giving 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 genuinely different is four things. Strings go through string-of and
never through .text: .text is the raw interior with escapes undecoded, so a
field read off it would hold a backslash and an n where the file meant a
newline — which is the first two lines of the acceptance output and the reason
they are two. Commas and colons are tokens rather than whitespace. An object's
keys are strings, so a key has to be refused when it is not a name a program
could write, and refused again when it carries an escape: the generated reader
compares against the bytes as written, which costs no allocation per key and is
only the same question when the name is written plainly. And there are no sets,
so there is no map-key path and no fixed array — every collection is a (Vec T)
and defjson is the smaller of the two by half.

JSON has no integer type; the tokenizer draws the line at whether a number has
a fraction or an exponent, which is the only line there is, so 1 derives i64
and 1.0 derives f64. That is the file's own distinction and the honest one to
take.

@x86 matches on it and @sanitize is clean.
This commit is contained in:
Joseph Ferano 2026-09-19 06:41:57 +07:00
parent 76f23fc68b
commit dc34c62ce0
5 changed files with 573 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
test/dune
View File

@ -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/*)

12
test/programs/assets/json/config.json Normal file
View File

@ -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 }
}
}

53
test/programs/json-provide.flan Normal file
View File

@ -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)

60
test/test_acceptance.ml
View File

@ -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

445
vendor/json/provide.flan vendored Normal file
View File

@ -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}))))