diff --git a/NEXT.md b/NEXT.md index 5e88e35..379f3c8 100644 --- a/NEXT.md +++ b/NEXT.md @@ -1073,8 +1073,15 @@ rather than cumulative, which is a deliberate divergence from `watch.clj` argued five numbers, and the window is the editor's". **Item 6 landed the same day**: `test/programs/frame-rollback.flan` is the worked example — `snapshot` at the top of the frame, `restore` in the `continue` clause — and `bounds-condition.flan`'s half-written abandoned frame is the thought it finishes. That was -the last Tier 1 item anyone was going to move. Items 7 (`drop`), 8 (generics) and 9 (`(read-edn T bytes)`) are still -on that list and still deferred with reasons written beside each; none is a blocker for this game. +the last Tier 1 item anyone was going to move. **Item 9 (`(read-edn T bytes)`) landed 2026-09-19**, and not as +`read-edn`: `(edn/defedn Tileset "assets/tileset.edn")` derives the struct from the *file* at compile time and +emits a reader with it, so the ~80 lines `docs/PORTING.md` prices for two schemas are not written by hand and not +written by the compiler either. It is a macro in `vendor:edn`, and `defjson` is the same over `vendor:json`. The +competing answer PORTING names — compile-time embedding — is not a competitor after all but the other half: the +shape comes from the file at compile time and the bytes may come from an `embed` beside it. See +[`docs/BUILT.md`](docs/BUILT.md), "A type provider: the struct a data file implies". Items 7 (`drop`) and 8 +(generics) are still on that list and still deferred with reasons written beside each; neither is a blocker for +this game. **What `docs/PORTING.md` says NOT to build, with evidence:** escaping closures (one capture site, fixed by one parameter), `Handle`/pools, `Result`/`try`, `handler-case`, `loop`/`recur` and tail calls, user allocators, structural typing — diff --git a/docs/BUILT.md b/docs/BUILT.md index ceb9d46..4b15117 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -5804,3 +5804,178 @@ the same comparison the prelude uses. An infinity still prints signed: there the the value, and the backends were always agreed about it. Pinned in `test/programs/format.flan`, which is in the x86 survey corpus, so one program holds both the printed form under `dune test` and the agreement under the survey. + +## A type provider: the struct a data file implies, derived while the program is compiled + +`(edn/defedn Tileset "assets/tileset.edn")` reads the file at expansion time, works out +what shape it is, and answers the struct that shape implies together with a reader over +the tokenizer next door. `(.texture-path data)` is then a field load off a struct nobody +declared: no `Value`, no `match`, no runtime tag, nothing looked up by name. F#'s type +providers with the useful half and none of the plugin protocol, and `vendor/json`'s +`defjson` is the same thing over a different grammar. + +Both are macros in their packages, not compiler builtins. That was the requirement and it +held, but only after four things the macro system did not have. Each is general and none +of them mentions EDN. + +### A macro may read a file, at the path the call site is written at + +`(embed "assets/x.edn")` resolves against the directory of the *source file the form is +written in* — check.ml's `embed_path`, and Odin's rule before it — because anything else +makes a package's assets depend on where `flan` happened to be invoked from. A macro had +no way to honour that rule: it runs inside the compiler and could always have called +`slurp`, but a `Form` carries no location, deliberately, so a macro handed +`(defedn T "assets/x.edn")` knows the path and not what it is relative to. + +So the compiler tells it. `lib/macro.ml`'s `dir_of` pokes the call site's directory into +two C symbols in the macro module's own `flan_rt.c` before every expansion, and the +prelude's `(macro-slurp "...")` joins the two. C data and not a Flan global because +`Build.macro_module` emits with hidden visibility and only the `flan.macro.*` thunks stay +exported — the other half of that same comment is that the C goes on resolving the way it +always did, which is what makes these findable. + +It answers `None` rather than signalling, and that is why it is not `slurp`. A condition +raised inside an expansion is raised in the compiler, through the module's own copy of the +runtime, which is the failure `Build.macro_module`'s hidden-visibility note measured: it +takes the process down instead of parking it. Absence arriving as an answer is what lets +a provider refuse *about* a missing file, with a location, which is the sentence its +author wanted anyway. + +Re-expansion re-reads, and nothing had to be built for that: the cached macro module holds +the macro's code, not the data, and `expand_form` calls the macro fresh. Editing the +`.edn` and building again produces the struct that file now implies — measured by adding +a key and finding it in the emitted IR. + +### A package's macro may call the package's functions + +`Load.qualify_macro` already renamed a package macro's body so a call to the package's own +`next` reads `edn/next`; the intent was written down. The module was then compiled from +the prelude and the `defmacro`s alone, so the call arrived at the checker as *the call +edn/next into an imported package*. That was the machinery missing a piece, not a rule — +and it is why a derivation this size can be ordinary Flan over the tokenizer next door +instead of a second scanner inlined into a macro body. + +`Parse.imported_decls` carries the package's declarations beside its macros, already +qualified, and `Macro.compile` trims them to what the macro bodies reach. raylib's five +`with-*` are pure quasiquote, so nothing of raylib is reachable and its module is the one +it always was — which matters, because raylib's declarations are `declare`s against a +library a macro module has no linker argument for. The trim is over names and happens +before `Check`, since a surviving `Declare` would be emitted whether or not the checker +was asked about it. + +One thing this exposed. A quasiquote inside a package's *ordinary function* was never +qualified — only a `defmacro` body goes through `qualify_macro` — so a +`(defn ... [c (Ptr Cursor)] ...)` emitted from a derivation helper reached the importer +naming a type it had never heard of. The name survives into a *string*, which is exactly +the property the expander's walk depends on and exactly what puts it out of a rename's +reach. `rename_expr` now qualifies a literal `(Form.Sym {.s "..."})` naming something the +package owns. Until a package's macros could call its functions there was no helper that +built code, so this could not have shown before. + +### One call, several declarations + +Expansion is form-for-form, and every macro written until now expanded to an *expression*. +A provider produces the struct *and* the reader over it, and a struct per nesting level in +the data: three declarations and more from one form, which no arrangement of one-for-one +reaches. A top-level `(do ...)` is now its items, spliced in place, after expansion and +before the declaration walk. Nobody writes one in a file, and the single-declaration entry +point says so by name for anyone who tries. + +### `compile-error`, because a name carries a name and not a sentence + +This is the one piece that had to go in the compiler, and the prelude's `unless` had +already written down why: *a macro has no error facility, so a malformed call answers a +name nothing defines and the report is the right place with the wrong sentence.* A +provider's refusals are all sentence — *the third element of this vector is a string where +the first two were integers*, at line 3 column 9 of a file the compiler is not reading — +and no symbol an expansion could invent holds that. + +So a macro that has to refuse expands to `(compile-error "...")`, one arm in check.ml's +builtin match. A builtin because it has to fail *while checking*: a declared function +would compile, link and run, and the compile it was meant to stop would have succeeded. +`Loc.from_macro` already stamps the call site onto every node of an expansion, so the +location is the form the author wrote and the sentence is the macro's — the two halves the +prelude's note says are never both right at once. It is wrapped in a `defn` with a +gensym'd name, because a top-level position takes a declaration and the body is where an +expression the checker walks can live. + +### The rules it derives, and the one the game file decided + +A map with keyword keys is a struct, one field per key. An integer is `i64`, a float +`f64`, a boolean `bool`, a string `string` — *copied*, which is `read.flan`'s contract and +not the tokenizer's: a `Token`'s text points into the buffer and a struct that outlives +the buffer cannot hold one. A vector of one repeated shape is `(Vec T)`. A nested map is a +struct named for the path that reaches it, `Tileset-selected-cells`, with a hyphen because +`/` is package qualification and because every name in this language is hyphenated +already, so no case conversion has to be written at macro time. + +The set rule is the one the real file decided. A set is this repo's `(Map T bool)` — +check.ml says exactly that where it refuses a `()` value — so its elements are map *keys*, +and a vector inside a set is therefore a fixed array `[n T]` and not a `(Vec T)`: a Vec is +not a map key and `[2 i64]` is. `game-data.edn` is a set of `[x y]` pairs, so that is the +case rather than a corner of it. Every element must then be the same *length* as well as +the same shape, which falls out of the type comparison already being made, since the +length is in the type. + +Everything else is refused while expanding, with the line and column in the **data** file: +a heterogeneous collection names both positions, an empty one has no element to derive +from, a `nil` has no type, and a map with a key that is not a keyword is not a struct. A +file the compiler could not make sense of is one the program would have read wrongly. + +`(vec-new)` and `(map-new)` have to be *told* what they build by naming a type, and +`(Vec i64)` and `[2 i64]` have no name to be. Both fall back to what the context wants and +a signature is a type position where anything can be written, so each collection gets a +one-line constructor stating its type. The reader reads better for it: it says +`(cells-new a)` where it would otherwise carry a type nobody wrote. + +### Two conditions at read time, for the two ways a file stops matching + +The struct was derived from the file as it was when the program was compiled. +`SchemaDrift` names a key that has arrived or a field that has gone, once each, because a +missing key otherwise leaves a field at zero — a texture path of `""` and a count of `0` — +and the program draws nothing for a reason nothing reports. `ReadFailed` is the louder +one: a generated reader accumulates errors on the cursor, and the cursor is made and +dropped inside the entry point, so a file that does not parse would have handed back a +zeroed struct with nothing said. `read-file` answers an `Option` precisely so a malformed +document is distinguishable from one that is literally nil, and a derived reader is held +to the same honesty. Neither is fatal: signalling a condition no handler takes carries on, +so a program that would rather not care writes nothing. + +### What `defjson` shares, which is the design and not the code + +`vendor/json` imports `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 it needs and the expression that +reads one; a refusal carried in a field rather than raised; the typed constructor per +collection; the gensym'd `compile-error` wrapper. + +Four things are genuinely different. Strings go through `string-of` and never through +`.text`, because `.text` is the raw interior with escapes undecoded and a field read off +it would hold a backslash and an `n` where the file meant a newline. Commas and colons are +tokens rather than whitespace. An object's keys are strings, so a key is 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 either; 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`. + +### What is checked + +`test/programs/edn-provide.flan` reads the real `assets/edn/tileset.edn` through a derived +struct, and its first five lines are `edn-read.flan`'s first five character for character. +Two readers over one file agreeing is what says the derived one is right; either alone +could be self-consistently wrong. The pair memberships are the derivation deciding in +public — `[3 4]` is a key and `[9 9]` is not, where a version that made the set 108 loose +integers would have compiled and answered differently on all four. + +The refusals write their own data file, because the data file *is* the test, and each is +asserted on the position it names rather than on the fact of failing. One checks a line +and column into a file the compiler is not reading, which is the whole of what +`compile-error` was added for. `test_session.ml` expands a `defedn` through a session at +an origin the editor would have sent, which is the `C-c C-m` path and the live-tuning +loop: it asserts both that the data file resolved against the buffer's directory and that +what comes back is code a person can read. The generated readers survey under `@x86` — the +fixed-array map key is a hash and equality pair nothing generated had asked the backend +for before — and `@sanitize` is clean over both programs. diff --git a/docs/PORTING.md b/docs/PORTING.md index 4349110..f4f643a 100644 --- a/docs/PORTING.md +++ b/docs/PORTING.md @@ -214,10 +214,11 @@ tileset file itself. So this is writable today, and the tileset needs no hand-written reader at all: it reads as a `Value.Table` whose `:selected-cells` is a `Value.Set` of pairs, against an arena, -released by one `free-all`. A hand-written reader is still what a *struct* costs, because -`(read-edn T bytes)` is not built — call it ~80 lines for the bitmask table if it wants -to land in a struct rather than a `Value`. See §3 for whether it should be written at -all. +released by one `free-all`. A hand-written reader is no longer what a *struct* costs: +`(edn/defedn Tileset "assets/tileset.edn")` derives the struct from the file while the +program is compiled and emits the reader with it, so the ~80 lines this used to price are +not written at all. See §3 item 9, and `docs/BUILT.md`, "A type provider: the struct a +data file implies". --- @@ -629,10 +630,15 @@ not compete for the same slot. game rather than in the engine. **Do not sequence it ahead of items 4–6 on this game's account.** -9. **`(read-edn T bytes)`.** `vendor:edn` already makes the asset readers writable; this - removes ~80 lines of hand-written cursor walking for two schemas. Convenience, and it - competes with compile-time embedding, which may be the better answer for both files - anyway. +9. ~~**`(read-edn T bytes)`.**~~ **Built**, and not under that name: `(edn/defedn Tileset + "assets/tileset.edn")` reads the *file* while the program is compiled, derives the + struct its shape implies, and emits a reader with it — so the ~80 lines are neither + hand-written nor written by the compiler from a type that was declared by hand. It is a + macro in `vendor:edn`, not a builtin, and `defjson` is the same over `vendor:json`. + The competition with compile-time embedding was the wrong reading of it: they are the + two halves of one answer, the shape from the file at compile time and the bytes from an + `embed` beside it. See `docs/BUILT.md`, "A type provider: the struct a data file + implies". **Not ranked, because this game does not need them:** escaping closures and capture (one site, fixed by one parameter), `Handle` and pools (nothing to pool), `Result`/`try` diff --git a/lib/check.ml b/lib/check.ml index a8bf82a..59f8604 100644 --- a/lib/check.ml +++ b/lib/check.ml @@ -4683,6 +4683,41 @@ and named_call ctx ~want loc name args = | _ -> fail loc "embed is (embed \"path\") for a [u8], or (embed \"path\" string)") + (* ── What a macro says when it has to refuse ─────────────────── + The one thing a macro could not do, written down in the prelude where + [unless] settles for it: "a macro has no error facility: it runs inside + the compiler and anything it signals aborts the compile with no location. + So a malformed (unless) answers a name nothing defines, and the report is + 'unknown name unless-takes-a-test-and-a-body' at the call site, which is + the right place and the wrong sentence." + + A name nothing defines carries a name. It cannot carry a sentence, and a + type provider's refusals are all sentence: the third element of this + vector is a string where the first two were integers; there is no file at + assets/x.edn; :size is a map with keys of two kinds. Those name a position + in a *data* file, which no symbol the expansion could invent will hold. + + So a macro that has to refuse expands to a call to this, and the string is + the report. [Loc.from_macro] has already stamped the call site onto every + node of the expansion, so the location is the [defedn] the author wrote + and the sentence is the macro's — which is the two halves the prelude's + note says are never both right at once. + + A builtin and not a declaration, because it has to fail *here*: a declared + function would compile, link and run, and the compile it was meant to stop + would have succeeded. The whole of it is one arm, and the argument is a + literal for the same reason [embed]'s path is one — there is nothing at + this point in a compile to compute a string from. *) + | "compile-error" -> + arity loc name 1 args; + (match (List.hd args).Ast.e with + | Ast.Str s -> fail loc "%s" s + | _ -> + fail (List.hd args).Ast.loc + "compile-error takes a literal string — it is reported while the \ + program is being checked, so there is nothing here to build one \ + from. A macro that has to refuse builds the sentence as it expands \ + and puts it in the form") | "embed-dir" -> arity loc name 1 args; let arg = List.hd args in @@ -5780,6 +5815,10 @@ let builtins : (string * string * string) list = ("embed-dir", "embed-dir [\"path\"] [n EmbedFile]", "Every file in the directory, read at compile time, as a fixed array of \ EmbedFile. It does not descend."); + ("compile-error", "compile-error [\"message\"] ()", + "Refuses the compile with that message, at the form it is written in. \ + What a macro expands to when it has to say why: a name nothing defines \ + carries a name, and this carries a sentence."); (* files *) ("slurp", "slurp [string Allocator?] (Vec u8)", diff --git a/lib/load.ml b/lib/load.ml index aadf66a..68797f1 100644 --- a/lib/load.ml +++ b/lib/load.ml @@ -238,6 +238,31 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr = in { a with Ast.body = List.map (rename_expr owned alias bound) a.Ast.body }) arms) + (* A quoted symbol naming something the package declares. + [(Form.Sym {.s "Cursor"})] is what a quasiquote desugars to, and it is + the one place a package's name survives into a *string* — which is + exactly the property [Macro]'s walk depends on and exactly what puts the + name out of an ordinary rename's reach. + + [qualify_macro] handles that for a [defmacro] by renaming the body + before the desugaring, over the text its author wrote. An ordinary + [defn] never went through it, and until a package's macros could call + the package's functions that was never visible: a helper that *builds* + code was not a thing a package could have. It is now — the derivation a + type provider does is far too large for one macro body — and a + [(defn ... [c (Ptr Cursor)] ...)] emitted from one arrived at the + importer naming a type the importer has never heard of. + + Only a literal string, and only a name the package owns. A [.s] computed + at run time is a name the macro made up (a generated struct, a field + read out of the data file) and is nobody's to qualify; a literal naming + [i64] or [let] is not the package's either. The case order matters: this + has to be tried before the general [Struct] arm below, which would + rewrite the constructor and walk past the field. *) + | Ast.Struct (("Form.Sym" as n), [ ("s", ({ Ast.e = Ast.Str s; _ } as v)) ]) + when qualify_name owned alias bound s <> s -> + Ast.Struct (name n, + [ ("s", { v with Ast.e = Ast.Str (qualify_name owned alias bound s) }) ]) | Ast.Struct (n, kvs) -> Ast.Struct (name n, List.map (fun (k, v) -> (k, go v)) kvs) | Ast.Arr items -> Ast.Arr (gos items) @@ -965,12 +990,17 @@ let rec import ~seen ~open_ ~loc alias dir = let nested_macros = List.fold_left (fun acc r -> macro_union acc r.macros) [] nested in + (* Beside the macros, what those macros may call — see the note over + [Parse.imported_decls]. The same set the package's own files are checked + against, so a macro of a package this one imports is compiled against + exactly what its author could see. *) + let nested_decls = List.concat_map (fun r -> r.decls) nested in (* The package's own files, parsed with what it imported in front of them and nothing else. A parent's macros are deliberately not here: this package did not import that parent, and a name it never asked for is not one it should be able to call. *) let ds = - Parse.with_imported nested_macros + Parse.with_imported ~decls:nested_decls nested_macros (fun () -> List.concat_map (fun (_, forms) -> Parse.program forms) sources) in (* [main] is the importer's, always. A package that called its own would @@ -1319,7 +1349,8 @@ let program ?(parse = Parse.program) ~file (forms : Form.t list) : t = (imports_of forms) in let decls = - Parse.with_imported (macro_union imported.macros !Parse.imported_macros) + Parse.with_imported ~decls:(imported.decls @ !Parse.imported_decls) + (macro_union imported.macros !Parse.imported_macros) (fun () -> parse forms) in let t = diff --git a/lib/macro.ml b/lib/macro.ml index 26de4f2..1580231 100644 --- a/lib/macro.ml +++ b/lib/macro.ml @@ -82,11 +82,23 @@ let self = | Some s when s <> "" -> s | _ -> Build.stamp_of Sys.executable_name) -let key (extra : Form.t list) = +(* [support] is in the key for the same reason the prelude's text is: it is + compiled into the module, so a package whose functions changed while its + macros did not is a stale [.so] that the extras alone would not notice. + [Marshal] and not a printer, because [Ast] has no printer and one written + for a cache key would be a second rendering of the tree to keep in step with + the first. The declarations are plain data — variants, strings, floats and + locations, no closures and no abstract blocks — so the image is structural, + and it moves when a location does. That direction is the safe one: a + cosmetic edit above a package's functions costs a rebuild of the module, and + nothing costs a stale one. *) +let key ?(support = []) (extra : Form.t list) = Digest.to_hex (Digest.string (Lazy.force self ^ "\000" ^ Prelude.source ^ "\000" - ^ String.concat "\000" (List.map Form.to_string extra))) + ^ String.concat "\000" (List.map Form.to_string extra) + ^ "\000" + ^ (if support = [] then "" else Marshal.to_string support []))) (* True while a macro module is being built. [Build.macro_module] goes through [Check.program], which parses the prelude, which calls back into @@ -163,9 +175,99 @@ let reduce (forms : Form.t list) : Form.t list = | _ -> true) forms +(* ── What a package's macro may call ──────────────────────────────── + The header above says a macro body may call prelude functions and other + macros and nothing else, and for a macro written in a *package* that was the + machinery missing a piece rather than a rule. [Load.qualify_macro] renames + the body so a call to the package's own [next] reads [edn/next] — it says + the intent plainly — and the module was then compiled without anything of + that name in it, so the call arrived at the checker as "the call edn/next + into an imported package". + + So [Parse.imported_decls] carries the package's declarations beside its + macros, already qualified, and they go into the module. Trimmed to what the + macros actually reach, for two reasons that are both about programs whose + macros want none of this: raylib's five [with-*] are pure quasiquote, so + nothing of raylib is reachable and the module is the one it always was — and + raylib's declarations are [declare]s against a library this link has no + argument for, so a module that took the whole package would fail to link + for every program that draws anything. + + Reachability over names and not over [Reach]'s checked program, because the + trim has to happen *before* [Check]: an [Ast.Declare] that survived into the + module would be emitted whether or not the checker was ever asked about it. + A type is reached the same way a function is — [Load.uses] walks signatures + and bodies alike — which is what keeps [edn/Cursor] in when [edn/next] is. *) + +let support (roots : string list) (ds : Ast.decl list) : Ast.decl list = + if ds = [] then [] + else begin + let want = Hashtbl.create 64 in + List.iter (fun n -> Hashtbl.replace want n ()) roots; + (* Fixpoint over the declarations, since a kept one names more. Bounded by + their number: the set only grows and a pass that adds nothing stops. *) + let changed = ref true in + while !changed do + changed := false; + List.iter + (fun (d : Ast.decl) -> + match Ast.declared_name d with + | Some n when Hashtbl.mem want n -> + List.iter + (fun (u, _) -> + if not (Hashtbl.mem want u) then begin + Hashtbl.replace want u (); + changed := true + end) + (Load.uses [ d ]) + | _ -> ()) + ds + done; + List.filter + (fun (d : Ast.decl) -> + match Ast.declared_name d with + | Some n -> Hashtbl.mem want n + | None -> false) + ds + end + +(* The names a macro's text mentions, which is the root set above. Every symbol + in the body, because a macro body reaches a package's names as calls, as + types in a [let]'s initialiser and as data-type cases — and over-rooting only + ever keeps a declaration that would have compiled anyway. *) +let roots_of (extra : Form.t list) = + List.fold_left (fun acc f -> Load.form_syms f acc) [] extra + let compile (names : string list) (extra : Form.t list) : loaded = + (* The macros themselves are in [imported_decls] too — a [defmacro] is an + [Ast.Defn] by the time [Parse] is finished with it, and [Load] qualifies + and carries it like any other declaration. They arrive here a second time + in [extra], which is where their *current* text is, so the copy in the + support set is dropped rather than reaching the checker as a name defined + twice. Current matters: a session that has just re-evaluated a macro holds + the new body in [macros] and the old one in [decls]. *) + (* Deduped by name as well as filtered, and the dedupe is not belt and + braces. [Load.program] extends the ambient set rather than replacing it — + a session has already set its own when it calls — so a package reached + along two routes, or a file reloaded inside a session that already knows + it, arrives twice. Two declarations of one name reach [Check.program] as a + redefinition, refused with a sentence nobody would connect to this. It is + the rule [Load.macro_union] already applies a level up, applied to the + declarations that now travel with those macros. *) + let support = + let seen = Hashtbl.create 64 in + List.filter + (fun (d : Ast.decl) -> + match Ast.declared_name d with + | Some n when List.mem n names -> false + | Some n -> if Hashtbl.mem seen n then false + else (Hashtbl.add seen n (); true) + | None -> true) + (support (roots_of extra) !Parse.imported_decls) + in let out = - Filename.concat (Build.cachedir ()) ("flan-macros-" ^ key extra ^ ".so") + Filename.concat (Build.cachedir ()) + ("flan-macros-" ^ key ~support extra ^ ".so") in if not (Sys.file_exists out) then begin building := true; @@ -177,8 +279,13 @@ let compile (names : string list) (extra : Form.t list) : loaded = (fun () -> (* [Check.program] prepends the prelude itself — reduced, for the one build that cannot have all of it — so only the file's own defmacros - go in here. *) - let p = Check.program (Parse.program extra) in + and the package declarations they reach go in here. + + The support comes first: it holds the types a macro's signature + names, and a declaration order that mentioned [edn/Cursor] before + declaring it would be refused for a reason that is this line's and + not the author's. *) + let p = Check.program (support @ Parse.program extra) in (* Written beside the final name and renamed, so a second process reading the cache never sees a half-written object. *) let tmp = out ^ "." ^ string_of_int (Unix.getpid ()) in @@ -189,6 +296,48 @@ let compile (names : string list) (extra : Form.t list) : loaded = { handle; fns = List.map (fun n -> (n, Dynload.dl_sym handle ("flan.macro." ^ n))) names } +(* ── Where the call site is ──────────────────────────────────────── + The one thing a macro cannot find out for itself and the one it needs to + read a data file: a Form carries no location — deliberately, see + [Expand.unmarshal] — so a macro handed [(defedn T "assets/x.edn")] knows the + path and not what it is relative to. [(embed "assets/x.edn")] resolves + against the directory of the source file the form is written in, and a macro + reading a file has to resolve it the same way or a package's data would + depend on where flan was invoked from. + + So it is poked in before the call, into the two C symbols the module's own + [flan_rt.c] declares for it. C data and not a Flan global because + [Build.macro_module] emits with hidden visibility and only the + [flan.macro.*] thunks stay exported — the same comment's other half is that + the C goes on resolving the way it always did, which is what makes these two + findable. + + Set per call rather than once per module: one expansion walks the prelude's + forms, the file's own and a package's, and a macro called from a package's + source resolves against *that* file's directory. [Filename.dirname] is + [embed_path]'s own move, and an empty answer — a bare filename with no + directory in it — leaves the length at zero, which the runtime reads as "no + better idea than the process's own directory". *) + +let dir_of (l : loaded) (loc : Loc.t) = + let dir = Filename.dirname loc.Loc.file in + let dir = if String.equal dir "." then "" else dir in + (* Not guarded. The symbol is in the module this just built, so its absence + means [runtime/flan_rt.c] and this file have come apart — and the shape + that failure would take if it were swallowed is a relative path resolving + against the compiler's working directory, which reads some *other* file + and says nothing. A missing symbol raises out of [dl_sym] instead. *) + let buf = Dynload.dl_sym l.handle "flan_macro_dir" in + let n = Dynload.dl_sym l.handle "flan_macro_dir_n" in + (* 4096 is FLAN_PATH_MAX, and a path at or over it is left unset rather than + truncated: half a directory is a path that resolves to the wrong file, + where none at all resolves to none. *) + if String.length dir > 0 && String.length dir < 4096 then begin + Dynload.poke_bytes buf 0 dir; + Dynload.poke_i64 n 0 (Int64.of_int (String.length dir)) + end + else Dynload.poke_i64 n 0 0L + (* ── The walk ────────────────────────────────────────────────────── Bottom up: a macro's arguments are expanded before it is called, so nothing a macro is handed contains a call to another macro. Then what it answers is @@ -212,6 +361,7 @@ let rec expand_form (l : loaded) (f : Form.t) : Form.t = every form it produced knows where it came from and an error on one of them can say so. *) let from = Loc.from_macro n loc in + dir_of l loc; settle l n loc (Expand.call ~loc:from (List.assoc n l.fns) args) fuel | Form.List xs -> Form.make (Form.List (List.map (expand_form l) xs)) loc | Form.Vec xs -> Form.make (Form.Vec (List.map (expand_form l) xs)) loc @@ -230,6 +380,7 @@ and settle l first loc (f : Form.t) left = else begin let args = List.map (expand_form l) args in let from = Loc.from_macro m loc in + dir_of l loc; settle l first loc (Expand.call ~loc:from (List.assoc m l.fns) args) (left - 1) end @@ -416,6 +567,10 @@ let expand_step (f : Form.t) : Form.t * string option = match f.Form.v with | Form.List ({ Form.v = Form.Sym n; _ } :: args) when List.mem_assoc n l.fns -> + (* [C-c C-m] over a type provider reads the data file, which is the + whole of what makes the live loop live: edit the .edn, expand + again, see the struct that file now implies. *) + dir_of l f.Form.loc; ( Expand.call ~loc:(Loc.from_macro n f.Form.loc) (List.assoc n l.fns) args, Some n ) diff --git a/lib/parse.ml b/lib/parse.ml index ab9d9d1..a75c1b5 100644 --- a/lib/parse.ml +++ b/lib/parse.ml @@ -1219,6 +1219,15 @@ let rec decl (f : Form.t) : Ast.decl = | _ -> fail f "defmacro is (defmacro name [param ...] body ...)") + (* Only reachable from the single-declaration entry point below: a file's + forms go through [splice] first, and a [do] there is its items. Said by + name because the two paths differ and the difference is not the author's + fault to guess at. *) + | List ({ v = Sym "do"; _ } :: _) -> + fail f + "a top-level (do ...) is several declarations spliced in place, and this \ + is a position that takes exactly one — a macro answering several is a \ + file's form, not an expression's" | List ({ v = Sym s; _ } :: _) -> fail f "unknown top-level form (%s ...)" s | _ -> fail f "expected a top-level declaration, found %s" (Form.to_string f) @@ -1255,10 +1264,40 @@ let expander : (Form.t list -> Form.t list) ref = ref (fun fs -> fs) whole of an evaluation. Empty is the ordinary case and costs nothing. *) let imported_macros : Form.t list ref = ref [] -let with_imported (ms : Form.t list) (f : unit -> 'a) : 'a = +(* What those macros are allowed to *call*, and it is the same list the + importing program gets: the package's declarations, qualified under the + alias, as [Load] already built them. + + A macro module is compiled from the prelude plus the [defmacro]s, so until + now the header's rule held without anything enforcing it — a macro body + could call prelude functions and other macros and nothing else. A package + macro that called one of its own package's functions was renamed to + [alias/fn] by [Load.rename_form], reached the checker with nothing of that + name declared, and was refused as a call into an imported package. + + That refusal was the machinery missing a piece rather than a rule. The + rename says the intent plainly: what a package's macro answers with, and + what its body calls, is spelled the way the importer spells it. So the + declarations travel beside the macros and go into the module with them. + [Macro.compile] prunes them to what the macros actually reach, so a package + whose macros are pure quasiquote — raylib's five [with-*] — pays nothing and + links nothing new. + + An [Ast.decl list] and not forms, because [Load] has already done the + qualifying over the Ast and a second renamer over [Form] would be that work + written twice, in the file where the two copies could disagree silently. *) +let imported_decls : Ast.decl list ref = ref [] + +let with_imported ?(decls = []) (ms : Form.t list) (f : unit -> 'a) : 'a = let saved = !imported_macros in + let saved_decls = !imported_decls in imported_macros := ms; - Fun.protect ~finally:(fun () -> imported_macros := saved) f + imported_decls := decls; + Fun.protect + ~finally:(fun () -> + imported_macros := saved; + imported_decls := saved_decls) + f (* Two entry points and not one function with a flag, and the reason is the daemon. [Loc.Errors] is a second exception, and the handlers in the session @@ -1273,12 +1312,41 @@ let with_imported (ms : Form.t list) (f : unit -> 'a) : 'a = here: the reader already found where each declaration ends, so skipping a bad one costs nothing and cannot lose its place. Inside a declaration there is no such landmark, so one bad [defn] is one error. *) +(* ── One call, several declarations ──────────────────────────────── + Expansion is form-for-form: [Macro.expand_form] answers one [Form.t] per + input and the loop below turns each into one [Ast.decl]. Every macro written + until now expands to an *expression* — [unless], [into], raylib's [with-*] — + so one-for-one was the whole of what was needed. + + A type provider is the first thing that is not. [(defedn Tileset "t.edn")] + has to produce the struct *and* the reader over it, and a nested map in the + data means a struct per nesting level: three declarations and more from one + form. There is no arrangement of one-for-one that reaches that. + + So a [do] at the top level is its items, in place. It is the sequencing + spelling the language already has, it is Clojure's answer to exactly this, + and it is only ever reachable by a macro: nobody writes [(do (defn ...))] in + a file, and the message below still says so for anyone who tries and wrote + it wrong. Recursive, because a macro that splices what another macro + answered has a [do] inside a [do] and the nesting is not the author's to + flatten by hand. + + It is spliced *after* expansion and before the declaration walk, so what is + spliced is already fully expanded — a [do] holding a call to another macro + settled before it got here. *) +let rec splice (f : Form.t) : Form.t list = + match f.Form.v with + | Form.List ({ Form.v = Form.Sym "do"; _ } :: items) -> + List.concat_map splice items + | _ -> [ f ] + let parse_forms ~keep_going (forms : Form.t list) : Ast.decl list = (* Quasiquote first and always, because it is pure and needs nothing loaded: it is what turns a macro body into ordinary code, and the prelude's own macros have to parse in a process that has not built a macro module yet. Then expansion, which may need one. *) let forms = !expander (List.map Expand.quasiquote forms) in + let forms = List.concat_map splice forms in temps := 0; let s = Loc.sink ~on:keep_going in let decls = List.filter_map (fun f -> Loc.caught s (fun () -> decl f)) forms in diff --git a/lib/prelude.ml b/lib/prelude.ml index 95b5759..4bef62e 100644 --- a/lib/prelude.ml +++ b/lib/prelude.ml @@ -1794,6 +1794,41 @@ let source = {flan| (let [n (i64 0)] (if (= (file-stat-raw path (addr n)) 1) (Some n) None))) +;; ── Reading a file while a macro runs ───────────────────────────────── +;; +;; The one thing a macro needed that it could not write for itself. A macro is +;; compiled and dlopened into the compiler, so `slurp` was always callable from +;; one; what was missing is that a macro has no idea where its call site is, +;; and so no way to resolve a path the way `(embed "assets/x.edn")` resolves +;; one — relative to the directory of the source file the form is written in. +;; +;; This is that rule, and it is the *same* rule: the compiler pokes the call +;; site's directory into the runtime before every expansion (runtime/flan_rt.c, +;; "Reading a file while a macro runs", and lib/macro.ml's expand_form), and a +;; relative path is joined to it. An absolute path is taken as written. +;; +;; **None rather than a condition**, which is the whole reason this is not +;; `slurp`. A condition signalled inside an expansion is signalled *in the +;; compiler*, through the macro module's own copy of the runtime, and that is +;; the failure `Build.macro_module`'s hidden-visibility note measured: it takes +;; the process down instead of parking it. Absence arriving as an answer is +;; what lets a type provider say "there is no file at that path" as a refusal +;; with a location, which is the sentence its author wanted anyway. +;; +;; **Outside a macro it is still a read**, with the path relative to the +;; process rather than to any source file — nothing else knows better, and +;; every program links this runtime. It is not a file API and `slurp` is; this +;; exists so a macro can look at data at compile time. +(declare macro-slurp-raw [path string out-len (Ptr i64)] (Ptr u8) + "flan_macro_slurp") + +(defn macro-slurp [path string] (Option [u8]) + (let [n (i64 0) + p (macro-slurp-raw path (addr n))] + (if (< n 0) + None + (Some (slice-from-ptr p (i32 n)))))) + ;; ── Form: what a macro takes and what it answers ────────────────────── ;; ;; The reader's output, mirrored on the Flan side, because a macro is a diff --git a/lib/session.ml b/lib/session.ml index 230158c..a119ffe 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -122,6 +122,32 @@ let create ?(debug = false) ?(x86 = false) ~file () = macros = Load.macro_union (own_macros forms) l.Load.macros; thunks = 0; debug; x86 }, l) +(* What a macro may call, for the same reason [macros] is held: an evaluation + parses one form with no import in sight, and a package macro whose body + calls its own package's functions has to find them. [Load.program] hands + this to [Parse.with_imported] from the import it just read; a session has to + answer it from what it already holds. + + Filtered out of [decls] by ownership rather than kept as a second list, + because [decls] is the one thing every redefinition already maintains and a + parallel copy would be a second thing to remember to update. A package's + names are qualified in there — that is what "post-Load: flat, one namespace" + means — so the prefix is the whole test. + + The buffer's own declarations are deliberately not here. A macro module is + built from the prelude with no part of the file in it (see [Macro.reduce]'s + header, and the cycle it is about), and a session's [decls] is the file. *) +let package_decls t = + List.filter + (fun (d : Ast.decl) -> + match Ast.declared_name d with + | Some n -> + List.exists + (fun (p : Load.pkg) -> String.starts_with ~prefix:(p.Load.alias ^ "/") n) + t.pkgs + | None -> false) + t.decls + (* Which package a file being edited belongs to, if any. A form typed into vendor/agent/agent.flan declares [poll], but the running @@ -480,7 +506,7 @@ let restore t h = let eval ?(origin = "") ?pause t src : change = let forms = Reader.read_all ~file:origin src in - Parse.with_imported t.macros @@ fun () -> + Parse.with_imported ~decls:(package_decls t) t.macros @@ fun () -> (* Through [Load] like any other source, so an evaluated (import ...) means what it means in a file. Its expansion is what gets spliced, which is also why the accumulated list is the post-Load one: re-evaluating a file that @@ -1296,7 +1322,7 @@ let eval_expr ?(origin = "") ?(pause = false) t src : change = untouched: a cold macro module costs its ~300ms before that clock starts, and the non-termination refusals raise [Loc.Error] out of this call, which the daemon already answers as an error rather than a silence. *) - let parsed = Parse.with_imported t.macros (fun () -> Parse.expr form) in + let parsed = Parse.with_imported ~decls:(package_decls t) t.macros (fun () -> Parse.expr form) in (* Wrapped before the checker, so the call is checked like any other and a prelude that stopped offering [pause] would be an ordinary unknown name rather than a thunk that silently did not stop. The [Do] takes the @@ -1440,7 +1466,7 @@ let macroexpand ?(origin = "") ~(all : bool) t (src : string) : expansion let before = Expand.quasiquote form in (* And the session's macros in front of it, as [eval] and [eval_expr] both put them: [Macro.program] reads [Parse.imported_macros] directly. *) - Parse.with_imported t.macros @@ fun () -> + Parse.with_imported ~decls:(package_decls t) t.macros @@ fun () -> let after, name = if all then Macro.expand_all before else Macro.expand_step before in diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 3f9c3a8..89952a1 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -2975,6 +2975,88 @@ const uint8_t *flan_getenv(const uint8_t *name, int64_t n, int64_t *len) { return (const uint8_t *)v; } +/* ── Reading a file while a macro runs ───────────────────────────────── + * + * A macro is compiled and dlopened into the compiler, so it is ordinary native + * code and could always have called `slurp`. What it could not do is resolve a + * path the way the rest of the language resolves one. (embed "assets/x.edn") + * is relative to the directory of the *source file the form is written in* — + * lib/check.ml's embed_path, and Odin's rule before it — because anything else + * makes a package's assets depend on where flan happened to be invoked from. + * A macro has no idea where its call site is: a Form carries no location, on + * purpose (see the prelude's Form, and Expand.unmarshal). + * + * So the compiler tells it, here. lib/macro.ml dlsym's the two symbols below + * and pokes the call site's directory into them before every expansion; a + * macro-time read joins that to a relative path and opens the result. The + * channel is C data and not a Flan global because Build.macro_module emits the + * module with hidden visibility — only the flan.macro.* thunks stay exported — + * and "the C goes on resolving the way it always did" is the other half of + * that same comment. + * + * It is empty in a process that is not expanding anything, which is every + * process but the compiler: the module links this file, so a *program* holding + * these symbols simply has a relative path mean what it means to the shell. + * + * `slurp` is deliberately not what the prelude wraps around this. slurp + * signals a FileError, and a condition raised inside an expansion is raised in + * the compiler, through the macro module's own copy of the runtime — which is + * the failure Build.macro_module's ~hidden comment measured. Absence answers + * here as a length of -1, on getenv's pattern, so a data file that is not + * there becomes something the macro can refuse *about* rather than a trap. */ + +char flan_macro_dir[FLAN_PATH_MAX] = { 0 }; +int64_t flan_macro_dir_n = 0; + +/* The bytes are the caller's to read and nobody's to free: an expansion is + * bounded by the size of the program being compiled, which is exactly the + * budget lib/dynload.ml's `owned` note already spends on a macro's own + * allocations. Leaking is the same decision as there, for the same reason — + * the returned slice is read after the call returns, and there is no `drop`. */ +const uint8_t *flan_macro_slurp(const uint8_t *path, int64_t n, int64_t *len) { + static const char empty[1] = { 0 }; + char rel[FLAN_PATH_MAX]; + char full[FLAN_PATH_MAX]; + FILE *f; + long size; + uint8_t *buf; + size_t got; + *len = -1; + if (!flan_path_cstr(path, n, rel)) return (const uint8_t *)empty; + /* An absolute path is taken as written, and a relative one is joined to the + * call site's directory — embed_path's two cases, in the same order. A dir + * that was never poked leaves a relative path relative to the process, which + * is the only thing it can mean when nothing knows better. */ + if (rel[0] == '/' || flan_macro_dir_n <= 0) { + memcpy(full, rel, (size_t)n + 1); + } else { + if (flan_macro_dir_n + 1 + n >= FLAN_PATH_MAX) return (const uint8_t *)empty; + memcpy(full, flan_macro_dir, (size_t)flan_macro_dir_n); + full[flan_macro_dir_n] = '/'; + memcpy(full + flan_macro_dir_n + 1, rel, (size_t)n + 1); + } + f = fopen(full, "rb"); + if (!f) return (const uint8_t *)empty; + /* A directory opens on Linux and fails at the read, which is the trap + * check.ml's read_embed_file records: guarding only the open turns + * (macro-slurp "somedir") into a crash rather than an answer. Both ends are + * guarded here and both answer absent. */ + if (fseek(f, 0, SEEK_END) != 0) { fclose(f); return (const uint8_t *)empty; } + size = ftell(f); + if (size < 0 || fseek(f, 0, SEEK_SET) != 0) { + fclose(f); + return (const uint8_t *)empty; + } + buf = (uint8_t *)malloc((size_t)size + 1); + if (!buf) { fclose(f); return (const uint8_t *)empty; } + got = fread(buf, 1, (size_t)size, f); + fclose(f); + if (got != (size_t)size) { free(buf); return (const uint8_t *)empty; } + buf[size] = 0; + *len = (int64_t)size; + return buf; +} + /* ── The rest of the file surface ────────────────────────────────────── * * Four more POSIX-shaped calls under the same rules as flan_file_size, diff --git a/test/dune b/test/dune index 143edfb..ca7b658 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 @@ -103,6 +106,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/*) @@ -149,7 +153,8 @@ ; a Flan program: flan_dyn.c has no Flan spelling yet. It is also the one ; translation unit here that frees anything, which is what makes it worth a ; sanitized run at all. See [dyn_sweep]. - (file dyn_ops.c)) + (file dyn_ops.c) + (glob_files programs/assets/json/*)) (action (run ./test_sanitize.exe))) ; The corpus a third time, under Valgrind's memcheck. Its own alias for the @@ -186,6 +191,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/*) @@ -244,6 +250,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/*) @@ -407,6 +414,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/edn/tuning.edn b/test/programs/assets/edn/tuning.edn new file mode 100644 index 0000000..4241b2c --- /dev/null +++ b/test/programs/assets/edn/tuning.edn @@ -0,0 +1,11 @@ +;; A tuning file with one of each shape defedn derives, so that the struct it +;; produces exercises every arm: a string, an integer, a float, a boolean, a +;; homogeneous vector, a nested map, and a nested map inside that one. +{:name "goblin" + :hp 12 + :speed 1.5 + :boss? false + :drops [3 1 4 1 5] + :hitbox {:w 16 + :h 24 + :offset {:x -2 :y 0}}} 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/edn-provide.flan b/test/programs/edn-provide.flan new file mode 100644 index 0000000..318eaab --- /dev/null +++ b/test/programs/edn-provide.flan @@ -0,0 +1,120 @@ +;;;; defedn over two real files, and the condition a drifted one signals. +;;;; +;;;; The first half is the claim the feature is for: `(.texture-path t)` here +;;;; is a field load off a struct nobody declared, and the same numbers +;;;; edn-read.flan prints through the dynamic reader come out of it. Two +;;;; readers over one file agreeing is what says the derived one is right — +;;;; either alone could be self-consistently wrong. +;;;; +;;;; The second half is the shape matrix: a string, an integer, a float, a +;;;; boolean, a vector, and a map inside a map, each read back. +;;;; +;;;; The third is drift. The struct was derived from the file as it was when +;;;; this was compiled; the bytes read at run time are a later version of it, +;;;; with one key gone and one arrived. Both are named by SchemaDrift, which is +;;;; the whole reason the reader carries one: a missing key otherwise leaves a +;;;; field at zero and the program draws nothing for a reason nothing reports. + +(import edn "vendor:edn") + +;; Both derived at compile time, from the files as they sit beside this one. +;; The path is the (embed "...") path — relative to this file — and not the +;; path the run-time reads below use, which is relative to the process. +(edn/defedn Tileset "assets/edn/tileset.edn") +(edn/defedn Tuning "assets/edn/tuning.edn") + +;; The same file the dynamic reader in edn-read.flan walks. Embedded rather +;; than read, so this half asserts the reader and not the filesystem. +(defconst tileset (embed "assets/edn/tileset.edn")) +(defconst tuning (embed "assets/edn/tuning.edn")) + +(defn show-tileset [a Allocator] () + (let [t (Tileset-of-bytes tileset a)] + ;; The line edn-read.flan prints first, off a struct field this time. + (println (.texture-path t)) + ;; 54 pairs, and the same three memberships and one miss. A derivation + ;; that flattened the pairs into 108 integers would have a different count + ;; and would answer no to every one of these. + (println (len (.selected-cells t))) + (println (has-key? (.selected-cells t) [3 4])) + (println (has-key? (.selected-cells t) [0 0])) + (println (has-key? (.selected-cells t) [4 11])) + (println (has-key? (.selected-cells t) [9 9])))) + +(defn show-tuning [a Allocator] () + (let [t (Tuning-of-bytes tuning a)] + (println (.name t)) + (println (.hp t)) + (println (.speed t)) + (println (if (.boss? t) "yes" "no")) + (println (len (.drops t))) + ;; 3 + 1 + 4 + 1 + 5. A vector read that stopped at the first element would + ;; still have a plausible length from a zeroed Vec, so the sum is the claim. + (let [total (i64 0)] + (dotimes [i (len (.drops t))] + (set total (+ total (at (.drops t) i)))) + (println total)) + ;; The nested structs, by the names the paths give them: Tuning-hitbox and + ;; Tuning-hitbox-offset. Both are ordinary field loads, two deep. + (println (.w (.hitbox t))) + (println (.h (.hitbox t))) + (println (.x (.offset (.hitbox t)))) + (println (.y (.offset (.hitbox t)))))) + +;; ── Drift ─────────────────────────────────────────────────────────── +;; +;; The struct says :name :hp :speed :boss? :drops :hitbox. These bytes have no +;; :speed and have a :level the struct has never heard of, which is what a +;; tuning file looks like a month after the program was built. +(defconst drifted string + "{:name \"imp\" :hp 3 :level 7 :boss? true :drops [1] :hitbox {:w 1 :h 1 :offset {:x 0 :y 0}}}") + +(defn show-drift [a Allocator] () + (handler-bind + [(edn/SchemaDrift [d] + (do (print (if (.extra? d) "extra " "missing ")) + (print (.field d)) + (print " in ") + (println (.struct d))))] + (let [t (Tuning-of-bytes (bytes drifted) a)] + ;; The fields that were there are read, which is the other half of the + ;; contract: a drifted file is reported, not refused. :speed is the one + ;; that was missing and is zero. + (println (.name t)) + (println (.hp t)) + (println (.speed t))))) + +;; ── A file that does not parse ────────────────────────────────────── +;; +;; The louder failure, and the one that had the quieter answer until ReadFailed +;; existed: a generated reader accumulates errors on the cursor, and the cursor +;; is made and dropped inside the entry point, so a stray brace gave back a +;; zeroed struct with nothing said. The rest of this package refuses to do +;; that — read-file answers an Option so that a malformed document is +;; distinguishable from one that is literally nil — and a derived reader has to +;; be at least as honest. +(defconst broken string "{:name \"orc\" :hp }") + +(defn show-broken [a Allocator] () + (handler-bind + [(edn/ReadFailed [e] + (do (print "unreadable ") + (print (.struct e)) + (print ": ") + (println (edn/error-message (.code e)))))] + (let [t (Tuning-of-bytes (bytes broken) a)] + ;; Read anyway, and zeroed, which is the half a handler that carries on + ;; is choosing. Printed so that "it signalled" and "it gave back nothing + ;; usable" are two claims rather than one. + (println (.hp t))))) + +(defn main [] i32 + (let [a (heap-allocator)] + (show-tileset a) + (println "") + (show-tuning a) + (println "") + (show-drift a) + (println "") + (show-broken a)) + 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 de921cc..fb5d5f7 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -643,6 +643,184 @@ let () = outputs ~opt:"-O0" "edn/read over the tileset, -O0" "programs/edn-read.flan" edn_read_out; + (* The same file again, through a struct derived from it at compile time. + The first five lines are the first five above, character for character, + and that is the claim: two readers over one file agreeing is what says + the derived one is right, where either alone could be self-consistently + wrong. Nothing in the program declares a type and nothing in it matches + on a tag — (.texture-path t) is a field load. + + The pair memberships are the derivation's own decision showing: the set + became a (Map [2 i64] bool), so [3 4] is a key and [9 9] is not. A + version that made it a (Vec i64) of 108 numbers would have compiled and + would answer differently on every one of these four lines. + + Then the shape matrix — a string, an integer, a float, a boolean, a + vector summed, and a map inside a map read two field loads deep, by the + names the paths give them. 14 is 3+1+4+1+5, and it is there because a + length alone would pass on a Vec that was allocated and never filled. + + Last, drift: the struct was derived from a file with :speed and without + :level, and the bytes read carry the opposite. Both conditions are + named, in the order the reader meets them — the unknown key as it + arrives, the missing field when the map closes — and the read carries + on, which is the other half of the contract. :speed reads 0. + + Then the louder failure, which had the quieter answer until ReadFailed + existed: a generated reader accumulates errors on the cursor, and the + cursor is made and dropped inside the entry point, so a file that does + not parse handed back a zeroed struct with nothing said. The rest of the + package refuses to do that — read-file answers an Option so a malformed + document is distinguishable from one that is literally nil — and this is + the derived reader being as honest. Two lines and not one: it signalled, + and what it gave back is nothing usable. *) + let edn_provide_out = + "./source-assets/Sprout Lands Premium/Objects/Mushrooms, Flowers, \ + Stones.png\n\ + 54\ntrue\ntrue\ntrue\nfalse\n\n\ + goblin\n12\n1.5\nno\n5\n14\n16\n24\n-2\n0\n\n\ + extra level in Tuning\nmissing speed in Tuning\nimp\n3\n0\n\n\ + unreadable Tuning: unexpected token: not the kind the caller was \ + reading\n0\n" + in + outputs "defedn over the tileset and a tuning file" + "programs/edn-provide.flan" edn_provide_out; + 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 + than a struct with a field of some guessed type. + + Both halves of the pair are written here rather than committed, because + the data file *is* the test: a fixture .edn sitting in the corpus would + be read by nothing else and would look like an asset. They go beside the + other programs so that the two things a provider resolves — the vendor: + collection, and the data path relative to the source file — resolve the + way they do for a real one. + + Each is asserted on the position it names and not only on the fact of + failing. A version that refused everything with one sentence would pass + 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 refusal ~pkg ~mac ~ext name data needle = + let base = "programs/refuse-" ^ name in + 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 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 + with + | _ -> + incr failures; + Printf.printf "FAIL %s\n it was accepted\n" name + | exception Loc.Error { Loc.dmsg = m; _ } -> + if not (contains m needle) then begin + incr failures; + 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 _ -> ()) [ 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"; + (* A map whose keys are not all keywords is not a struct: a field is named, + and "name" in quotes is a value. *) + provider_refusal "mixed-keys" "{:a 1 \"b\" 2}" "that is not a keyword"; + (* An empty collection carries no element to derive an element type from, + which is the one thing a shape read out of data cannot guess. *) + provider_refusal "empty-vector" "{:xs []}" + "has no element to derive an element type from"; + (* nil has no type. A field that is sometimes absent is not something a + struct holds, and guessing would put a zero where a decision belongs. *) + provider_refusal "nil-value" "{:a nil}" "has no type to derive"; + (* The line and column are into the *data* file and are the point of the + whole error facility: this one is on the third line. *) + provider_refusal "position" "{:a 1\n :b 2\n :c [1 \"x\"]}" "line 3 column"; + (* A set becomes a (Map T bool), so its elements are map keys. A set of + maps is refused by name here rather than at the (Map ...) it would build, + whose message names a type nobody wrote. *) + provider_refusal "set-of-maps" "{:s #{{:a 1}}}" + "is not something this builds"; + (* And the file that is not there, which is the case the path rule is for: + it says where it looked. *) + (let flanp = "programs/refuse-missing.flan" in + Out_channel.with_open_bin flanp (fun ch -> + Out_channel.output_string ch + "(import edn \"vendor:edn\")\n\ + (edn/defedn T \"no-such-file.edn\")\n(defn main [] i32 0)\n"); + (match + let l = Load.program ~file:flanp (Reader.read_file flanp) in + Check.program l.Load.decls + with + | _ -> + incr failures; + Printf.printf "FAIL a defedn over a file that is not there\n\ + \ it was accepted\n" + | exception Loc.Error { Loc.dmsg = m; _ } -> + if not (contains m "there is no file at no-such-file.edn") then begin + incr failures; + Printf.printf "FAIL a defedn over a file that is not there\n\ + \ said: %S\n" m + 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 @@ -2999,10 +3177,11 @@ level "1" outputs ~opt:"-O0" "dyn: an unannotated defn at two types, -O0" "programs/dyn-basic.flan" dyn_basic_out; (* The rendering is the typed printer's: a leading space after the open - bracket and strings quoted inside a collection but bare alone — - (println [\"a\"]) and (println \"a\") already disagree exactly this way, - so the dyn printer disagreeing would have been the bug. The stub this - expectation was first written against printed neither. *) + bracket, and a string quoted inside a collection but bare alone — + println of a one-string array and of the string itself already + disagree exactly this way, so the dyn printer disagreeing would have + been the bug. The stub this expectation was first written against + printed neither. *) let dyn_vec_out = "4\n[ 1 2.5 \"three\" true]\n1 2.5 three true \n" in outputs "dyn: a heterogeneous vector" "programs/dyn-vec.flan" dyn_vec_out; diff --git a/test/test_session.ml b/test/test_session.ml index e32b55e..e942f69 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -737,6 +737,55 @@ let () = | exception Loc.Error { Loc.dmsg = m; _ } -> fail "a session that refused an expansion could not expand afterwards: %s" m); + (* ── A type provider, expanded ───────────────────────────────────── + Two claims, and they are the two halves of the live-tuning loop. + + The first is the path. A macro that reads a data file resolves it the way + (embed "...") does — against the directory of the source file the *form* + is written in — and a macro cannot know where that is, because a Form + carries no location. The compiler pokes the call site's directory in + before every expansion, and the call site here is an origin the editor + sent, not a file on a command line. "assets/edn/tuning.edn" is beside + programs/edn-provide.flan and nowhere near this process's directory, so an + expansion that answered anything at all read the right file. + + The second is that the answer is readable. `C-c C-m` over a provider is + the only way to see what it decided, and a provider whose output nobody + can look at is a plugin. So this asserts on text a person would recognise: + the struct with its fields and derived types, the nested struct named for + its path, and the reader's dispatch on a key. Asserted as substrings + rather than in full — the expansion is some hundreds of characters and a + golden copy of it would fail on every comment reflowed in the derivation. + + It also re-reads on every expansion, which is what makes editing the .edn + and hitting C-c C-m a loop: nothing is cached but the macro module, and + that holds the macro's code, not the data. *) + (let pt, _ = Session.create ~file:"programs/edn-provide.flan" () in + match + Session.macroexpand ~origin:"programs/edn-provide.flan" ~all:false pt + "(edn/defedn Tuning \"assets/edn/tuning.edn\")" + with + | x -> + let got = Form.to_source x.Session.xafter in + List.iter + (fun want -> + if not (has got want) then + fail "expanding a defedn: %S is not in\n%s" want got) + [ (* The struct, with a type per field derived from the value. *) + "(defstruct Tuning [name string hp i64 speed f64 boss? bool"; + (* The vector, and the constructor that states its type so that + (vec-new) has something to take it from. *) + "drops (Vec i64)"; + (* The nested map, named for the path that reaches it, and the one + nested inside that. *) + "(defstruct Tuning-hitbox-offset [x i64 y i64])"; + "hitbox Tuning-hitbox"; + (* And the reader, dispatching on a key onto a field. *) + "(edn/keyword=? k \"speed\")"; + "(set (.speed out) (edn/need-float c))" ] + | exception Loc.Error { Loc.dmsg = m; _ } -> + fail "expanding a defedn through a session: %s" m); + (* A form typed into a file that is *imported as a package* has to be qualified the way the import qualified it, or it splices as a brand-new unrelated name: the evaluation reports success and the running program diff --git a/vendor/edn/provide.flan b/vendor/edn/provide.flan new file mode 100644 index 0000000..c4b9589 --- /dev/null +++ b/vendor/edn/provide.flan @@ -0,0 +1,584 @@ +;;;; defedn: a struct derived from a data file, at compile time. +;;;; +;;;; F#'s type providers, with the part that makes them worth having and none +;;;; of the part that needs a plugin protocol. `(edn/defedn Tileset "t.edn")` +;;;; reads t.edn while the program is being compiled, works out what shape it +;;;; is, and emits the struct that shape implies together with a reader for it. +;;;; From then on `(.texture-path data)` is a field load off a struct: no Value, +;;;; no match, no runtime tag, nothing to look up by name. +;;;; +;;;; read.flan is the other half of the same choice, and both belong here. A +;;;; dynamic Value is what you want when the shape is the program's *input* — +;;;; an editor opening a file it has never seen. A provider is what you want +;;;; when the shape is part of the program and only the numbers change, which +;;;; is what a game's tuning file is. The typed world is not an afterthought: +;;;; it is the same tokenizer, read by a macro instead of by a loop. +;;;; +;;;; ── What it needs, and what was built for it ───────────────────────── +;;;; +;;;; A macro is compiled and dlopened into the compiler, so it has always been +;;;; able to run arbitrary code at expansion time. Three things it could not do +;;;; are what this file rests on, and all three are general: +;;;; +;;;; - `(macro-slurp "t.edn")` reads a file at expansion time, resolved the +;;;; way `(embed "t.edn")` resolves a path — against the directory of the +;;;; source file the form is written in. +;;;; - a package's macro may call the package's own functions, which is why +;;;; the derivation below is ordinary Flan over the tokenizer next door +;;;; rather than a second scanner inlined into a macro body. +;;;; - a macro may answer several declarations, as a top-level `(do ...)`, +;;;; and may refuse with a sentence through `(compile-error "...")`. +;;;; +;;;; ── The rules ──────────────────────────────────────────────────────── +;;;; +;;;; A map with keyword keys is a struct, one field per key, named for the +;;;; keyword. An integer is an i64, a float an f64, a boolean a bool, a string +;;;; a `string` — copied, which is read.flan's contract and not the tokenizer's: +;;;; a Token's text points into the buffer, and a struct that outlives the +;;;; buffer cannot hold one. +;;;; +;;;; A vector of one repeated shape is a `(Vec T)`. A set is this repo's own +;;;; spelling of one, `(Map T bool)` — check.ml says exactly that where it +;;;; refuses a map with a `()` value — and its elements are therefore read as +;;;; map *keys*. That is why a vector inside a set derives to a fixed array +;;;; `[n T]` rather than to a Vec: a Vec is not a map key and `[2 i64]` is. +;;;; The file this was built for is a set of pairs, so that is the case rather +;;;; than a corner of it. +;;;; +;;;; A nested map is a struct of its own, named for the path that reaches it — +;;;; `Tileset-selected-cells`. A hyphen because `/` is package qualification +;;;; and cannot appear in a name a program declares, and because every name in +;;;; this language is already hyphenated, so no case conversion has to be +;;;; written to produce one. The path is unique, so the name is. +;;;; +;;;; Everything else is refused while expanding, with the line and column in +;;;; the *data* file. A refusal is the point: a file the compiler could not +;;;; make sense of is one the program would have read wrongly. + +;; ── Small string work, for the refusals and the names ─────────────── + +(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` +;; below holds a line and a column at the same time, which read as the same +;; number until this copied. +(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, because that is what a slice into the +;; buffer costs nothing to produce. 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 at once, which is why they travel together: +;; the *type* the value implies, the struct declarations that type needs (a +;; nested map contributes one, and everything nested inside it contributes +;; more), and the *expression* that reads one — written against a cursor named +;; `c` and an allocator named `a`, which is the shape every generated reader +;; binds. +;; +;; `bad` is the refusal, carried rather than raised: there is no exception to +;; throw out of a recursive walk, and a partial answer with a reason attached +;; propagates to the top where the one `compile-error` is written. Empty means +;; the walk succeeded. +(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)) + +;; ── The scalars a generated reader calls ──────────────────────────── +;; +;; Functions and not inlined expansions, so that `C-c C-m` over a defedn shows +;; a reader somebody can read. Each is `expect` plus the conversion, with the +;; same "the cursor carries the error" contract the hand-written reader in +;; test/programs/edn.flan is written against: a failure leaves the value at +;; zero and 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)) + +;; Two kinds are acceptable, because 2 and 2.0 are the same number and a tuning +;; 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)) + +;; Copied into the allocator, which is the whole difference between a field of +;; a struct and a Token's text. The lifetime contract at the top of edn.flan is +;; the reason: `text` is a slice of the buffer, and a struct read out of a +;; buffer that is later freed would hold a dangling one. +(defn need-string [c (Ptr Cursor) a Allocator] string + (let [t (expect c tok-string) + b (vec-new u8 a)] + (append (addr b) (.text t)) + (string (as-slice b)))) + +;; Whether the next thing, past trivia, is this byte. Enough of a peek for +;; every loop below — "is the collection over" is the only lookahead a reader +;; of a known shape ever needs — and it consumes nothing, so the closer is +;; still there for `expect` to take. +(defn at-byte? [c (Ptr Cursor) b u8] bool + (skip-trivia c) + (and (not (at-end? c)) (= (at (.src c) (.pos c)) b))) + +;; ── The condition a reader signals when the file moved ────────────── +;; +;; The case the whole feature exists to catch. The struct was derived from the +;; file as it was when the program was compiled; the file read at run time may +;; be a later one, and a field that has gone or arrived 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 texture path of "" and a count of 0, and the +;; program draws nothing for a reason nothing reports. So it is a condition, +;; with the field named. Nothing here is fatal — signalling a condition no +;; handler takes carries on — so a program that would rather not care does not +;; have to write anything, and one that would rather know binds a handler. +;; +;; `pos` is the byte offset in the buffer being read: of the offending key for +;; an unknown one, and of the token that ended the map for a missing one, which +;; is where a person would look to add it. +(defstruct SchemaDrift + [field string + struct string + extra? bool + pos i32]) + +;; ── And the one a file that does not parse signals ────────────────── +;; +;; The louder failure had the quieter answer until this existed. A generated +;; reader accumulates errors on the cursor rather than returning them — which +;; is what lets it be a straight line of assignments — and the cursor is made +;; and dropped inside the entry point, so a stray brace in a file read at run +;; time gave the program a zeroed struct and said nothing at all. +;; +;; That is the one thing the rest of this package refuses to do. `read-file` +;; answers an Option precisely so that a malformed document is distinguishable +;; from a document that is literally nil, and the hand-written reader in +;; test/programs/edn.flan tests ok? and prints the reason. A derived reader has +;; to be at least as honest. +;; +;; A condition and not an Option, to match SchemaDrift beside it: both are "the +;; file is not what this program was built for", and a handler that wants to +;; carry on with a half-read struct may, while one that wants to stop has +;; something to stop on. `code` is an err-* constant, which `error-message` +;; turns into a sentence. +(defstruct ReadFailed + [struct string + code i32 + pos i32]) + +;; ── Deriving ──────────────────────────────────────────────────────── +;; +;; One value, from the cursor's current position, consumed. `name` is what a +;; struct here would be called; `src` is the whole buffer, for the positions a +;; refusal names. +(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 a)) + + (= (.kind t) tok-map-open) (derive-map c name (.pos t) src) + (= (.kind t) tok-vec-open) (derive-vec c name (.pos t) src) + (= (.kind t) tok-set-open) (derive-set c name (.pos t) src) + + (= (.kind t) tok-nil) + (derived-bad + (joined3 "the nil 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 defedn derives a type from — a map, a vector, a set, an integer, a float, a boolean or a string"))))) + +;; A vector, whose elements must all come to the same type. The first element +;; decides; every one after it is compared against that decision and both +;; positions are named when they disagree, because "heterogeneous" without +;; saying where sends someone to read the whole file. +(defn derive-vec [c (Ptr Cursor) name string at-pos i32 src [u8]] Derived + (when (at-byte? c \]) + (return (derived-bad + (joined3 "the empty vector at " (where src at-pos) + " has no element to derive an element type from — defedn 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)) + (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 (disagreement "vector" src at-pos n + (.ty head) (.ty item))))) + (set n (+ n 1)))) + (expect c tok-vec-close) + (let [elem (.ty head) + read1 (.reader head) + ty `(Vec ~elem) + cn (Form.Sym {.s (joined name "-new")})] + (ok-derived ty (with-decl (.decls head) `(defn ~cn [a Allocator] ~ty + (vec-new a))) + `(let [xs (~cn a)] + (expect c tok-vec-open) + (while (and (ok? c) (not (at-byte? c \]))) + (push xs ~read1)) + (expect c tok-vec-close) + xs)))))) + +;; Why every collection gets a one-line constructor of its own. +;; +;; `(vec-new)` and `(map-new)` each need to be told what they build, and the +;; way to tell them in argument position is to *name* a type: check.ml's +;; vec_new_elem and map_new_types take an `Ast.Var` and nothing else. A type +;; this derives may have no name — `(Vec i64)` has none, and `[2 i64]`, which +;; is the key of the set in the file this was built for, has none either. +;; +;; Both fall back to what the context wants, and a function's return type is a +;; type position where anything can be written. So the type is stated once, in +;; a signature, and the bare call in the body gets it from `want`. It is also +;; the more readable expansion: the reader says `(cells-new a)` where it would +;; otherwise carry a type nobody wrote. +(defn with-decl [decls [Form] d Form] [Form] + (form-append decls (form-cons d (form-nil)))) + +;; A set becomes `(Map T bool)`, so its elements are map keys. `derive-key` is +;; where that constraint is enforced and said. +(defn derive-set [c (Ptr Cursor) name string at-pos i32 src [u8]] Derived + (when (at-byte? c \}) + (return (derived-bad + (joined3 "the empty set at " (where src at-pos) + " has no element to derive an element type from")))) + (let [head (derive-key c (joined name "-key") src)] + (when (bad? head) + (return head)) + (let [n (i64 1)] + (while (and (ok? c) (not (at-byte? c \}))) + (let [item (derive-key c (joined name "-key") src)] + (when (bad? item) + (return item)) + (when (not (same-type? (.ty head) (.ty item))) + (return (derived-bad (disagreement "set" src at-pos n + (.ty head) (.ty item))))) + (set n (+ n 1)))) + (expect c tok-map-close) + (let [elem (.ty head) + read1 (.reader head) + ty `(Map ~elem bool) + cn (Form.Sym {.s (joined name "-new")})] + (ok-derived ty (with-decl (.decls head) `(defn ~cn [a Allocator] ~ty + (map-new a))) + `(let [tbl (~cn a)] + (expect c tok-set-open) + (while (and (ok? c) (not (at-byte? c \}))) + (put tbl ~read1 true)) + (expect c tok-map-close) + tbl)))))) + +;; One element of a set. The scalars that are map keys pass; a vector becomes a +;; fixed array, which is one where a Vec is not; anything else is refused here +;; rather than at the `(Map ...)` the caller would build out of it, because a +;; map-key refusal names a type nobody wrote. +(defn derive-key [c (Ptr Cursor) name string src [u8]] Derived + (when (at-byte? c \[) + (return (derive-array c name src))) + (let [d (derive c name src)] + (when (bad? d) + (return d)) + (when (not (key-type? (.ty d))) + (return (derived-bad + (joined3 "a set of " (render (.ty d)) + " is not something this builds: a set becomes a (Map T bool), so its elements are map keys. Integers, booleans, strings and vectors of those are")))) + d)) + +;; A vector in key position. Its length is part of its type, so every element +;; of the set has to be the same length as well as the same shape — which falls +;; out of the type comparison the caller already makes, since the length is in +;; the type it compares. +(defn derive-array [c (Ptr Cursor) name string src [u8]] Derived + (let [open (next c)] + (when (at-byte? c \]) + (return (derived-bad + (joined3 "the empty vector at " (where src (.pos open)) + " is inside a set, and an empty fixed array has no element type and no length")))) + (let [head (derive c (joined name "-item") src)] + (when (bad? head) + (return head)) + (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 (disagreement "vector inside a set" src + (.pos open) n + (.ty head) (.ty item))))) + (set n (+ n 1)))) + (expect c tok-vec-close) + (when (not (key-type? (.ty head))) + (return (derived-bad + (joined3 "a set of vectors of " (render (.ty head)) + " is not something this builds: the vector becomes a fixed array, which is a map key only when its elements are compared bytewise")))) + (let [elem (.ty head) + read1 (.reader head) + count (Form.Int {.i n})] + (ok-derived `[~count ~elem] (.decls head) + `(let [arr (array ~count ~elem) + i 0] + (expect c tok-vec-open) + (while (and (ok? c) (not (at-byte? c \])) (< i ~count)) + (set (at arr i) ~read1) + (set i (+ i 1))) + (expect c tok-vec-close) + arr))))))) + +(defn disagreement [what string src [u8] at-pos i32 n i64 + first Form second Form] string + (joined3 (joined3 "the " what " at ") + (where src at-pos) + (joined3 (joined3 " holds more than one shape: its first element is " + (render first) " and element ") + (i64->string n) + (joined3 " is " (render second) + ". Every element has to be the same shape, because the type this becomes has one element type")))) + +;; ── A map, which is a struct ──────────────────────────────────────── +;; +;; The declaration and the reader together, because the fields decide both and +;; walking twice would mean tokenizing twice. +;; +;; The reader's shape is the hand-written one in test/programs/edn.flan, which +;; was written to show what a generated one would look like: open the map, loop +;; on the keys, dispatch each onto its field, and finish. What it does +;; differently is the two arms a hand-written reader had no reason to have — a +;; key that is not a field of the struct, and a field the file did not have. +;; Both signal SchemaDrift. See the note over that type. +(defn derive-map [c (Ptr Cursor) name string at-pos i32 src [u8]] Derived + (when (at-byte? c \}) + (return (derived-bad + (joined3 "the empty map at " (where src at-pos) + " has no keys 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 map 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-keyword) + (return (derived-bad + (joined3 (joined3 "the map at " (where src at-pos) " has a key at ") + (where src (.pos k)) + " that is not a keyword. A struct's fields are named, so every key of a map defedn reads has to be one — :name, not \"name\" and not 1")))) + (let [fname (copy-text (.text k)) + 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 `(keyword=? k ~lit)) + (push clauses `(do (set (~dot out) ~read1) + (set seen (bit-or seen ~bit)))) + ;; Checked at the closing brace rather than tracked by name: the + ;; bit is decided here, where the field is, 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 k)}))))) + (set idx (+ idx 1))))) + (expect c tok-map-close) + ;; An unknown key. The hand-written reader skips one, which is right when a + ;; person wrote the reader and knows what else is in the file. Here the + ;; struct *is* the file, so a key that is not a field is the file having + ;; moved: it is 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 (copy-text (.text k)) + .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-map-open) + (while (ok? c) + (let [k (next c)] + (when (or (not (ok? c)) (= (.kind k) tok-map-close)) + ~@(as-slice missing) + (return out)) + (when (!= (.kind k) tok-keyword) + (fail c err-unexpected-token (.pos k)) + (return out)) + (cond ~@(as-slice clauses)))) + out))] + (push decls struct) + (push decls reader) + (ok-derived sname (as-slice decls) `(~rname c a))))) + +;; ── 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, a number, `(Vec T)`, `(Map K V)` and `[n 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)) + +;; What check.ml takes as a map key, narrowed to what this file can produce. +;; A float is deliberately absent and the checker says why: NaN is not equal to +;; itself, so there is no equality for a map to hash. +(defn key-type? [t Form] bool + (let [s (bytes (render t))] + (or (bytes=? s (bytes "i64")) + (or (bytes=? s (bytes "bool")) + (bytes=? s (bytes "string")))))) + +;; ── The macro ─────────────────────────────────────────────────────── +;; +;; `(edn/defedn Tileset "assets/tileset.edn")`. The path is relative to the +;; file this is written in, exactly as `(embed "assets/tileset.edn")` 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. `C-c C-m` over the call shows all of it, which +;; is the point of generating readable code rather than the smallest code — a +;; provider whose output nobody can look at is a plugin. +(defmacro defedn [args] + (if (!= (len args) 2) + (refuse "defedn is (defedn Name \"path.edn\") — 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 defedn is written in — the same place (embed \"...\") would look"))) + _ (refuse "defedn's first argument is the name of the struct to declare, written as a name")) + _ (refuse "defedn'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 (joined3 path " holds more than one value, and a defedn 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) + ;; The two entry points. Both take the allocator the struct's own + ;; fields are built in, because a string field is a copy and a Vec + ;; field is an allocation — spec-memory's rule, and the reason the + ;; destination is never implicit. + (defn ~bname [b [u8] a Allocator] ~sname + (let [c (cursor b) + out (~rname (addr c) a)] + ;; The cursor is made and dropped here, so this is the only + ;; place that can ask whether the read worked. See ReadFailed. + (when (not (ok? (addr c))) + (signal (ReadFailed {.struct ~(Form.Str {.s name}) + .code (.err c) + .pos (.err-pos c)}))) + out)) + (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 `defedn` 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})))) diff --git a/vendor/json/provide.flan b/vendor/json/provide.flan new file mode 100644 index 0000000..3da211f --- /dev/null +++ b/vendor/json/provide.flan @@ -0,0 +1,464 @@ +;;;; 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]) + +;; And the one a file that does not parse signals. A generated reader +;; accumulates errors on the cursor rather than returning them — which is what +;; lets it be a straight line of assignments — and the cursor is made and +;; dropped inside the entry point, so without this a stray brace in a file read +;; at run time would give the program a zeroed struct and say nothing. The +;; louder failure would have had the quieter answer. `code` is an err-* +;; constant, which `error-message` turns into a sentence. +(defstruct ReadFailed + [struct string + code i32 + 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) + out (~rname (addr c) a)] + ;; The cursor is made and dropped here, so this is the only + ;; place that can ask whether the read worked. See ReadFailed. + (when (not (ok? (addr c))) + (signal (ReadFailed {.struct ~(Form.Str {.s name}) + .code (.err c) + .pos (.err-pos c)}))) + out)) + (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}))))