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

Every tracked Flan file is what the indenter would write, and a with- head indents its body like a definer

Browse Source 
clojure-mode decided each shape. A with- head, and a def or with- head behind a namespace, indents as a body; a qualified head finds its unqualified spec. The rest was hand formatting: cond and match results under their tests, ordinary call arguments under the first one, and lone ; continuation comments rewritten as ;; lines above the code.
This commit is contained in:
Joseph Ferano 2026-09-25 10:19:22 +07:00
parent bf827dc55b
commit ca031d6b38
16 changed files with 391 additions and 322 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
TODO.org
View File

@ -1804,10 +1804,15 @@ pass. Deriving from clojure-mode at runtime stays rejected: it would add an
external dependency to a mode that ships in this repository and needs nothing external dependency to a mode that ships in this repository and needs nothing
beyond stock Emacs, and that community is mid-transition to a tree-sitter mode. beyond stock Emacs, and that community is mid-transition to a tree-sitter mode.
** TODO 373 lines in 20 files still reindent differently ** DONE Every tracked .flan file reindents to itself
Concentrated in four files, untouched by the Emacs pass and untouched before it. CLOSED: [2026-09-25]
The indenter and the hand-formatting there disagree about shapes nothing has clojure-mode decided each shape. The indenter was wrong on one: a =with-= head,
looked at. and a qualified =def…= or =with-= head, now indents as a body, and a qualified
name finds its unqualified part's spec. The rest was hand formatting and was
reindented: a =cond= or =match= result on its own line sits under its test, and
an ordinary call's later arguments align under its first. A lone =;= comment
line goes to =comment-column= in every Lisp mode, so continuation comments are
written as =;;= lines above the code instead.
** DONE C-c C-i inspects the expression at point ** DONE C-c C-i inspects the expression at point
No prompt, because the expression is already written in the buffer. =C-u= opens No prompt, because the expression is already written in the buffer. =C-u= opens

23
emacs/flan-mode.el
View File

