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
beyond stock Emacs, and that community is mid-transition to a tree-sitter mode.
** TODO 373 lines in 20 files still reindent differently
Concentrated in four files, untouched by the Emacs pass and untouched before it.
The indenter and the hand-formatting there disagree about shapes nothing has
looked at.
** DONE Every tracked .flan file reindents to itself
CLOSED: [2026-09-25]
clojure-mode decided each shape. The indenter was wrong on one: a =with-= head,
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
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.")
(defun flan--indent-spec (name)
"The indent spec for the form called NAME, or nil."
(and name (cdr (assoc name flan-indent-specs))))
"The indent spec for the form called NAME, or nil.
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")
"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
;; like one, which covers `defstruct', `defdata', `defunion',
;; `defenum', `defonce', `defconst' and `defalias' without naming
;; them.
((and name (string-match-p "\\`def" name))
;; them. A `with-' form is a body too — `rl/with-drawing',
;; `rl/with-mode-2d camera' — whatever it takes before the body.
((flan--definer-p name)
(+ lisp-body-indent head-column))
;; A clause: `(name [params] body…)'. `handler-bind', `handler-case'
;; 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]
(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

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

@ -65,13 +65,13 @@
;; to corner.
(set (at textures 0)
(upload (rl/gen-image-gradient-linear screen-width screen-height 0
rl/red rl/blue)))
rl/red rl/blue)))
(set (at textures 1)
(upload (rl/gen-image-gradient-linear screen-width screen-height 90
rl/red rl/blue)))
rl/red rl/blue)))
(set (at textures 2)
(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.
(set (at textures 3)
(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,
;; 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 ─────────────────────────────────────────────────────
;; [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)]
(cond
(= which 1)
;; 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
;; the slots and strand every inner Vec — so the construction dies
;; rather than the free three hundred lines later.
(let [bad (vec-new Value)]
(println (length bad)))
;; 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
;; the slots and strand every inner Vec — so the construction dies
;; rather than the free three hundred lines later.
(let [bad (vec-new Value)]
(println (length bad)))
(= which 2)
;; Use after free-all, which is a different mechanism and worth
;; pinning separately: the allocator's epoch moves on every free-all
;; and every container records the epoch it was made at. The header
;; 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
;; reason spec-memory.md makes an Allocator a pointer rather than a
;; copied value — a copied allocator would carry its own epoch and
;; the copy would never notice.
(let [outer (vec-new Value frame)]
(let [inner (vec-new Value frame)]
(push inner (Value.Int {.n (i64 7)}))
(push outer (Value.List {.items inner})))
(match (at outer 0)
(List items)
(do (println (length items))
(free-all frame)
(println (length items)))
_ (println 0)))
;; Use after free-all, which is a different mechanism and worth
;; pinning separately: the allocator's epoch moves on every free-all
;; and every container records the epoch it was made at. The header
;; 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
;; reason spec-memory.md makes an Allocator a pointer rather than a
;; copied value — a copied allocator would carry its own epoch and
;; the copy would never notice.
(let [outer (vec-new Value frame)]
(let [inner (vec-new Value frame)]
(push inner (Value.Int {.n (i64 7)}))
(push outer (Value.List {.items inner})))
(match (at outer 0)
(List items)
(do (println (length items))
(free-all frame)
(println (length items)))
_ (println 0)))
(= which 3)
;; 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
;; 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
;; 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.
(let [v (Value.List {})]
(match v
(List items)
(do (push items (Value.Int {.n (i64 1)}))
(println (length items)))
_ (println 0)))
;; 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
;; 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
;; 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.
(let [v (Value.List {})]
(match v
(List items)
(do (push items (Value.Int {.n (i64 1)}))
(println (length items)))
_ (println 0)))
:else
(do
;; 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
;; in a region, because free-all releases every block the region
;; handed out and the inner ones are among them. The rule asks about
;; the *allocator*, never "does this element own anything", so this
;; must be built without complaint.
(with-allocator frame
(let [rows (vec-new Row)]
(let [row (vec-new i32)]
(push row 1)
(push row 2)
(push rows row))
(println (length rows))
(println (length (at rows 0)))))
(free-all frame)
;; 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
;; run above got no complaint.
(with-allocator frame
(let [vs (vec-new Value)]
(push vs (Value.Int {.n (i64 41)}))
(println (length vs))))
(free-all frame)
;; 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
;; ZII container in an arena would be unusable.
(with-allocator frame
(let [v (Value.List {})]
(match v
(List items)
(do (push items (Value.Int {.n (i64 1)}))
(println (length items)))
_ (println 0))))
(free-all frame))))
(do
;; 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
;; in a region, because free-all releases every block the region
;; handed out and the inner ones are among them. The rule asks about
;; the *allocator*, never "does this element own anything", so this
;; must be built without complaint.
(with-allocator frame
(let [rows (vec-new Row)]
(let [row (vec-new i32)]
(push row 1)
(push row 2)
(push rows row))
(println (length rows))
(println (length (at rows 0)))))
(free-all frame)
;; 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
;; run above got no complaint.
(with-allocator frame
(let [vs (vec-new Value)]
(push vs (Value.Int {.n (i64 41)}))
(println (length vs))))
(free-all frame)
;; 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
;; ZII container in an arena would be unusable.
(with-allocator frame
(let [v (Value.List {})]
(match v
(List items)
(do (push items (Value.Int {.n (i64 1)}))
(println (length items)))
_ (println 0))))
(free-all frame))))
(arena-destroy frame)
0)

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

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

9
test/programs/edn.flan
View File

@ -213,8 +213,9 @@
;; ── The refusals, each asserted on its own reason ─────────────────
(refusal "\"a\\nb\"") ; an escape inside a string
(refusal "\"a\\\"b\"") ; an escaped quote — the case where a wrong
; version returns `a\` and leaves `b"` behind
;; An escaped quote is the case where a wrong version returns `a\` and
;; leaves `b"` behind.
(refusal "\"a\\\"b\"") ; an escaped quote
(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
;; `#{` that pushed nothing would answer "no error" for both of these.
@ -228,8 +229,8 @@
(refusal "\\a") ; a character literal
(refusal "12x") ; starts like a number, is not one
(refusal "[1 :]") ; a colon with no name
(refusal "@") ; not the start of any value — and the case a
; scan-to-delimiter reads as a one-byte symbol
;; `@` is the case a 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 "[1 2}") ; the wrong closer
(refusal "]") ; a closer with nothing open

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