@ -585,8 +585,22 @@ Anything not named here that begins with `def' is treated as `:defn' by
`flan-indent-function'; anything else indents as a function call.") `flan-indent-function'; anything else indents as a function call.")
(defun flan--indent-spec (name) (defun flan--indent-spec (name)
"The indent spec for the form called NAME, or nil." "The indent spec for the form called NAME, or nil.
(and name (cdr (assoc name flan-indent-specs)))) A qualified name falls back to its unqualified part, so `rl/when' would find
the entry for `when' — `clojure--get-indent-method' does the same."
(and name
(cdr (or (assoc name flan-indent-specs)
(and (string-match "/\\([^/]+\\)\\'" name)
(assoc (match-string 1 name) flan-indent-specs))))))
(defun flan--definer-p (name)
"Non-nil if NAME indents as a definition or a `with-' form.
Either may be qualified: `rl/with-drawing' is a `with-' form. This is
`clojure-indent-function''s fallback for a head with no spec, regexp and all;
`default…' is excluded there because it is not a definer, and here too."
(and name
(string-match "\\`\\(?:\\S +/\\)?\\(def[a-z]*\\|with-\\)" name)
(not (string-match-p "\\`default" (match-string 1 name)))))
(defconst flan--labelled-forms '("dotimes" "while" "until") (defconst flan--labelled-forms '("dotimes" "while" "until")
"Loops that may carry a label, which `break' and `continue' name. "Loops that may carry a label, which `break' and `continue' name.
@ -755,8 +769,9 @@ decision to `calculate-lisp-indent'."
;; No spec. Anything else spelled `def…' is a definition and indents ;; No spec. Anything else spelled `def…' is a definition and indents
;; like one, which covers `defstruct', `defdata', `defunion', ;; like one, which covers `defstruct', `defdata', `defunion',
;; `defenum', `defonce', `defconst' and `defalias' without naming ;; `defenum', `defonce', `defconst' and `defalias' without naming
;; them. ;; them. A `with-' form is a body too — `rl/with-drawing',
((and name (string-match-p "\\`def" name)) ;; `rl/with-mode-2d camera' — whatever it takes before the body.
((flan--definer-p name)
(+ lisp-body-indent head-column)) (+ lisp-body-indent head-column))
;; A clause: `(name [params] body…)'. `handler-bind', `handler-case' ;; A clause: `(name [params] body…)'. `handler-bind', `handler-case'
;; and `restart-case' all write their clauses this way, and the head is ;; and `restart-case' all write their clauses this way, and the head is

48
emacs/test-flan-mode.el
View File

@ -326,6 +326,54 @@
y 2.0] y 2.0]
(print y))") (print y))")
;; A `with-' form is a body, qualified or not, whatever it takes on the head's
;; line — `clojure-indent-function''s fallback. From `examples/core-2d-camera.flan'.
(test-flan-mode--check
"a qualified with- form indents its body by two past an argument"
"(rl/with-mode-2d camera
(rl/draw-rectangle-rec player rl/red)
(rl/draw-grid 10 1.0))")
(test-flan-mode--check
"a qualified def form indents its body by two"
"(m/defthing name
(body))")
;; A qualified name finds the spec of its unqualified part.
(test-flan-mode--check
"a qualified when keeps when's spec"
"(rl/when (ready?)
(go))")
;; `default…' begins with `def' and is not a definer.
(test-flan-mode--check
"a default-prefixed call aligns its arguments"
"(default-color a
b)")
;; A cond result on its own line sits under its test, not deeper.
(test-flan-mode--check
"a cond result on its own line aligns with its test"
"(cond
(= k 1)
(one)
:else
(other))")
(test-flan-mode--check
"a match result on its own line aligns with its pattern"
"(match v
(Int n) n
(List items)
(length items))")
;; A trailing argument of an ordinary call aligns under the first argument,
;; even when it is long; only a `with-', `def' or specced head gives a body.
(test-flan-mode--check
"an ordinary call's arguments align under the first one"
"(push missing
`(when (ok) (go)))")
;;; Font lock ;;; Font lock

6
examples/textures-image-generation.flan
View File

@ -65,13 +65,13 @@
;; to corner. ;; to corner.
(set (at textures 0) (set (at textures 0)
(upload (rl/gen-image-gradient-linear screen-width screen-height 0 (upload (rl/gen-image-gradient-linear screen-width screen-height 0
rl/red rl/blue))) rl/red rl/blue)))
(set (at textures 1) (set (at textures 1)
(upload (rl/gen-image-gradient-linear screen-width screen-height 90 (upload (rl/gen-image-gradient-linear screen-width screen-height 90
rl/red rl/blue))) rl/red rl/blue)))
(set (at textures 2) (set (at textures 2)
(upload (rl/gen-image-gradient-linear screen-width screen-height 45 (upload (rl/gen-image-gradient-linear screen-width screen-height 45
rl/red rl/blue))) rl/red rl/blue)))
;; density 0 means the falloff reaches the edge of the image. ;; density 0 means the falloff reaches the edge of the image.
(set (at textures 3) (set (at textures 3)
(upload (rl/gen-image-gradient-radial screen-width screen-height 0.0 (upload (rl/gen-image-gradient-radial screen-width screen-height 0.0

4
syntax-sketch.flan
View File

@ -13,8 +13,8 @@
;; Normative references: spec-memory.md (ownership, containers, places, ;; Normative references: spec-memory.md (ownership, containers, places,
;; generics, function values) and spec-conditions.md (restart semantics). ;; generics, function values) and spec-conditions.md (restart semantics).
(import rl "vendor:raylib") ; directory = package, declaration optional; ;; Imports are always qualified: rl/foo.
; imports are always qualified rl/foo (import rl "vendor:raylib") ; directory = package, declaration optional
;; ── Type notation ───────────────────────────────────────────────────── ;; ── Type notation ─────────────────────────────────────────────────────
;; [4 f32] fixed array — a value, copies on assignment ;; [4 f32] fixed array — a value, copies on assignment

142
test/programs/arena-region.flan
View File

@ -28,82 +28,82 @@
(let [which (if (> (length args) 1) (i32 (bytes->i64 (bytes-view (at args 1)))) 0)] (let [which (if (> (length args) 1) (i32 (bytes->i64 (bytes-view (at args 1)))) 0)]
(cond (cond
(= which 1) (= which 1)
;; The refusal. The context here is the heap, which can free one ;; The refusal. The context here is the heap, which can free one
;; block, and a (Vec Value) against it is a free that would release ;; block, and a (Vec Value) against it is a free that would release
;; the slots and strand every inner Vec — so the construction dies ;; the slots and strand every inner Vec — so the construction dies
;; rather than the free three hundred lines later. ;; rather than the free three hundred lines later.
(let [bad (vec-new Value)] (let [bad (vec-new Value)]
(println (length bad))) (println (length bad)))
(= which 2) (= which 2)
;; Use after free-all, which is a different mechanism and worth ;; Use after free-all, which is a different mechanism and worth
;; pinning separately: the allocator's epoch moves on every free-all ;; pinning separately: the allocator's epoch moves on every free-all
;; and every container records the epoch it was made at. The header ;; and every container records the epoch it was made at. The header
;; below was copied *out* of the arena container into a local before ;; below was copied *out* of the arena container into a local before
;; the release, which is the case the check has to cover and the ;; the release, which is the case the check has to cover and the
;; reason spec-memory.md makes an Allocator a pointer rather than a ;; reason spec-memory.md makes an Allocator a pointer rather than a
;; copied value — a copied allocator would carry its own epoch and ;; copied value — a copied allocator would carry its own epoch and
;; the copy would never notice. ;; the copy would never notice.
(let [outer (vec-new Value frame)] (let [outer (vec-new Value frame)]
(let [inner (vec-new Value frame)] (let [inner (vec-new Value frame)]
(push inner (Value.Int {.n (i64 7)})) (push inner (Value.Int {.n (i64 7)}))
(push outer (Value.List {.items inner}))) (push outer (Value.List {.items inner})))
(match (at outer 0) (match (at outer 0)
(List items) (List items)
(do (println (length items)) (do (println (length items))
(free-all frame) (free-all frame)
(println (length items))) (println (length items)))
_ (println 0))) _ (println 0)))
(= which 3) (= which 3)
;; ZII, which is the hole a guard only at the construction would have ;; ZII, which is the hole a guard only at the construction would have
;; left. The items field is omitted from the literal, so it is a zeroed ;; left. The items field is omitted from the literal, so it is a zeroed
;; Vec with no allocator at all — it never went near (vec-new) — and ;; Vec with no allocator at all — it never went near (vec-new) — and
;; the first push is what adopts the context. So the branch is emitted ;; the first push is what adopts the context. So the branch is emitted
;; at every growth too, and there it asks the container, which answers ;; at every growth too, and there it asks the container, which answers
;; from the allocator it will adopt when it has none of its own. ;; from the allocator it will adopt when it has none of its own.
(let [v (Value.List {})] (let [v (Value.List {})]
(match v (match v
(List items) (List items)
(do (push items (Value.Int {.n (i64 1)})) (do (push items (Value.Int {.n (i64 1)}))
(println (length items))) (println (length items)))
_ (println 0))) _ (println 0)))
:else :else
(do (do
;; The control, and it is the case the frame tier exists for: a ;; The control, and it is the case the frame tier exists for: a
;; (Vec (Vec i32)) owns storage at two levels and is perfectly happy ;; (Vec (Vec i32)) owns storage at two levels and is perfectly happy
;; in a region, because free-all releases every block the region ;; in a region, because free-all releases every block the region
;; handed out and the inner ones are among them. The rule asks about ;; handed out and the inner ones are among them. The rule asks about
;; the *allocator*, never "does this element own anything", so this ;; the *allocator*, never "does this element own anything", so this
;; must be built without complaint. ;; must be built without complaint.
(with-allocator frame (with-allocator frame
(let [rows (vec-new Row)] (let [rows (vec-new Row)]
(let [row (vec-new i32)] (let [row (vec-new i32)]
(push row 1) (push row 1)
(push row 2) (push row 2)
(push rows row)) (push rows row))
(println (length rows)) (println (length rows))
(println (length (at rows 0))))) (println (length (at rows 0)))))
(free-all frame) (free-all frame)
;; And the same container against the heap dies — asserted from the ;; And the same container against the heap dies — asserted from the
;; other side in run 1 above; here the point is only that the region ;; other side in run 1 above; here the point is only that the region
;; run above got no complaint. ;; run above got no complaint.
(with-allocator frame (with-allocator frame
(let [vs (vec-new Value)] (let [vs (vec-new Value)]
(push vs (Value.Int {.n (i64 41)})) (push vs (Value.Int {.n (i64 41)}))
(println (length vs)))) (println (length vs))))
(free-all frame) (free-all frame)
;; And the zeroed field of run 3, this time in the region: the growth ;; And the zeroed field of run 3, this time in the region: the growth
;; guard has to pass here as surely as it has to fail there, or every ;; guard has to pass here as surely as it has to fail there, or every
;; ZII container in an arena would be unusable. ;; ZII container in an arena would be unusable.
(with-allocator frame (with-allocator frame
(let [v (Value.List {})] (let [v (Value.List {})]
(match v (match v
(List items) (List items)
(do (push items (Value.Int {.n (i64 1)})) (do (push items (Value.Int {.n (i64 1)}))
(println (length items))) (println (length items)))
_ (println 0)))) _ (println 0))))
(free-all frame)))) (free-all frame))))
(arena-destroy frame) (arena-destroy frame)
0) 0)

12
test/programs/arena-value.flan
View File

@ -51,13 +51,13 @@
(match v (match v
(Int n) n (Int n) n
(List items) (List items)
(let [t (i64 0)] (let [t (i64 0)]
(dotimes [i (length items)] (dotimes [i (length items)]
(set t (+ t (total (at items i))))) (set t (+ t (total (at items i)))))
t) t)
(Table entries) (Table entries)
(+ (match (get entries "xs") (Some x) (total x) None (i64 0)) (+ (match (get entries "xs") (Some x) (total x) None (i64 0))
(match (get entries "ys") (Some y) (total y) None (i64 0))) (match (get entries "ys") (Some y) (total y) None (i64 0)))
_ (i64 0))) _ (i64 0)))
(defn build [] i64 (defn build [] i64

9
test/programs/edn.flan
View File

@ -213,8 +213,9 @@
;; ── The refusals, each asserted on its own reason ───────────────── ;; ── The refusals, each asserted on its own reason ─────────────────
(refusal "\"a\\nb\"") ; an escape inside a string (refusal "\"a\\nb\"") ; an escape inside a string
(refusal "\"a\\\"b\"") ; an escaped quote — the case where a wrong ;; An escaped quote is the case where a wrong version returns `a\` and
; version returns `a\` and leaves `b"` behind ;; leaves `b"` behind.
(refusal "\"a\\\"b\"") ; an escaped quote
(refusal "\"unterminated") ; not a refusal, but the other string failure (refusal "\"unterminated") ; not a refusal, but the other string failure
;; A set is read now, so what is left to refuse about one is its balance. A ;; A set is read now, so what is left to refuse about one is its balance. A
;; `#{` that pushed nothing would answer "no error" for both of these. ;; `#{` that pushed nothing would answer "no error" for both of these.
@ -228,8 +229,8 @@
(refusal "\\a") ; a character literal (refusal "\\a") ; a character literal
(refusal "12x") ; starts like a number, is not one (refusal "12x") ; starts like a number, is not one
(refusal "[1 :]") ; a colon with no name (refusal "[1 :]") ; a colon with no name
(refusal "@") ; not the start of any value — and the case a ;; `@` is the case a scan-to-delimiter reads as a one-byte symbol.
; scan-to-delimiter reads as a one-byte symbol (refusal "@") ; not the start of any value
(refusal "`x") ; a Clojure reader macro, not EDN (refusal "`x") ; a Clojure reader macro, not EDN
(refusal "[1 2}") ; the wrong closer (refusal "[1 2}") ; the wrong closer
(refusal "]") ; a closer with nothing open (refusal "]") ; a closer with nothing open

2
test/programs/frame-rollback.flan
View File

@ -154,7 +154,7 @@
(do (update-frame col) (do (update-frame col)
(set frames (+ frames 1))) (set frames (+ frames 1)))
(continue [] (restore) (continue [] (restore)
(set skipped (+ skipped 1))))) (set skipped (+ skipped 1)))))
(defn main [] i32 (defn main [] i32
(set (.brush world) 1) (set (.brush world) 1)

170
test/programs/json.flan
View File

@ -118,41 +118,41 @@
(defn read-value [c (Ptr json/Cursor) t json/Token] Value (defn read-value [c (Ptr json/Cursor) t json/Token] Value
(cond (cond
(= (.kind t) json/tok-bool) (= (.kind t) json/tok-bool)
(Value.Bool {.b (match (json/bool-of t) (Some v) v None false)}) (Value.Bool {.b (match (json/bool-of t) (Some v) v None false)})
(= (.kind t) json/tok-int) (= (.kind t) json/tok-int)
(Value.Int {.n (match (json/int-of t) (Some v) v None (i64 0))}) (Value.Int {.n (match (json/int-of t) (Some v) v None (i64 0))})
(= (.kind t) json/tok-float) (= (.kind t) json/tok-float)
(Value.Float {.x (match (json/float-of t) (Some v) v None 0.0)}) (Value.Float {.x (match (json/float-of t) (Some v) v None 0.0)})
(= (.kind t) json/tok-string) (= (.kind t) json/tok-string)
(Value.Text {.s (match (json/string-of t) (Some s) s None "")}) (Value.Text {.s (match (json/string-of t) (Some s) s None "")})
(= (.kind t) json/tok-array-open) (= (.kind t) json/tok-array-open)
(let [items (vec-new Value) (let [items (vec-new Value)
u (json/next c) u (json/next c)
more (and (json/ok? c) (!= (.kind u) json/tok-array-close))] more (and (json/ok? c) (!= (.kind u) json/tok-array-close))]
(while more (while more
(push items (read-value c u)) (push items (read-value c u))
(let [sep (json/next c)] (let [sep (json/next c)]
(cond (cond
(not (json/ok? c)) (set more false) (not (json/ok? c)) (set more false)
(= (.kind sep) json/tok-array-close) (set more false) (= (.kind sep) json/tok-array-close) (set more false)
(!= (.kind sep) json/tok-comma) (!= (.kind sep) json/tok-comma)
(do (json/fail c json/err-unexpected-token (.pos sep)) (do (json/fail c json/err-unexpected-token (.pos sep))
(set more false)) (set more false))
:else :else
(do (set u (json/next c)) (do (set u (json/next c))
;; A comma and then the closer. Named, because a trailing ;; A comma and then the closer. Named, because a trailing
;; comma is legal JSON5 and a reader that quietly allowed ;; comma is legal JSON5 and a reader that quietly allowed
;; it would be reading a different format than it claims. ;; it would be reading a different format than it claims.
;; ;;
;; The fail is what ends the loop, through the ok? test ;; The fail is what ends the loop, through the ok? test
;; below it and not on its own — so these two are in this ;; below it and not on its own — so these two are in this
;; order on purpose, and swapping them spins. ;; order on purpose, and swapping them spins.
(when (= (.kind u) json/tok-array-close) (when (= (.kind u) json/tok-array-close)
(json/fail c json/err-trailing-comma (.pos u))) (json/fail c json/err-trailing-comma (.pos u)))
(when (not (json/ok? c)) (when (not (json/ok? c))
(set more false)))))) (set more false))))))
(Value.Array {.items items})) (Value.Array {.items items}))
;; An object key is a quoted string and nothing else — an unquoted one was ;; An object key is a quoted string and nothing else — an unquoted one was
;; already refused by the tokenizer as a bare word, so what reaches here is ;; already refused by the tokenizer as a bare word, so what reaches here is
@ -160,41 +160,41 @@
;; same string-of the values use, so the map owns its keys and the source ;; same string-of the values use, so the map owns its keys and the source
;; buffer is not in the picture. ;; buffer is not in the picture.
(= (.kind t) json/tok-object-open) (= (.kind t) json/tok-object-open)
(let [entries (map-new string Value) (let [entries (map-new string Value)
k (json/next c) k (json/next c)
more (and (json/ok? c) (!= (.kind k) json/tok-object-close))] more (and (json/ok? c) (!= (.kind k) json/tok-object-close))]
(while more (while more
(if (!= (.kind k) json/tok-string) (if (!= (.kind k) json/tok-string)
(do (json/fail c json/err-unexpected-token (.pos k)) (do (json/fail c json/err-unexpected-token (.pos k))
(set more false)) (set more false))
(let [key (match (json/string-of k) (Some s) s None "")] (let [key (match (json/string-of k) (Some s) s None "")]
(json/expect c json/tok-colon) (json/expect c json/tok-colon)
(if (not (json/ok? c)) (if (not (json/ok? c))
(set more false) (set more false)
(let [v (json/next c)] (let [v (json/next c)]
(if (not (json/ok? c)) (if (not (json/ok? c))
(set more false) (set more false)
(do (do
(put entries key (read-value c v)) (put entries key (read-value c v))
(let [sep (json/next c)] (let [sep (json/next c)]
(cond (cond
(not (json/ok? c)) (set more false) (not (json/ok? c)) (set more false)
(= (.kind sep) json/tok-object-close) (set more false) (= (.kind sep) json/tok-object-close) (set more false)
(!= (.kind sep) json/tok-comma) (!= (.kind sep) json/tok-comma)
(do (json/fail c json/err-unexpected-token (.pos sep)) (do (json/fail c json/err-unexpected-token (.pos sep))
(set more false)) (set more false))
:else :else
;; Same two steps, same order, same reason as the ;; Same two steps, same order, same reason as the
;; array arm: the fail ends the loop through the ;; array arm: the fail ends the loop through the
;; ok? test under it, and it has to, because the ;; ok? test under it, and it has to, because the
;; next pass would otherwise ask string-of for the ;; next pass would otherwise ask string-of for the
;; text of a closing brace. ;; text of a closing brace.
(do (set k (json/next c)) (do (set k (json/next c))
(when (= (.kind k) json/tok-object-close) (when (= (.kind k) json/tok-object-close)
(json/fail c json/err-trailing-comma (.pos k))) (json/fail c json/err-trailing-comma (.pos k)))
(when (not (json/ok? c)) (when (not (json/ok? c))
(set more false)))))))))))) (set more false))))))))))))
(Value.Object {.entries entries})) (Value.Object {.entries entries}))
:else Value.Null)) :else Value.Null))
@ -204,34 +204,34 @@
(defn count-leaves [v Value] i32 (defn count-leaves [v Value] i32
(match v (match v
(Array items) (Array items)
(let [n 0] (let [n 0]
(dotimes [i (length items)] (dotimes [i (length items)]
(set n (+ n (count-leaves (at items i))))) (set n (+ n (count-leaves (at items i)))))
n) n)
;; map-next fills an out-parameter with a copy of the value's bytes, which ;; map-next fills an out-parameter with a copy of the value's bytes, which
;; for a Value holding a container is a second header over the same block. ;; for a Value holding a container is a second header over the same block.
;; In a region that is an alias and not a second owner, so walking a map is ;; In a region that is an alias and not a second owner, so walking a map is
;; the ordinary iteration and needs no accessor of its own. ;; the ordinary iteration and needs no accessor of its own.
(Object entries) (Object entries)
(let [n 0 (let [n 0
cur (i64 0) cur (i64 0)
k "" k ""
e Value.Null] e Value.Null]
(while (map-next entries (addr cur) (addr k) (addr e)) (while (map-next entries (addr cur) (addr k) (addr e))
(set n (+ n (count-leaves e)))) (set n (+ n (count-leaves e))))
n) n)
_ 1)) _ 1))
(defn sum-ints [v Value] i64 (defn sum-ints [v Value] i64
(match v (match v
(Int n) n (Int n) n
(Array items) (Array items)
(let [t (i64 0)] (let [t (i64 0)]
(dotimes [i (length items)] (dotimes [i (length items)]
(set t (+ t (sum-ints (at items i))))) (set t (+ t (sum-ints (at items i)))))
t) t)
(Object entries) (Object entries)
(match (get entries "xs") (Some x) (sum-ints x) None (i64 0)) (match (get entries "xs") (Some x) (sum-ints x) None (i64 0))
_ (i64 0))) _ (i64 0)))
(defn describe [v Value] string (defn describe [v Value] string
@ -244,9 +244,9 @@
(defn text-at [v Value key string] string (defn text-at [v Value key string] string
(match v (match v
(Object entries) (Object entries)
(match (get entries key) (match (get entries key)
(Some x) (match x (Text s) s _ "<not a string>") (Some x) (match x (Text s) s _ "<not a string>")
None "<missing>") None "<missing>")
_ "<not an object>")) _ "<not an object>"))
(defn read-doc [src [u8]] Value (defn read-doc [src [u8]] Value
@ -413,7 +413,7 @@
(println (sum-ints v)) ; [1 2 3] (println (sum-ints v)) ; [1 2 3]
(println (describe (match v (Object e) (match (get e "gravity") (println (describe (match v (Object e) (match (get e "gravity")
(Some g) g None Value.Null) (Some g) g None Value.Null)
_ Value.Null))) _ Value.Null)))
;; The escapes, resolved. The quotes in `name` never existed as bytes ;; The escapes, resolved. The quotes in `name` never existed as bytes
;; in the source; é is two bytes out of six and the emoji is four out ;; in the source; é is two bytes out of six and the emoji is four out
;; of twelve; and the eight one-character escapes are eight bytes. ;; of twelve; and the eight one-character escapes are eight bytes.

8
test/programs/pkgs/tree/tree.flan
View File

@ -25,8 +25,8 @@
(match t (match t
(Leaf n) n (Leaf n) n
(Branch kids) (Branch kids)
(let [s (i64 0)] (let [s (i64 0)]
(dotimes [i (length kids)] (dotimes [i (length kids)]
(set s (+ s (total (at kids i))))) (set s (+ s (total (at kids i)))))
s) s)
Empty (i64 0))) Empty (i64 0)))

6
test/programs/utf8.flan
View File

@ -102,9 +102,9 @@
(show-dec (slice lone-cont 0 1)) ; a continuation byte leading (show-dec (slice lone-cont 0 1)) ; a continuation byte leading
(show-dec (slice overlong2 0 2)) ; overlong "/" (show-dec (slice overlong2 0 2)) ; overlong "/"
(show-dec (slice overlong3 0 3)) ; overlong "/" again, three bytes (show-dec (slice overlong3 0 3)) ; overlong "/" again, three bytes
(show-dec (slice overlong4 0 4)) ; and four. Added after a mutation run: ;; Added after a mutation run: relaxing 0xf0's floor to 0x80 left the
; relaxing 0xf0's floor to 0x80 left the ;; whole suite green without this line.
; whole suite green without this line. (show-dec (slice overlong4 0 4)) ; and four
(show-dec (slice surrogate 0 3)) ; U+D800 (show-dec (slice surrogate 0 3)) ; U+D800
(show-dec (slice above-max 0 4)) ; U+110000 (show-dec (slice above-max 0 4)) ; U+110000
(show-dec (slice lead-f5 0 4)) ; 0xf5 leads nothing (show-dec (slice lead-f5 0 4)) ; 0xf5 leads nothing

112
vendor/edn/provide.flan vendored
View File

@ -216,8 +216,8 @@
(let [t (next c)] (let [t (next c)]
(when (not (ok? c)) (when (not (ok? c))
(return (derived-bad (return (derived-bad
(joined3 "the data file could not be read at " (where src (error-pos c)) (joined3 "the data file could not be read at " (where src (error-pos c))
(joined ": " (error-message (.err c))))))) (joined ": " (error-message (.err c)))))))
(cond (cond
(= (.kind t) tok-int) (ok-derived `i64 (form-nil) `(need-int c)) (= (.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-float) (ok-derived `f64 (form-nil) `(need-float c))
@ -231,12 +231,12 @@
(= (.kind t) tok-nil) (= (.kind t) tok-nil)
(derived-bad (derived-bad
(joined3 "the nil at " (where src (.pos t)) (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")) " 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 :else
(derived-bad (derived-bad
(joined3 "the value at " (where src (.pos t)) (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"))))) " 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 ;; 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 ;; decides; every one after it is compared against that decision and both
@ -245,8 +245,8 @@
(defn- derive-vec [c (Ptr Cursor) name string at-pos i32 src [u8]] Derived (defn- derive-vec [c (Ptr Cursor) name string at-pos i32 src [u8]] Derived
(when (at-byte? c \]) (when (at-byte? c \])
(return (derived-bad (return (derived-bad
(joined3 "the empty vector at " (where src at-pos) (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")))) " 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)] (let [head (derive c (joined name "-item") src)]
(when (bad? head) (when (bad? head)
(return head)) (return head))
@ -266,12 +266,12 @@
cn (Form.Sym {.s (joined name "-new")})] cn (Form.Sym {.s (joined name "-new")})]
(ok-derived ty (with-decl (.decls head) `(defn ~cn [a Allocator] ~ty (ok-derived ty (with-decl (.decls head) `(defn ~cn [a Allocator] ~ty
(vec-new a))) (vec-new a)))
`(let [xs (~cn a)] `(let [xs (~cn a)]
(expect c tok-vec-open) (expect c tok-vec-open)
(while (and (ok? c) (not (at-byte? c \]))) (while (and (ok? c) (not (at-byte? c \])))
(push xs ~read1)) (push xs ~read1))
(expect c tok-vec-close) (expect c tok-vec-close)
xs)))))) xs))))))
;; Why every collection gets a one-line constructor of its own. ;; Why every collection gets a one-line constructor of its own.
;; ;;
@ -294,8 +294,8 @@
(defn- derive-set [c (Ptr Cursor) name string at-pos i32 src [u8]] Derived (defn- derive-set [c (Ptr Cursor) name string at-pos i32 src [u8]] Derived
(when (at-byte? c \}) (when (at-byte? c \})
(return (derived-bad (return (derived-bad
(joined3 "the empty set at " (where src at-pos) (joined3 "the empty set at " (where src at-pos)
" has no element to derive an element type from")))) " has no element to derive an element type from"))))
(let [head (derive-key c (joined name "-key") src)] (let [head (derive-key c (joined name "-key") src)]
(when (bad? head) (when (bad? head)
(return head)) (return head))
@ -315,12 +315,12 @@
cn (Form.Sym {.s (joined name "-new")})] cn (Form.Sym {.s (joined name "-new")})]
(ok-derived ty (with-decl (.decls head) `(defn ~cn [a Allocator] ~ty (ok-derived ty (with-decl (.decls head) `(defn ~cn [a Allocator] ~ty
(map-new a))) (map-new a)))
`(let [tbl (~cn a)] `(let [tbl (~cn a)]
(expect c tok-set-open) (expect c tok-set-open)
(while (and (ok? c) (not (at-byte? c \}))) (while (and (ok? c) (not (at-byte? c \})))
(put tbl ~read1 true)) (put tbl ~read1 true))
(expect c tok-map-close) (expect c tok-map-close)
tbl)))))) tbl))))))
;; One element of a set. The scalars that are map keys pass; a vector becomes a ;; 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 ;; fixed array, which is one where a Vec is not; anything else is refused here
@ -334,8 +334,8 @@
(return d)) (return d))
(when (not (key-type? (.ty d))) (when (not (key-type? (.ty d)))
(return (derived-bad (return (derived-bad
(joined3 "a set of " (render (.ty d)) (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")))) " 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)) d))
;; A vector in key position. Its length is part of its type, so every element ;; A vector in key position. Its length is part of its type, so every element
@ -346,8 +346,8 @@
(let [open (next c)] (let [open (next c)]
(when (at-byte? c \]) (when (at-byte? c \])
(return (derived-bad (return (derived-bad
(joined3 "the empty vector at " (where src (.pos open)) (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")))) " is inside a set, and an empty fixed array has no element type and no length"))))
(let [head (derive c (joined name "-item") src)] (let [head (derive c (joined name "-item") src)]
(when (bad? head) (when (bad? head)
(return head)) (return head))
@ -364,30 +364,30 @@
(expect c tok-vec-close) (expect c tok-vec-close)
(when (not (key-type? (.ty head))) (when (not (key-type? (.ty head)))
(return (derived-bad (return (derived-bad
(joined3 "a set of vectors of " (render (.ty head)) (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")))) " 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) (let [elem (.ty head)
read1 (.reader head) read1 (.reader head)
count (Form.Int {.i n})] count (Form.Int {.i n})]
(ok-derived `[~count ~elem] (.decls head) (ok-derived `[~count ~elem] (.decls head)
`(let [arr (array ~count ~elem) `(let [arr (array ~count ~elem)
i 0] i 0]
(expect c tok-vec-open) (expect c tok-vec-open)
(while (and (ok? c) (not (at-byte? c \])) (< i ~count)) (while (and (ok? c) (not (at-byte? c \])) (< i ~count))
(set (at arr i) ~read1) (set (at arr i) ~read1)
(set i (+ i 1))) (set i (+ i 1)))
(expect c tok-vec-close) (expect c tok-vec-close)
arr))))))) arr)))))))
(defn- disagreement [what string src [u8] at-pos i32 n i64 (defn- disagreement [what string src [u8] at-pos i32 n i64
first Form second Form] string first Form second Form] string
(joined3 (joined3 "the " what " at ") (joined3 (joined3 "the " what " at ")
(where src at-pos) (where src at-pos)
(joined3 (joined3 " holds more than one shape: its first element is " (joined3 (joined3 " holds more than one shape: its first element is "
(render first) " and element ") (render first) " and element ")
(i64->string n) (i64->string n)
(joined3 " is " (render second) (joined3 " is " (render second)
". Every element has to be the same shape, because the type this becomes has one element type")))) ". Every element has to be the same shape, because the type this becomes has one element type"))))
;; ── A map, which is a struct ──────────────────────────────────────── ;; ── A map, which is a struct ────────────────────────────────────────
;; ;;
@ -403,8 +403,8 @@
(defn- derive-map [c (Ptr Cursor) name string at-pos i32 src [u8]] Derived (defn- derive-map [c (Ptr Cursor) name string at-pos i32 src [u8]] Derived
(when (at-byte? c \}) (when (at-byte? c \})
(return (derived-bad (return (derived-bad
(joined3 "the empty map at " (where src at-pos) (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")))) " 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 (let [fields (vec-new Form) ; the defstruct's [name type ...] vector
clauses (vec-new Form) ; the reader's cond: test, body, test, body clauses (vec-new Form) ; the reader's cond: test, body, test, body
missing (vec-new Form) ; one per field, checked when the map closes missing (vec-new Form) ; one per field, checked when the map closes
@ -414,14 +414,14 @@
(let [k (next c)] (let [k (next c)]
(when (not (ok? c)) (when (not (ok? c))
(return (derived-bad (return (derived-bad
(joined3 "the data file could not be read at " (joined3 "the data file could not be read at "
(where src (error-pos c)) (where src (error-pos c))
(joined ": " (error-message (.err c))))))) (joined ": " (error-message (.err c)))))))
(when (!= (.kind k) tok-keyword) (when (!= (.kind k) tok-keyword)
(return (derived-bad (return (derived-bad
(joined3 (joined3 "the map at " (where src at-pos) " has a key at ") (joined3 (joined3 "the map at " (where src at-pos) " has a key at ")
(where src (.pos k)) (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")))) " 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)) (let [fname (copy-text (.text k))
d (derive c (joined3 name "-" fname) src)] d (derive c (joined3 name "-" fname) src)]
(when (bad? d) (when (bad? d)
@ -441,11 +441,11 @@
;; bit is decided here, where the field is, so the two cannot fall ;; bit is decided here, where the field is, so the two cannot fall
;; out of step the way a parallel list of names would. ;; out of step the way a parallel list of names would.
(push missing (push missing
`(when (= (bit-and seen ~bit) 0) `(when (= (bit-and seen ~bit) 0)
(signal (SchemaDrift {.field ~lit (signal (SchemaDrift {.field ~lit
.struct ~(Form.Str {.s name}) .struct ~(Form.Str {.s name})
.extra? false .extra? false
.pos (.pos k)}))))) .pos (.pos k)})))))
(set idx (+ idx 1))))) (set idx (+ idx 1)))))
(expect c tok-map-close) (expect c tok-map-close)
;; An unknown key. The hand-written reader skips one, which is right when a ;; An unknown key. The hand-written reader skips one, which is right when a
@ -455,12 +455,12 @@
;; handle the condition still reads the rest. ;; handle the condition still reads the rest.
(push clauses `:else) (push clauses `:else)
(push clauses (push clauses
`(do (signal (SchemaDrift {.field (copy-text (.text k)) `(do (signal (SchemaDrift {.field (copy-text (.text k))
.struct ~(Form.Str {.s name}) .struct ~(Form.Str {.s name})
.extra? true .extra? true
.pos (.pos k)})) .pos (.pos k)}))
(when (not (skip-value c)) (when (not (skip-value c))
(return out)))) (return out))))
(let [sname (Form.Sym {.s name}) (let [sname (Form.Sym {.s name})
rname (Form.Sym {.s (joined "read-" name)}) rname (Form.Sym {.s (joined "read-" name)})
struct `(defstruct ~sname ~(Form.Vec {.xs (slice fields)})) struct `(defstruct ~sname ~(Form.Vec {.xs (slice fields)}))
@ -539,7 +539,7 @@
(Some src) (provide name path src) (Some src) (provide name path src)
None (refuse None (refuse
(joined3 "there is no file at " path (joined3 "there is no file at " path
", read relative to the file this defedn is written in — the same place (embed \"...\") would look"))) ", 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 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")))) _ (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"))))

52
vendor/edn/read.flan vendored
View File

@ -93,44 +93,44 @@
(= (.kind t) tok-symbol) (keyword (.text t)) (= (.kind t) tok-symbol) (keyword (.text t))
(= (.kind t) tok-vec-open) (= (.kind t) tok-vec-open)
(let [items (vec-new dyn) (let [items (vec-new dyn)
u (next c)] u (next c)]
(while (and (ok? c) (while (and (ok? c)
(!= (.kind u) tok-vec-close) (!= (.kind u) tok-vec-close)
(!= (.kind u) tok-eof)) (!= (.kind u) tok-eof))
(push items (read-value c u)) (push items (read-value c u))
(set u (next c))) (set u (next c)))
items) items)
;; A set ends on tok-map-close, because `}` is the byte that ends it. The ;; A set ends on tok-map-close, because `}` is the byte that ends it. The
;; dedup is the map's own: put replaces the value of an equal key, so a ;; dedup is the map's own: put replaces the value of an equal key, so a
;; set with a duplicate in it never exists and #{[0 0] [0 0]} is one ;; set with a duplicate in it never exists and #{[0 0] [0 0]} is one
;; element by structure, not by header identity. ;; element by structure, not by header identity.
(= (.kind t) tok-set-open) (= (.kind t) tok-set-open)
(let [s {} (let [s {}
u (next c)] u (next c)]
(while (and (ok? c) (while (and (ok? c)
(!= (.kind u) tok-map-close) (!= (.kind u) tok-map-close)
(!= (.kind u) tok-eof)) (!= (.kind u) tok-eof))
(put s (read-value c u) true) (put s (read-value c u) true)
(set u (next c))) (set u (next c)))
s) s)
;; A map's key is a whole value, read by the same recursion as anything ;; A map's key is a whole value, read by the same recursion as anything
;; else — :a and "a" are two keys, [0 0] can key a map, and the old ;; else — :a and "a" are two keys, [0 0] can key a map, and the old
;; (Map string Value) narrowing that collapsed them is gone with the type ;; (Map string Value) narrowing that collapsed them is gone with the type
;; that forced it. ;; that forced it.
(= (.kind t) tok-map-open) (= (.kind t) tok-map-open)
(let [m {} (let [m {}
k (next c)] k (next c)]
(while (and (ok? c) (while (and (ok? c)
(!= (.kind k) tok-map-close) (!= (.kind k) tok-map-close)
(!= (.kind k) tok-eof)) (!= (.kind k) tok-eof))
(let [key (read-value c k) (let [key (read-value c k)
u (next c)] u (next c)]
(put m key (read-value c u))) (put m key (read-value c u)))
(set k (next c))) (set k (next c)))
m) m)
:else nil)) :else nil))

82
vendor/json/provide.flan vendored
View File

@ -177,8 +177,8 @@
(let [t (next c)] (let [t (next c)]
(when (not (ok? c)) (when (not (ok? c))
(return (derived-bad (return (derived-bad
(joined3 "the data file could not be read at " (where src (error-pos c)) (joined3 "the data file could not be read at " (where src (error-pos c))
(joined ": " (error-message (.err c))))))) (joined ": " (error-message (.err c)))))))
(cond (cond
(= (.kind t) tok-int) (ok-derived `i64 (form-nil) `(need-int c)) (= (.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-float) (ok-derived `f64 (form-nil) `(need-float c))
@ -191,12 +191,12 @@
(= (.kind t) tok-null) (= (.kind t) tok-null)
(derived-bad (derived-bad
(joined3 "the null at " (where src (.pos t)) (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")) " 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 :else
(derived-bad (derived-bad
(joined3 "the value at " (where src (.pos t)) (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"))))) " 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; ;; 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 ;; every one after it is compared against that, and both positions are named
@ -205,8 +205,8 @@
(defn- derive-array [c (Ptr Cursor) name string at-pos i32 src [u8]] Derived (defn- derive-array [c (Ptr Cursor) name string at-pos i32 src [u8]] Derived
(when (at-byte? c \]) (when (at-byte? c \])
(return (derived-bad (return (derived-bad
(joined3 "the empty array at " (where src at-pos) (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")))) " 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)] (let [head (derive c (joined name "-item") src)]
(when (bad? head) (when (bad? head)
(return head)) (return head))
@ -218,12 +218,12 @@
(return item)) (return item))
(when (not (same-type? (.ty head) (.ty item))) (when (not (same-type? (.ty head) (.ty item)))
(return (derived-bad (return (derived-bad
(joined3 (joined3 "the array at " (where src at-pos) (joined3 (joined3 "the array at " (where src at-pos)
" holds more than one shape: element 0 is ") " holds more than one shape: element 0 is ")
(render (.ty head)) (render (.ty head))
(joined3 (joined3 " and element " (i64->string n) " is ") (joined3 (joined3 " and element " (i64->string n) " is ")
(render (.ty item)) (render (.ty item))
". Every element of an array has to be the same shape, because the (Vec T) it becomes has one element type"))))) ". Every element of an array has to be the same shape, because the (Vec T) it becomes has one element type")))))
(comma c) (comma c)
(set n (+ n 1)))) (set n (+ n 1))))
(expect c tok-array-close) (expect c tok-array-close)
@ -238,21 +238,21 @@
;; better for it too. ;; better for it too.
(ok-derived ty (with-decl (.decls head) `(defn ~cn [a Allocator] ~ty (ok-derived ty (with-decl (.decls head) `(defn ~cn [a Allocator] ~ty
(vec-new a))) (vec-new a)))
`(let [xs (~cn a)] `(let [xs (~cn a)]
(expect c tok-array-open) (expect c tok-array-open)
(while (and (ok? c) (not (at-byte? c \]))) (while (and (ok? c) (not (at-byte? c \])))
(push xs ~read1) (push xs ~read1)
(comma c)) (comma c))
(expect c tok-array-close) (expect c tok-array-close)
xs)))))) xs))))))
;; ── An object, which is a struct ──────────────────────────────────── ;; ── An object, which is a struct ────────────────────────────────────
(defn- derive-object [c (Ptr Cursor) name string at-pos i32 src [u8]] Derived (defn- derive-object [c (Ptr Cursor) name string at-pos i32 src [u8]] Derived
(when (at-byte? c \}) (when (at-byte? c \})
(return (derived-bad (return (derived-bad
(joined3 "the empty object at " (where src at-pos) (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")))) " 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 (let [fields (vec-new Form) ; the defstruct's [name type ...] vector
clauses (vec-new Form) ; the reader's cond: test, body, test, body clauses (vec-new Form) ; the reader's cond: test, body, test, body
missing (vec-new Form) ; one per field, checked when the object closes missing (vec-new Form) ; one per field, checked when the object closes
@ -262,12 +262,12 @@
(let [k (next c)] (let [k (next c)]
(when (not (ok? c)) (when (not (ok? c))
(return (derived-bad (return (derived-bad
(joined3 "the data file could not be read at " (where src (error-pos c)) (joined3 "the data file could not be read at " (where src (error-pos c))
(joined ": " (error-message (.err c))))))) (joined ": " (error-message (.err c)))))))
(when (!= (.kind k) tok-string) (when (!= (.kind k) tok-string)
(return (derived-bad (return (derived-bad
(joined3 "the object at " (joined3 (where src at-pos) " has a member at " (where src (.pos k))) (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")))) " whose name is not a string, which JSON requires"))))
;; The comparison in the generated reader is against the token's RAW ;; The comparison in the generated reader is against the token's RAW
;; text, which costs no allocation per key. That is only the same ;; 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 — ;; question as "is this the field" when the name has no escape in it —
@ -277,12 +277,12 @@
(let [raw (.text k)] (let [raw (.text k)]
(when (has-escape? raw) (when (has-escape? raw)
(return (derived-bad (return (derived-bad
(joined3 "the member name at " (where src (.pos k)) (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")))) " 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)) (when (not (name-like? raw))
(return (derived-bad (return (derived-bad
(joined3 "the member name at " (where src (.pos k)) (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")))) " 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) (expect c tok-colon)
(let [fname (copy-of raw) (let [fname (copy-of raw)
d (derive c (joined3 name "-" fname) src)] d (derive c (joined3 name "-" fname) src)]
@ -303,11 +303,11 @@
;; beside the field, so the two cannot fall out of step the way a ;; beside the field, so the two cannot fall out of step the way a
;; parallel list of names would. ;; parallel list of names would.
(push missing (push missing
`(when (= (bit-and seen ~bit) 0) `(when (= (bit-and seen ~bit) 0)
(signal (SchemaDrift {.field ~lit (signal (SchemaDrift {.field ~lit
.struct ~(Form.Str {.s name}) .struct ~(Form.Str {.s name})
.extra? false .extra? false
.pos (.pos close)}))))) .pos (.pos close)})))))
(comma c) (comma c)
(set idx (+ idx 1)))))) (set idx (+ idx 1))))))
(expect c tok-object-close) (expect c tok-object-close)
@ -316,12 +316,12 @@
;; program that declines to handle the condition still reads the rest. ;; program that declines to handle the condition still reads the rest.
(push clauses `:else) (push clauses `:else)
(push clauses (push clauses
`(do (signal (SchemaDrift {.field (match (string-of k) (Some s) s None "") `(do (signal (SchemaDrift {.field (match (string-of k) (Some s) s None "")
.struct ~(Form.Str {.s name}) .struct ~(Form.Str {.s name})
.extra? true .extra? true
.pos (.pos k)})) .pos (.pos k)}))
(when (not (skip-value c)) (when (not (skip-value c))
(return out)))) (return out))))
(let [sname (Form.Sym {.s name}) (let [sname (Form.Sym {.s name})
rname (Form.Sym {.s (joined "read-" name)}) rname (Form.Sym {.s (joined "read-" name)})
struct `(defstruct ~sname ~(Form.Vec {.xs (slice fields)})) struct `(defstruct ~sname ~(Form.Vec {.xs (slice fields)}))
@ -420,7 +420,7 @@
(Some src) (provide name path src) (Some src) (provide name path src)
None (refuse None (refuse
(joined3 "there is no file at " path (joined3 "there is no file at " path
", read relative to the file this defjson is written in — the same place (embed \"...\") would look"))) ", 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 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")))) _ (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"))))

24
vendor/raylib/raylib.flan vendored
View File

@ -551,7 +551,7 @@
"CheckCollisionCircleRec") "CheckCollisionCircleRec")
(declare-c collision-circle-line? [center Vector2 radius f32 (declare-c collision-circle-line? [center Vector2 radius f32
p1 Vector2 p2 Vector2] bool "CheckCollisionCircleLine") p1 Vector2 p2 Vector2] bool "CheckCollisionCircleLine")
(declare-c collision-point-rec? (declare-c collision-point-rec?
[point Vector2 rec Rectangle] bool [point Vector2 rec Rectangle] bool
@ -562,13 +562,13 @@
"CheckCollisionPointCircle") "CheckCollisionPointCircle")
(declare-c collision-point-triangle? [point Vector2 a Vector2 b Vector2 (declare-c collision-point-triangle? [point Vector2 a Vector2 b Vector2
c Vector2] bool "CheckCollisionPointTriangle") c Vector2] bool "CheckCollisionPointTriangle")
;; `threshold` is in pixels, and it is not optional in practice: raylib's test ;; `threshold` is in pixels, and it is not optional in practice: raylib's test
;; is a distance comparison in floats, so a point exactly on the line fails at ;; is a distance comparison in floats, so a point exactly on the line fails at
;; a threshold of 0. 1 is the useful smallest value. ;; a threshold of 0. 1 is the useful smallest value.
(declare-c collision-point-line? [point Vector2 p1 Vector2 p2 Vector2 (declare-c collision-point-line? [point Vector2 p1 Vector2 p2 Vector2
threshold i32] bool "CheckCollisionPointLine") threshold i32] bool "CheckCollisionPointLine")
;; The one binding whose Flan face is not raylib's, and one of only two in ;; The one binding whose Flan face is not raylib's, and one of only two in
;; this file with a hand-written wrapper on top. A Flan slice crosses as ;; this file with a hand-written wrapper on top. A Flan slice crosses as
@ -685,12 +685,12 @@
"DrawTextureV") "DrawTextureV")
(declare-c draw-texture-ex [texture Texture2D position Vector2 rotation f32 (declare-c draw-texture-ex [texture Texture2D position Vector2 rotation f32
scale f32 tint Color] "DrawTextureEx") scale f32 tint Color] "DrawTextureEx")
;; A negative source width or height flips the sprite, which is how a sheet is ;; A negative source width or height flips the sprite, which is how a sheet is
;; drawn facing the other way without a second image. ;; drawn facing the other way without a second image.
(declare-c draw-texture-rec [texture Texture2D source Rectangle position Vector2 (declare-c draw-texture-rec [texture Texture2D source Rectangle position Vector2
tint Color] "DrawTextureRec") tint Color] "DrawTextureRec")
;; The two above, in one call, and the only one of the four that both takes a ;; The two above, in one call, and the only one of the four that both takes a
;; source rectangle and scales: `source` picks a cell out of an atlas, `dest` ;; source rectangle and scales: `source` picks a cell out of an atlas, `dest`
@ -933,10 +933,10 @@
;; Angles are degrees, clockwise from the +x axis, and `segments` is how many ;; Angles are degrees, clockwise from the +x axis, and `segments` is how many
;; straight pieces the arc is made of — 0 lets raylib pick from the radius. ;; straight pieces the arc is made of — 0 lets raylib pick from the radius.
(declare-c draw-ring [center Vector2 inner f32 outer f32 start f32 end f32 (declare-c draw-ring [center Vector2 inner f32 outer f32 start f32 end f32
segments i32 color Color] "DrawRing") segments i32 color Color] "DrawRing")
(declare-c draw-ring-lines [center Vector2 inner f32 outer f32 start f32 end f32 (declare-c draw-ring-lines [center Vector2 inner f32 outer f32 start f32 end f32
segments i32 color Color] "DrawRingLines") segments i32 color Color] "DrawRingLines")
;; Counter-clockwise, and raylib means it: the clockwise winding is culled and ;; Counter-clockwise, and raylib means it: the clockwise winding is culled and
;; draws nothing at all, which looks exactly like a broken binding. ;; draws nothing at all, which looks exactly like a broken binding.
@ -968,15 +968,15 @@
;; `roundness` is 0 to 1 as a fraction of the shorter side, so 0 is a plain ;; `roundness` is 0 to 1 as a fraction of the shorter side, so 0 is a plain
;; rectangle and 1 is a stadium. ;; rectangle and 1 is a stadium.
(declare-c draw-rectangle-rounded [rec Rectangle roundness f32 segments i32 (declare-c draw-rectangle-rounded [rec Rectangle roundness f32 segments i32
color Color] "DrawRectangleRounded") color Color] "DrawRectangleRounded")
;; No thickness here — see the section note. The `-ex` form below is the one ;; No thickness here — see the section note. The `-ex` form below is the one
;; that takes it. ;; that takes it.
(declare-c draw-rectangle-rounded-lines [rec Rectangle roundness f32 segments i32 (declare-c draw-rectangle-rounded-lines [rec Rectangle roundness f32 segments i32
color Color] "DrawRectangleRoundedLines") color Color] "DrawRectangleRoundedLines")
(declare-c draw-rectangle-rounded-lines-ex [rec Rectangle roundness f32 (declare-c draw-rectangle-rounded-lines-ex [rec Rectangle roundness f32
segments i32 thick f32 color Color] "DrawRectangleRoundedLinesEx") segments i32 thick f32 color Color] "DrawRectangleRoundedLinesEx")
;; ── A slice where raylib wants a pointer and a count ───────────────── ;; ── A slice where raylib wants a pointer and a count ─────────────────
;; ;;
@ -1524,7 +1524,7 @@
;; so a one-character string is unaffected by it. raylib's own DrawTextEx adds ;; so a one-character string is unaffected by it. raylib's own DrawTextEx adds
;; it the same way measure-text-ex counts it, which is why the two agree. ;; it the same way measure-text-ex counts it, which is why the two agree.
(declare-c draw-text-ex [font Font text string position Vector2 (declare-c draw-text-ex [font Font text string position Vector2
font-size f32 spacing f32 tint Color] "DrawTextEx") font-size f32 spacing f32 tint Color] "DrawTextEx")
;; Pure arithmetic over the font — no GL, no window — and therefore the one ;; Pure arithmetic over the font — no GL, no window — and therefore the one
;; thing in this section the acceptance table can assert. See the note above: ;; thing in this section the acceptance table can assert. See the note above:
@ -1568,7 +1568,7 @@
"GetGlyphAtlasRec") "GetGlyphAtlasRec")
(declare-c draw-text-codepoint [font Font codepoint i32 position Vector2 (declare-c draw-text-codepoint [font Font codepoint i32 position Vector2
font-size f32 tint Color] "DrawTextCodepoint") font-size f32 tint Color] "DrawTextCodepoint")
;; DrawTextCodepoints and LoadFontData are not bound. The first is the slice ;; DrawTextCodepoints and LoadFontData are not bound. The first is the slice
;; problem again and adds nothing draw-text-ex does not already do from a ;; problem again and adds nothing draw-text-ex does not already do from a