@ -154,7 +154,7 @@
(do (update-frame col)
(set frames (+ frames 1)))
(continue [] (restore)
(set skipped (+ skipped 1)))))
(set skipped (+ skipped 1)))))
(defn main [] i32
(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
(cond
(= (.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)
(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)
(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)
(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)
(let [items (vec-new Value)
u (json/next c)
more (and (json/ok? c) (!= (.kind u) json/tok-array-close))]
(while more
(push items (read-value c u))
(let [sep (json/next c)]
(cond
(not (json/ok? c)) (set more false)
(= (.kind sep) json/tok-array-close) (set more false)
(!= (.kind sep) json/tok-comma)
(do (json/fail c json/err-unexpected-token (.pos sep))
(set more false))
:else
(do (set u (json/next c))
;; A comma and then the closer. Named, because a trailing
;; comma is legal JSON5 and a reader that quietly allowed
;; it would be reading a different format than it claims.
;;
;; The fail is what ends the loop, through the ok? test
;; below it and not on its own — so these two are in this
;; order on purpose, and swapping them spins.
(when (= (.kind u) json/tok-array-close)
(json/fail c json/err-trailing-comma (.pos u)))
(when (not (json/ok? c))
(set more false))))))
(Value.Array {.items items}))
(let [items (vec-new Value)
u (json/next c)
more (and (json/ok? c) (!= (.kind u) json/tok-array-close))]
(while more
(push items (read-value c u))
(let [sep (json/next c)]
(cond
(not (json/ok? c)) (set more false)
(= (.kind sep) json/tok-array-close) (set more false)
(!= (.kind sep) json/tok-comma)
(do (json/fail c json/err-unexpected-token (.pos sep))
(set more false))
:else
(do (set u (json/next c))
;; A comma and then the closer. Named, because a trailing
;; comma is legal JSON5 and a reader that quietly allowed
;; it would be reading a different format than it claims.
;;
;; The fail is what ends the loop, through the ok? test
;; below it and not on its own — so these two are in this
;; order on purpose, and swapping them spins.
(when (= (.kind u) json/tok-array-close)
(json/fail c json/err-trailing-comma (.pos u)))
(when (not (json/ok? c))
(set more false))))))
(Value.Array {.items items}))
;; 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
@ -160,41 +160,41 @@
;; same string-of the values use, so the map owns its keys and the source
;; buffer is not in the picture.
(= (.kind t) json/tok-object-open)
(let [entries (map-new string Value)
k (json/next c)
more (and (json/ok? c) (!= (.kind k) json/tok-object-close))]
(while more
(if (!= (.kind k) json/tok-string)
(do (json/fail c json/err-unexpected-token (.pos k))
(set more false))
(let [key (match (json/string-of k) (Some s) s None "")]
(json/expect c json/tok-colon)
(if (not (json/ok? c))
(set more false)
(let [v (json/next c)]
(if (not (json/ok? c))
(set more false)
(do
(put entries key (read-value c v))
(let [sep (json/next c)]
(cond
(not (json/ok? c)) (set more false)
(= (.kind sep) json/tok-object-close) (set more false)
(!= (.kind sep) json/tok-comma)
(do (json/fail c json/err-unexpected-token (.pos sep))
(set more false))
:else
;; Same two steps, same order, same reason as the
;; array arm: the fail ends the loop through the
;; ok? test under it, and it has to, because the
;; next pass would otherwise ask string-of for the
;; text of a closing brace.
(do (set k (json/next c))
(when (= (.kind k) json/tok-object-close)
(json/fail c json/err-trailing-comma (.pos k)))
(when (not (json/ok? c))
(set more false))))))))))))
(Value.Object {.entries entries}))
(let [entries (map-new string Value)
k (json/next c)
more (and (json/ok? c) (!= (.kind k) json/tok-object-close))]
(while more
(if (!= (.kind k) json/tok-string)
(do (json/fail c json/err-unexpected-token (.pos k))
(set more false))
(let [key (match (json/string-of k) (Some s) s None "")]
(json/expect c json/tok-colon)
(if (not (json/ok? c))
(set more false)
(let [v (json/next c)]
(if (not (json/ok? c))
(set more false)
(do
(put entries key (read-value c v))
(let [sep (json/next c)]
(cond
(not (json/ok? c)) (set more false)
(= (.kind sep) json/tok-object-close) (set more false)
(!= (.kind sep) json/tok-comma)
(do (json/fail c json/err-unexpected-token (.pos sep))
(set more false))
:else
;; Same two steps, same order, same reason as the
;; array arm: the fail ends the loop through the
;; ok? test under it, and it has to, because the
;; next pass would otherwise ask string-of for the
;; text of a closing brace.
(do (set k (json/next c))
(when (= (.kind k) json/tok-object-close)
(json/fail c json/err-trailing-comma (.pos k)))
(when (not (json/ok? c))
(set more false))))))))))))
(Value.Object {.entries entries}))
:else Value.Null))
@ -204,34 +204,34 @@
(defn count-leaves [v Value] i32
(match v
(Array items)
(let [n 0]
(dotimes [i (length items)]
(set n (+ n (count-leaves (at items i)))))
n)
(let [n 0]
(dotimes [i (length items)]
(set n (+ n (count-leaves (at items i)))))
n)
;; 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.
;; 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.
(Object entries)
(let [n 0
cur (i64 0)
k ""
e Value.Null]
(while (map-next entries (addr cur) (addr k) (addr e))
(set n (+ n (count-leaves e))))
n)
(let [n 0
cur (i64 0)
k ""
e Value.Null]
(while (map-next entries (addr cur) (addr k) (addr e))
(set n (+ n (count-leaves e))))
n)
_ 1))
(defn sum-ints [v Value] i64
(match v
(Int n) n
(Array items)
(let [t (i64 0)]
(dotimes [i (length items)]
(set t (+ t (sum-ints (at items i)))))
t)
(let [t (i64 0)]
(dotimes [i (length items)]
(set t (+ t (sum-ints (at items i)))))
t)
(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)))
(defn describe [v Value] string
@ -244,9 +244,9 @@
(defn text-at [v Value key string] string
(match v
(Object entries)
(match (get entries key)
(Some x) (match x (Text s) s _ "<not a string>")
None "<missing>")
(match (get entries key)
(Some x) (match x (Text s) s _ "<not a string>")
None "<missing>")
_ "<not an object>"))
(defn read-doc [src [u8]] Value
@ -413,7 +413,7 @@
(println (sum-ints v)) ; [1 2 3]
(println (describe (match v (Object e) (match (get e "gravity")
(Some g) g None Value.Null)
_ Value.Null)))
_ Value.Null)))
;; 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
;; 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
(Leaf n) n
(Branch kids)
(let [s (i64 0)]
(dotimes [i (length kids)]
(set s (+ s (total (at kids i)))))
s)
(let [s (i64 0)]
(dotimes [i (length kids)]
(set s (+ s (total (at kids i)))))
s)
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 overlong2 0 2)) ; overlong "/"
(show-dec (slice overlong3 0 3)) ; overlong "/" again, three bytes
(show-dec (slice overlong4 0 4)) ; and four. Added after a mutation run:
; relaxing 0xf0's floor to 0x80 left the
; whole suite green without this line.
;; Added after a mutation run: relaxing 0xf0's floor to 0x80 left the
;; 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 above-max 0 4)) ; U+110000
(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)]
(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)))))))
(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))
@ -231,12 +231,12 @@
(= (.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"))
" 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")))))
" 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
@ -245,8 +245,8 @@
(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"))))
(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))
@ -266,12 +266,12 @@
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))))))
`(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.
;;
@ -294,8 +294,8 @@
(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"))))
(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))
@ -315,12 +315,12 @@
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))))))
`(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
@ -334,8 +334,8 @@
(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"))))
(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
@ -346,8 +346,8 @@
(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"))))
(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))
@ -364,30 +364,30 @@
(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"))))
(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)))))))
`(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
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"))))
". Every element has to be the same shape, because the type this becomes has one element type"))))
;; ── A map, which is a struct ────────────────────────────────────────
;;
@ -403,8 +403,8 @@
(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"))))
(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
@ -414,14 +414,14 @@
(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)))))))
(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"))))
(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)
@ -441,11 +441,11 @@
;; 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)})))))
`(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
@ -455,12 +455,12 @@
;; 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))))
`(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 (slice fields)}))
@ -539,7 +539,7 @@
(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")))
", 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"))))

52
vendor/edn/read.flan vendored
View File

@ -93,44 +93,44 @@
(= (.kind t) tok-symbol) (keyword (.text t))
(= (.kind t) tok-vec-open)
(let [items (vec-new dyn)
u (next c)]
(while (and (ok? c)
(!= (.kind u) tok-vec-close)
(!= (.kind u) tok-eof))
(push items (read-value c u))
(set u (next c)))
items)
(let [items (vec-new dyn)
u (next c)]
(while (and (ok? c)
(!= (.kind u) tok-vec-close)
(!= (.kind u) tok-eof))
(push items (read-value c u))
(set u (next c)))
items)
;; 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
;; set with a duplicate in it never exists and #{[0 0] [0 0]} is one
;; element by structure, not by header identity.
(= (.kind t) tok-set-open)
(let [s {}
u (next c)]
(while (and (ok? c)
(!= (.kind u) tok-map-close)
(!= (.kind u) tok-eof))
(put s (read-value c u) true)
(set u (next c)))
s)
(let [s {}
u (next c)]
(while (and (ok? c)
(!= (.kind u) tok-map-close)
(!= (.kind u) tok-eof))
(put s (read-value c u) true)
(set u (next c)))
s)
;; 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
;; (Map string Value) narrowing that collapsed them is gone with the type
;; that forced it.
(= (.kind t) tok-map-open)
(let [m {}
k (next c)]
(while (and (ok? c)
(!= (.kind k) tok-map-close)
(!= (.kind k) tok-eof))
(let [key (read-value c k)
u (next c)]
(put m key (read-value c u)))
(set k (next c)))
m)
(let [m {}
k (next c)]
(while (and (ok? c)
(!= (.kind k) tok-map-close)
(!= (.kind k) tok-eof))
(let [key (read-value c k)
u (next c)]
(put m key (read-value c u)))
(set k (next c)))
m)
:else nil))

82
vendor/json/provide.flan vendored
View File

@ -177,8 +177,8 @@
(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)))))))
(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))
@ -191,12 +191,12 @@
(= (.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"))
" 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")))))
" 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
@ -205,8 +205,8 @@
(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"))))
(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))
@ -218,12 +218,12 @@
(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")))))
(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)
@ -238,21 +238,21 @@
;; 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))))))
`(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"))))
(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
@ -262,12 +262,12 @@
(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)))))))
(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"))))
(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 —
@ -277,12 +277,12 @@
(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"))))
(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"))))
(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)]
@ -303,11 +303,11 @@
;; 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)})))))
`(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)
@ -316,12 +316,12 @@
;; 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))))
`(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 (slice fields)}))
@ -420,7 +420,7 @@
(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")))
", 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"))))

24
vendor/raylib/raylib.flan vendored
View File

@ -551,7 +551,7 @@
"CheckCollisionCircleRec")
(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?
[point Vector2 rec Rectangle] bool
@ -562,13 +562,13 @@
"CheckCollisionPointCircle")
(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
;; 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.
(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
;; this file with a hand-written wrapper on top. A Flan slice crosses as
@ -685,12 +685,12 @@
"DrawTextureV")
(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
;; drawn facing the other way without a second image.
(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
;; 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
;; 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
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
segments i32 color Color] "DrawRingLines")
segments i32 color Color] "DrawRingLines")
;; Counter-clockwise, and raylib means it: the clockwise winding is culled and
;; 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
;; rectangle and 1 is a stadium.
(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
;; that takes it.
(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
segments i32 thick f32 color Color] "DrawRectangleRoundedLinesEx")
segments i32 thick f32 color Color] "DrawRectangleRoundedLinesEx")
;; ── 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
;; 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
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
;; thing in this section the acceptance table can assert. See the note above:
@ -1568,7 +1568,7 @@
"GetGlyphAtlasRec")
(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
;; problem again and adds nothing draw-text-ex does not already do from a