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

.fln has struct, class, method, generic, multi, macro, loop and type headers, one-line structs, and a top-level let is a global

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-26 05:56:48 +07:00
commit 1330f2cbc6
18 changed files with 1045 additions and 157 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
TODO.org
View File

@ -649,27 +649,6 @@ Decided 2026-09-26: a lambda's body follows ~=>~, and ~=>~ is its only spelling
takes an indented block even inside brackets, closing where the brackets close: takes an indented block even inside brackets, closing where the brackets close:
~sort-by(xs, fn(a, b) =>~ plus a block. ~sort-by(xs, fn(a, b) =>~ plus a block.
** NEXT A condition struct with a parent has no sugar
On the author's decision. =defstruct(DiskFull, :parent, IoError, [free i64])= is the fallback, with a
paren field vector. Proposal: =struct DiskFull :parent IoError= plus field lines.
** NEXT A type alias is written type Row = Vec(i32)
Decided 2026-09-26: .fln reads ~type Name = T~ as ~(defalias Name T)~, and the printer
writes it back.
** TODO flan check prints every definition of a file that checks
A clean =flan check= lists the whole prelude (about 170 lines). Clean should print
nothing, or only the file's own definitions behind a flag.
** NEXT Classes and methods have .fln syntax
Decided 2026-09-26: ~class Lambda(param, body, env)~, ~generic describe(v) -> dyn~,
~method describe(f: Lambda)~ plus a block (the class as the parameter's type),
~multi kind(v) -> dyn = type-of(v)~, ~method kind(v) when :int~ plus a block.
** NEXT A top-level let is a global
Decided 2026-09-26: in .fln ~let x = v~ at column 0 reads ~(def x v)~ and replaces
~def~, which is refused with that fix; ~once~ and ~const~ stay.
** NEXT Indices separate like vector elements ** NEXT Indices separate like vector elements
Decided 2026-09-26: ~grid[r c]~ and ~grid[(r + 1) (c - 1)]~ read like a vector's Decided 2026-09-26: ~grid[r c]~ and ~grid[(r + 1) (c - 1)]~ read like a vector's
space-separated single values; commas always work; an index with a bare operator space-separated single values; commas always work; an index with a bare operator
@ -680,18 +659,6 @@ Decided 2026-09-26: lines indented under a ~let~ that are ~name = v~ or ~name: T
more bindings of the same let; anything else there stays refused. flan convert writes more bindings of the same let; anything else there stays refused. flan convert writes
consecutive lets this way. consecutive lets this way.
** NEXT A struct fits on one line
Decided 2026-09-26: ~struct Pt(x: i32, y: i32)~ beside the block form, like a data
case; union and a struct with a parent too.
** NEXT defmacro has no sugar
On the author's decision. =defmacro(repeat, [i n & body]):= with a space-separated parameter vector.
Proposal: =macro repeat(i, n, & body)= plus a block.
** NEXT loop/recur has no sugar
On the author's decision. =loop([x a y b]):=. Proposal: =loop x = a, y = b= plus a block; =recur(...)=
stays a call.
** TODO Hard-coded code in messages is still paren syntax in a .fln file ** TODO Hard-coded code in messages is still paren syntax in a .fln file
Types follow the code's syntax now (=Types.spell=). Hints written into a message's Types follow the code's syntax now (=Types.spell=). Hints written into a message's
text — =(Ptr %s)=, =(clone v)=, =(the T x)= in most of =check.ml= and =parse.ml=, the text — =(Ptr %s)=, =(clone v)=, =(the T x)= in most of =check.ml= and =parse.ml=, the

52
bin/main.ml
View File

@ -226,9 +226,14 @@ let no_gc_flag = "--no-gc"
downstream that it ran. *) downstream that it ran. *)
let warn_memory_flag = "--warn-memory" let warn_memory_flag = "--warn-memory"
(* [flan check --defs]: every definition the checked program holds, prelude
included. Off by default, so a file that checks prints nothing. *)
let defs_flag = "--defs"
let flags = let flags =
[ no_checks_flag; dev_flag; debug_flag; sanitize_flag; two_process_flag; [ no_checks_flag; dev_flag; debug_flag; sanitize_flag; two_process_flag;
x86_flag; llvm_flag; no_annotate_flag; no_gc_flag; warn_memory_flag ] x86_flag; llvm_flag; no_annotate_flag; no_gc_flag; warn_memory_flag;
defs_flag ]
(* The warnings, where errors go. Printed one to a location in the repo's (* The warnings, where errors go. Printed one to a location in the repo's
standard [file:line:col:] shape, with the squiggle [Loc.entry] draws, so standard [file:line:col:] shape, with the squiggle [Loc.entry] draws, so
@ -355,6 +360,7 @@ let () =
files files
| _ :: "check" :: args when List.exists (fun a -> not (is_flag a)) args -> | _ :: "check" :: args when List.exists (fun a -> not (is_flag a)) args ->
let warn_memory = List.mem warn_memory_flag args in let warn_memory = List.mem warn_memory_flag args in
let defs = List.mem defs_flag args in
let files = List.filter (fun a -> not (is_flag a)) args in let files = List.filter (fun a -> not (is_flag a)) args in
List.iter List.iter
(fun path -> (fun path ->
@ -366,26 +372,28 @@ let () =
program that checked, which is what leaves the exit status program that checked, which is what leaves the exit status
alone. *) alone. *)
if warn_memory then print_memory_warnings ~file:path p; if warn_memory then print_memory_warnings ~file:path p;
List.iter if defs then begin
(fun (g : Flan.Tast.global) -> List.iter
Printf.printf "%s %s %s\n" (fun (g : Flan.Tast.global) ->
(* The three defining forms, told apart the way the compiler Printf.printf "%s %s %s\n"
tells them apart: [gconst] is the image, and [grerun] is (* The three defining forms, told apart the way the compiler
what a re-run does to the storage. A listing that called tells them apart: [gconst] is the image, and [grerun] is
both mutable forms one name could not answer the question what a re-run does to the storage. A listing that called
someone runs [flan check] on a dev file to ask. *) both mutable forms one name could not answer the question
(if g.gconst then "defconst" someone runs [flan check] on a dev file to ask. *)
else if g.grerun then "def" else "defonce") (if g.gconst then "defconst"
g.gname (Flan.Types.to_string g.gty)) else if g.grerun then "def" else "defonce")
p.globals; g.gname (Flan.Types.to_string g.gty))
List.iter p.globals;
(fun (f : Flan.Tast.fn) -> List.iter
if not (Flan.Check.internal_name f.name) then (fun (f : Flan.Tast.fn) ->
Printf.printf "defn %s : (Fn [%s] %s) %d slots\n" f.name if not (Flan.Check.internal_name f.name) then
(String.concat " " Printf.printf "defn %s : (Fn [%s] %s) %d slots\n" f.name
(List.map Flan.Types.to_string f.params)) (String.concat " "
(Flan.Types.to_string f.ret) (Array.length f.slots)) (List.map Flan.Types.to_string f.params))
p.fns)) (Flan.Types.to_string f.ret) (Array.length f.slots))
p.fns
end))
files files
(* The generated C, for looking at. A wrong FFI binding is wrong in the (* The generated C, for looking at. A wrong FFI binding is wrong in the
wrapper, and the wrapper is not on disk anywhere — [Build] hands the text wrapper, and the wrapper is not on disk anywhere — [Build] hands the text
@ -982,7 +990,7 @@ let () =
| None -> code)) | None -> code))
| _ -> | _ ->
prerr_endline prerr_endline
"usage: flan (read|parse|check|emit|shim) <file.flan>...\n flan check <file.flan>... [--warn-memory]\n flan emit <file.flan> [--x86] [--dev] [--debug] [--no-bounds-checks]\n\ "usage: flan (read|parse|check|emit|shim) <file.flan>...\n flan check <file.flan>... [--warn-memory] [--defs]\n flan emit <file.flan> [--x86] [--dev] [--debug] [--no-bounds-checks]\n\
\ flan import-c <header.h> [package.flan...] [clang flags...]\n\ \ flan import-c <header.h> [package.flan...] [clang flags...]\n\
\ flan generate-c <package-dir>\n\ \ flan generate-c <package-dir>\n\
\ flan build <file.flan> [-o out] [-O0|-O1|-O2|-O3] \ \ flan build <file.flan> [-o out] [-O0|-O1|-O2|-O3] \

2
emacs/MANUAL.md
View File

@ -1205,7 +1205,7 @@ Use `C-c C-g` if you need frames.
| `M-a` / `M-e` | `(` / `)` | statement: start / end (`)`: start of the next) | | `M-a` / `M-e` | `(` / `)` | statement: start / end (`)`: start of the next) |
| `C-M-u` | same | up to the enclosing bracket, or the line that owns the block | | `C-M-u` | same | up to the enclosing bracket, or the line that owns the block |
| `C-M-f` / `C-M-b` | same | brackets and terms, as everywhere | | `C-M-f` / `C-M-b` | same | brackets and terms, as everywhere |
| `TAB` | same | a line at a valid column stays; an empty or misplaced line goes deepest; each repeat steps out a level. One level deeper only after a line that opens a block: never after a `let`, unless its value goes on under it (`= match x`, `= if c`, a lambda header) | | `TAB` | same | a line at a valid column stays; an empty or misplaced line goes deepest; each repeat steps out a level. One level deeper only after a line that opens a block: never after a `let`, unless its value goes on under it (`= match x`, `= if c`, `= loop i = 0`, a lambda header) |
| `DEL` in indentation | same | drop one level | | `DEL` in indentation | same | drop one level |
| `C-c <` / `C-c >` | `<` / `>` | shift the region's lines a level | | `C-c <` / `C-c >` | `<` / `>` | shift the region's lines a level |
| `M-<up>` / `M-<down>` | same | move the statement past its neighbour | | `M-<up>` / `M-<down>` | same | move the statement past its neighbour |

112
emacs/flan-fln-mode.el
View File

@ -83,8 +83,14 @@ fine here. Brackets and strings are still paired."
(defconst flan-fln--clause-words '("else" "elif" "on" "restart") (defconst flan-fln--clause-words '("else" "elif" "on" "restart")
"Words that start a clause of the statement above, at its column.") "Words that start a clause of the statement above, at its column.")
;; What follows a word that starts a clause or a header: a space and not an
;; assignment, or the end of the line. `on = 2' assigns a variable named on,
;; as `assigns' in lib/indent_reader.ml reads it.
(defconst flan-fln--word-end-re
"\\(?:[ \t]+\\(?:[^-+*/= \t\n]\\|[-+*/]\\(?:[^=]\\|$\\)\\)\\|[ \t]*$\\)")
(defconst flan-fln--clause-re (defconst flan-fln--clause-re
"\\(else\\|elif\\|on\\|restart\\)\\(?:[ \t]\\|$\\)") (concat "\\(else\\|elif\\|on\\|restart\\)" flan-fln--word-end-re))
(defconst flan-fln--clause-headers (defconst flan-fln--clause-headers
'(("else" "if" "elif") ("elif" "if" "elif") '(("else" "if" "elif") ("elif" "if" "elif")
@ -97,7 +103,8 @@ fine here. Brackets and strings are still paired."
'("fn" "fn-" "def" "once" "const" "struct" "union" "data" "enum" "import" '("fn" "fn-" "def" "once" "const" "struct" "union" "data" "enum" "import"
"if" "elif" "else" "while" "until" "for" "match" "let" "return" "break" "if" "elif" "else" "while" "until" "for" "match" "let" "return" "break"
"continue" "defer" "handler-case" "handler-bind" "restart-case" "on" "continue" "defer" "handler-case" "handler-bind" "restart-case" "on"
"restart" "quote")) "restart" "quote" "macro" "loop" "type" "class" "generic" "multi"
"method"))
;; The headers whose block follows on the lines under them. `defer' and ;; The headers whose block follows on the lines under them. `defer' and
;; `quote' open one only when nothing follows them on the line; `fn' does not ;; `quote' open one only when nothing follows them on the line; `fn' does not
@ -106,12 +113,15 @@ fine here. Brackets and strings are still paired."
(defconst flan-fln--opener-words (defconst flan-fln--opener-words
'("fn" "fn-" "struct" "union" "data" "enum" "if" "elif" "else" "while" '("fn" "fn-" "struct" "union" "data" "enum" "if" "elif" "else" "while"
"until" "for" "match" "defer" "handler-case" "handler-bind" "until" "for" "match" "defer" "handler-case" "handler-bind"
"restart-case" "on" "restart" "quote")) "restart-case" "on" "restart" "quote" "macro" "loop" "class" "multi"
"method"))
(defconst flan-fln--declaration-words (defconst flan-fln--declaration-words
'(("fn" . "defn") ("fn-" . "defn-") ("def" . "def") ("once" . "defonce") '(("fn" . "defn") ("fn-" . "defn-") ("def" . "def") ("once" . "defonce")
("const" . "defconst") ("struct" . "defstruct") ("data" . "defdata") ("const" . "defconst") ("struct" . "defstruct") ("data" . "defdata")
("enum" . "defenum") ("union" . "defunion") ("import" . "import")) ("enum" . "defenum") ("union" . "defunion") ("import" . "import")
("let" . "def") ("macro" . "defmacro") ("type" . "defalias") ("class" . "defclass")
("generic" . "defgeneric") ("multi" . "defmulti") ("method" . "defmethod"))
"Each declaration header word, and the paren head it reads as.") "Each declaration header word, and the paren head it reads as.")
;;; Syntax ;;; Syntax
@ -324,15 +334,16 @@ depth, outside strings and comments, or nil."
(defun flan-fln--value-opens-p (l) (defun flan-fln--value-opens-p (l)
"Non-nil if the value the joined line L binds or assigns goes on under it: "Non-nil if the value the joined line L binds or assigns goes on under it:
`= match x', `= if c' with no `then', `= handler-case', `= restart-case', or `= match x', `= if c' with no `then', `= handler-case', `= restart-case',
a lambda header. These are the values lib/indent_reader.ml's `value_line' `= loop i = 0', or a lambda header. These are the values
reads a block for, besides a bare `=' and a call ending in `:'." lib/indent_reader.ml's `value_line' reads a block for, besides a bare `='
and a call ending in `:'."
(let ((v (flan-fln--value-start l)) (let ((v (flan-fln--value-start l))
(end (flan-fln--joined-end l))) (end (flan-fln--joined-end l)))
(and v (< v end) (and v (< v end)
(save-excursion (save-excursion
(goto-char v) (goto-char v)
(or (looking-at "\\(?:match\\|handler-case\\|handler-bind\\|restart-case\\)\\(?:[ \t]\\|$\\)") (or (looking-at "\\(?:match\\|handler-case\\|handler-bind\\|restart-case\\|loop\\)\\(?:[ \t]\\|$\\)")
(and (looking-at "if[ \t]") (not (flan-fln--then l))) (and (looking-at "if[ \t]") (not (flan-fln--then l)))
(flan-fln--lambda-header-p v end)))))) (flan-fln--lambda-header-p v end))))))
@ -602,7 +613,7 @@ the form."
(defun flan-fln--declaration-head-at (pos &optional heads) (defun flan-fln--declaration-head-at (pos &optional heads)
"The paren head of the declaration written at POS, or nil. "The paren head of the declaration written at POS, or nil.
The .fln twin of `flan--declaration-head-at': POS must be at column 0 and not The .fln twin of `flan--declaration-head-at': POS must be at column 0 and not
in a string or comment, and the header word -- `fn', `def', `struct', ... -- in a string or comment, and the header word -- `fn', `let', `struct', ... --
or the fallback call's name, `defmethod(', must read as one of HEADS, or the fallback call's name, `defmethod(', must read as one of HEADS,
`flan--declaration-heads' by default." `flan--declaration-heads' by default."
(save-excursion (save-excursion
@ -924,8 +935,9 @@ before point. With ARG, stop there instead, as \\[flan-eval-last-sexp] does."
"Non-nil if START's statement is a `let'. "Non-nil if START's statement is a `let'.
A let takes no block: lines under it are its value's (`= match x', a lambda A let takes no block: lines under it are its value's (`= match x', a lambda
header), and its name lasts to the end of the block it is in." header), and its name lasts to the end of the block it is in."
(save-excursion (goto-char (flan-fln--first-char start)) (and (> (flan-fln--indent-at start) 0)
(looking-at "let[ \t]"))) (save-excursion (goto-char (flan-fln--first-char start))
(looking-at "let[ \t]"))))
(defun flan-fln--block-rest (start) (defun flan-fln--block-rest (start)
"START's statement and every statement after it in the same block." "START's statement and every statement after it in the same block."
@ -1135,7 +1147,7 @@ Before it at the same level, else out to the line that owns this block."
(goto-char start) (goto-char start)
(back-to-indentation) (back-to-indentation)
(and (looking-at (concat (regexp-opt flan-fln--opener-words t) (and (looking-at (concat (regexp-opt flan-fln--opener-words t)
"\\(?:[ \t]\\|$\\)")) flan-fln--word-end-re))
(let* ((w (match-string-no-properties 1)) (let* ((w (match-string-no-properties 1))
(w-end (match-end 1)) (w-end (match-end 1))
(end (flan-fln--code-end last)) (end (flan-fln--code-end last))
@ -1143,8 +1155,13 @@ Before it at the same level, else out to the line that owns this block."
(cond (cond
;; `else x' after an if's block is the whole else. ;; `else x' after an if's block is the whole else.
((member w '("defer" "quote" "else")) alone) ((member w '("defer" "quote" "else")) alone)
((member w '("fn" "fn-")) ((member w '("fn" "fn-" "multi" "method"))
(not (re-search-forward "[ \t]=[ \t]" end t))) (not (re-search-forward "[ \t]=[ \t]" end t)))
;; `struct Pt(x: i32)' has its fields on the line.
((member w '("struct" "union" "class"))
(not (save-excursion
(goto-char w-end)
(looking-at "[ \t]+[^][ \t\n(){},;\":]+("))))
((member w '("if" "elif")) (not (flan-fln--then start))) ((member w '("if" "elif")) (not (flan-fln--then start)))
(t t))))) (t t)))))
;; `let r = match n', `x = if c', `fn f(x) = match x', a lambda ;; `let r = match n', `x = if c', `fn f(x) = match x', a lambda
@ -1158,7 +1175,7 @@ Before it at the same level, else out to the line that owns this block."
(let ((bol (line-beginning-position))) (let ((bol (line-beginning-position)))
(or (looking-back ":" bol) (or (looking-back ":" bol)
(looking-back "[ \t]->" bol) (looking-back "[ \t]->" bol)
;; `let x =' and `def colors =' with the value as a block, ;; `let x =' and `let colors =' at the top level with the value as a block,
;; which the author's list leaves out and the reader reads. ;; which the author's list leaves out and the reader reads.
(looking-back "[ \t]=" bol)))))) (looking-back "[ \t]=" bol))))))
@ -1524,6 +1541,29 @@ it, so a block pasted at another depth stays one block."
(defconst flan-fln--name-re "\\([^][ \t\n(){},;\":]+\\)" (defconst flan-fln--name-re "\\([^][ \t\n(){},;\":]+\\)"
"A declared name: a run up to a bracket, a space, or the colon of `x: T'.") "A declared name: a run up to a bracket, a space, or the colon of `x: T'.")
;; A defining form written as the fallback call, `defmacro(m, [x]):' or
;; `defmethod(area, point, [p]):'. The heads are `flan-mode''s own, so a
;; head it learns is drawn here too; its name is drawn as the sugar draws the
;; same kind of name.
(defconst flan-fln--fallback-type-heads
(seq-filter (lambda (h) (member h '("defstruct" "defdata" "defunion" "defenum"
"defalias" "defclass")))
flan--definers))
(defconst flan-fln--fallback-variable-heads
(seq-filter (lambda (h) (member h '("def" "defonce" "defconst"))) flan--definers))
(defconst flan-fln--fallback-function-heads
(seq-remove (lambda (h) (or (member h flan-fln--fallback-type-heads)
(member h flan-fln--fallback-variable-heads)
(member h '("defmacro" "import" "package"
"declare" "declare-c"))))
flan--definers)
"The fallback heads that define something called, for imenu.")
(defun flan-fln--fallback-re (heads)
(concat "^" (regexp-opt heads t) "(" flan-fln--name-re))
(defun flan-fln--return-type-matcher (limit) (defun flan-fln--return-type-matcher (limit)
"Find the next return type up to LIMIT: after the `->' of a fn header, a "Find the next return type up to LIMIT: after the `->' of a fn header, a
lambda or a `Fn(...)' type, and not after a match arm's." lambda or a `Fn(...)' type, and not after a match arm's."
@ -1554,13 +1594,36 @@ lambda or a `Fn(...)' type, and not after a match arm's."
(defvar flan-fln-font-lock-keywords (defvar flan-fln-font-lock-keywords
`(;; The header words, at the start of a line and followed by a space or the `(;; The header words, at the start of a line and followed by a space or the
;; end of it: `if(c, a)' is the fallback call and is not a header. ;; end of it: `if(c, a)' is the fallback call and is not a header.
(,(concat "^[ \t]*" (regexp-opt flan-fln--header-words t) "\\(?:[ \t]\\|$\\)") (,(concat "^[ \t]*" (regexp-opt flan-fln--header-words t) flan-fln--word-end-re)
1 font-lock-keyword-face) 1 font-lock-keyword-face)
(,(concat "^\\(fn-?\\)[ \t]+" flan-fln--name-re) (,(concat "^\\(fn-?\\|macro\\|generic\\|multi\\|method\\)[ \t]+" flan-fln--name-re)
2 font-lock-function-name-face) 2 font-lock-function-name-face)
(,(concat "^\\(?:struct\\|data\\|union\\|enum\\)[ \t]+" flan-fln--name-re) (,(concat "^\\(?:struct\\|data\\|union\\|enum\\|type\\|class\\)[ \t]+" flan-fln--name-re)
1 font-lock-type-face) 1 font-lock-type-face)
(,(concat "^\\(?:def\\|once\\|const\\)[ \t]+" flan-fln--name-re) ;; A method's class, `method area(p: point)', and a value after `when'.
(,(concat "^method[ \t]+[^][ \t\n(){},;\":]+([^][ \t\n(){},;\":]+:[ \t]*" flan-fln--name-re)
1 font-lock-type-face)
("^method[ \t].*)[ \t]+\\(when\\)[ \t]" 1 font-lock-keyword-face)
;; An alias's type, `type Row = Vec(i32)'.
(,(concat "^type[ \t]+[^][ \t\n(){},;\":]+[ \t]+=[ \t]+" flan-fln--name-re)
1 font-lock-type-face)
;; A defining form as the fallback call: the head a keyword, its first
;; argument the name it defines.
(,(flan-fln--fallback-re flan-fln--fallback-type-heads)
(1 font-lock-keyword-face) (2 font-lock-type-face))
(,(flan-fln--fallback-re flan-fln--fallback-variable-heads)
(1 font-lock-keyword-face) (2 font-lock-variable-name-face))
(,(flan-fln--fallback-re
(seq-remove (lambda (h) (or (member h flan-fln--fallback-type-heads)
(member h flan-fln--fallback-variable-heads)))
flan--definers))
(1 font-lock-keyword-face) (2 font-lock-function-name-face))
;; A condition's parent, `struct DiskFull :parent IoError'.
(,(concat "^struct[ \t]+[^][ \t\n(){},;\":]+\\(?:([^)\n]*)\\)?[ \t]+:parent[ \t]+"
flan-fln--name-re)
1 font-lock-type-face)
;; A global: a let at column 0 is one.
(,(concat "^\\(?:let\\|once\\|const\\)[ \t]+" flan-fln--name-re)
1 font-lock-variable-name-face) 1 font-lock-variable-name-face)
;; A restart clause's name, `restart retry() "Try again"'. ;; A restart clause's name, `restart retry() "Try again"'.
(,(concat "^[ \t]*restart[ \t]+" flan-fln--name-re) (,(concat "^[ \t]*restart[ \t]+" flan-fln--name-re)
@ -1593,10 +1656,13 @@ lambda or a `Fn(...)' type, and not after a match arm's."
"Font lock for `flan-fln-mode'.") "Font lock for `flan-fln-mode'.")
(defvar flan-fln-imenu-generic-expression (defvar flan-fln-imenu-generic-expression
`(("Functions" ,(concat "^fn-?[ \t]+" flan-fln--name-re) 1) `(("Functions" ,(concat "^\\(?:fn-?\\|generic\\|multi\\|method\\)[ \t]+" flan-fln--name-re) 1)
("Macros" ,(concat "^defmacro(" flan-fln--name-re) 1) ("Functions" ,(flan-fln--fallback-re flan-fln--fallback-function-heads) 2)
("Types" ,(concat "^\\(?:struct\\|data\\|union\\|enum\\)[ \t]+" flan-fln--name-re) 1) ("Macros" ,(concat "^\\(?:macro[ \t]+\\|defmacro(\\)" flan-fln--name-re) 1)
("Variables" ,(concat "^\\(?:def\\|once\\|const\\)[ \t]+" flan-fln--name-re) 1)) ("Types" ,(concat "^\\(?:struct\\|data\\|union\\|enum\\|type\\|class\\)[ \t]+" flan-fln--name-re) 1)
("Types" ,(flan-fln--fallback-re flan-fln--fallback-type-heads) 2)
("Variables" ,(concat "^\\(?:let\\|once\\|const\\)[ \t]+" flan-fln--name-re) 1)
("Variables" ,(flan-fln--fallback-re flan-fln--fallback-variable-heads) 2))
"Imenu index for `flan-fln-mode'.") "Imenu index for `flan-fln-mode'.")
(defun flan-fln-current-defun-name () (defun flan-fln-current-defun-name ()
@ -1605,7 +1671,7 @@ lambda or a `Fn(...)' type, and not after a match arm's."
(when s (when s
(save-excursion (save-excursion
(goto-char s) (goto-char s)
(and (looking-at (concat "\\(?:fn-?\\|def\\|once\\|const\\|struct\\|data\\|union\\|enum\\)[ \t]+" (and (looking-at (concat "\\(?:fn-?\\|macro\\|generic\\|multi\\|method\\|class\\|let\\|once\\|const\\|struct\\|data\\|union\\|enum\\|type\\)[ \t]+"
flan-fln--name-re)) flan-fln--name-re))
(match-string-no-properties 1)))))) (match-string-no-properties 1))))))

93
emacs/test-flan-fln-live.el
View File

@ -85,6 +85,55 @@ fn dir(d: Dir) -> i64
Dir.north -> 7 Dir.north -> 7
_ -> 8 _ -> 8
struct Oops :parent Error
code: i64
type Count = i64
let speed: i64 = 3
fn speed-of() -> i64 = speed
struct Pair(a: i64, b: i64)
fn pair-sum(p: Pair) -> i64 = p.a + p.b
class shape(w, h)
generic area(s) -> dyn
method area(s: shape) = get(s, :w) * get(s, :h)
multi kind(v) -> dyn = type-of(v)
method kind(v) when :int = 1
method kind(v) when :else
0
fn counted(n: Count) -> Count = n + 1
fn oops-code() -> i64
handler-case
error(Oops{.code 7})
on Oops(c)
c.code
macro dbl-of(x, & more)
quote
~x + ~x
fn use-mac(k: i64) -> i64 = dbl-of(k)
fn gcd(a: i64, b: i64) -> i64
loop x = a, y = b
if y == 0 then x else recur(y, x % y)
fn sum-to(n: i64) -> i64
let r = loop i = 0, acc = 0
if i > n then acc else recur(i + 1, acc + i)
r
comment(): comment():
if 1 < 2 and if 1 < 2 and
3 < 4 3 < 4
@ -209,12 +258,48 @@ comment():
("fn size" "(size 20)" "2") ("fn size" "(size 20)" "2")
("fn lam" "(lam 3)" "7") ("fn lam" "(lam 3)" "7")
("fn rs" "(rs)" "3") ("fn rs" "(rs)" "3")
("fn dir" "(dir :north)" "7"))) ("fn dir" "(dir :north)" "7")
("struct Oops" "(oops-code)" "7")
("type Count" "(counted 1)" "2")
("struct Pair" "(pair-sum (Pair {.a 1 .b 2}))" "3")
("fn pair-sum" "(pair-sum (Pair {.a 1 .b 2}))" "3")
("class shape" "(i64 (area (shape 2 3)))" "6")
("generic area" "(i64 (area (shape 2 3)))" "6")
("method area" "(i64 (area (shape 2 3)))" "6")
("multi kind" "(i64 (kind 3))" "1")
("method kind(v) when :else" "(i64 (kind :x))" "0")
("fn counted" "(counted 1)" "2")
("fn oops-code" "(oops-code)" "7")
("macro dbl-of" "(use-mac 5)" "10")
("fn use-mac" "(use-mac 5)" "10")
("fn gcd" "(gcd 1071 462)" "21")
("fn sum-to" "(sum-to 4)" "10")))
(funcall goto needle) (funcall goto needle)
(flan-fln-eval-defun) (flan-fln-eval-defun)
(test-flan--check (funcall name (format "C-c C-c installs %s" needle)) (test-flan--check (funcall name (format "C-c C-c installs %s" needle))
(equal (funcall value call) want))) (equal (funcall value call) want)))
;; A top-level let is a global, installed and re-run by C-c C-c.
(funcall goto "let speed: i64 = 3")
(end-of-line)
(delete-char -1)
(insert "9")
(flan-fln-eval-defun)
(test-flan--check (funcall name "C-c C-c on a top-level let installs the global")
(equal (funcall value "(speed-of)") "9"))
;; A macro changed in the buffer and installed again reaches the
;; function installed after it.
(funcall goto "~x + ~x")
(delete-char 7)
(insert "~x * 3")
(funcall goto "macro dbl-of")
(flan-fln-eval-defun)
(funcall goto "fn use-mac")
(flan-fln-eval-defun)
(test-flan--check (funcall name "C-c C-c on a changed macro takes effect")
(equal (funcall value "(use-mac 5)") "15"))
;; The pause mark. What is sent is a line and column, and the daemon ;; The pause mark. What is sent is a line and column, and the daemon
;; answers `:pause' only when a form the reader made starts exactly ;; answers `:pause' only when a form the reader made starts exactly
;; there (`Ast.mark_pause'). Each kind of target once, and one position ;; there (`Ast.mark_pause'). Each kind of target once, and one position
@ -284,7 +369,11 @@ comment():
("restart retry" "a restart with a report, at its block") ("restart retry" "a restart with a report, at its block")
("Dir.north" "an enum member's arm, at its value") ("Dir.north" "an enum member's arm, at its value")
("let b = 2" "a let the let above takes in, at its value") ("let b = 2" "a let the let above takes in, at its value")
("let c: i64" "a typed one, at its value"))) ("let c: i64" "a typed one, at its value")
("loop x = a" "a loop, at its word")
("if y == 0" "a loop's block")
("let r = loop" "a let-bound loop, at its let")
("if i > n" "a let-bound loop's block")))
(funcall goto (car c)) (funcall goto (car c))
(let ((reply (flan-fln-eval-defun '(4)))) (let ((reply (flan-fln-eval-defun '(4))))
(test-flan--check (funcall name (format "C-u C-c C-c marks %s where the reader starts it" (test-flan--check (funcall name (format "C-u C-c C-c marks %s where the reader starts it"

184
emacs/test-flan-fln.el
View File

@ -203,7 +203,7 @@ fn step() -> ()
(test-flan-fln--is "before any form, the next one" (test-flan-fln--is "before any form, the next one"
(test-flan-fln--thing 'flan-fln-toplevel) "fn f() -> i32 = 1")) (test-flan-fln--thing 'flan-fln-toplevel) "fn f() -> i32 = 1"))
(test-flan-fln--in "def xs = [1 2\n3 4]\n + 1\nfn|x() -> i32 = 1\n" (test-flan-fln--in "let xs = [1 2\n3 4]\n + 1\nfn|x() -> i32 = 1\n"
(test-flan-fln--is "column 0 inside a bracket or after a leading operator is no form start" (test-flan-fln--is "column 0 inside a bracket or after a leading operator is no form start"
(save-excursion (beginning-of-defun) (save-excursion (beginning-of-defun)
(buffer-substring-no-properties (point) (line-end-position))) (buffer-substring-no-properties (point) (line-end-position)))
@ -711,6 +711,103 @@ of its line with AT-END."
(test-flan-fln--is "an enum member as a constant" (funcall face "Dir.north") 'font-lock-constant-face) (test-flan-fln--is "an enum member as a constant" (funcall face "Dir.north") 'font-lock-constant-face)
(test-flan-fln--is "an arm's value is not a type" (funcall face "twice(1)") nil) (test-flan-fln--is "an arm's value is not a type" (funcall face "twice(1)") nil)
(test-flan-fln--is "nor after a pattern with parentheses" (funcall face "r\n") nil))) (test-flan-fln--is "nor after a pattern with parentheses" (funcall face "r\n") nil)))
(test-flan-fln--in "struct DiskFull :parent IoError
free: i64
type Row = Vec(i64)
macro repeat(i, n, & body)
quote
for ~i in range(~n)
~@body
fn gcd(a: i32, b: i32) -> i32
loop x = a, y = b
if y == 0 then x else recur(y, x % y)
"
(font-lock-ensure)
(let ((face (lambda (needle)
(save-excursion (goto-char (point-min)) (search-forward needle)
(get-text-property (match-beginning 0) 'face)))))
(test-flan-fln--is "a struct's parent is a type" (funcall face "IoError") 'font-lock-type-face)
(test-flan-fln--is "and :parent a keyword" (funcall face ":parent") 'font-lock-constant-face)
(test-flan-fln--is "macro is a keyword" (funcall face "macro") 'font-lock-keyword-face)
(test-flan-fln--is "and its name a function's" (funcall face "repeat") 'font-lock-function-name-face)
(test-flan-fln--is "loop is a keyword" (funcall face "loop") 'font-lock-keyword-face)
(test-flan-fln--is "type is a keyword" (funcall face "type") 'font-lock-keyword-face)
(test-flan-fln--is "an alias's name is a type" (funcall face "Row") 'font-lock-type-face)
(test-flan-fln--is "and so is what it names" (funcall face "Vec(i64)") 'font-lock-type-face))
(goto-char (point-min))
(search-forward "Row")
(test-flan-fln--is "an alias installs as a defalias"
(flan-fln--declaration-head-at (line-beginning-position)) "defalias")
(goto-char (point-min))
(search-forward "~@body")
(test-flan-fln--is "a macro is one top-level form"
(test-flan-fln--thing 'flan-fln-toplevel)
"macro repeat(i, n, & body)
quote
for ~i in range(~n)
~@body")
(test-flan-fln--is "installed as a defmacro"
(flan-fln--declaration-head-at (car (flan-fln--toplevel-bounds (point))))
"defmacro")
(search-forward "recur")
(test-flan-fln--is "a loop's statement is its header and block"
(progn (forward-line -1)
(test-flan-fln--thing 'flan-fln-statement))
"loop x = a, y = b
if y == 0 then x else recur(y, x % y)")
(test-flan-fln--is "and its body the block"
(test-flan-fln--thing 'flan-fln-body)
"if y == 0 then x else recur(y, x % y)")
(goto-char (point-min))
(test-flan-fln--is "the struct's head is defstruct"
(flan-fln--declaration-head-at (point)) "defstruct")
(let ((imenu-generic-expression flan-fln-imenu-generic-expression))
(test-flan--check "imenu lists the macro"
(assoc "repeat" (cdr (assoc "Macros" (imenu--generic-function
imenu-generic-expression)))))))
(test-flan-fln--in "defmacro(m, [x]):
quote
~x
defmethod(area, point, [p]):
0
defclass(Shape, [w dyn]):
defstruct(Io, :parent, Error, [])
defconst(k, 3)
"
(font-lock-ensure)
(let ((face (lambda (needle)
(save-excursion (goto-char (point-min)) (search-forward needle)
(get-text-property (match-beginning 0) 'face)))))
(dolist (c '(("defmacro" m font-lock-function-name-face)
("defmethod" area font-lock-function-name-face)
("defclass" Shape font-lock-type-face)
("defstruct" Io font-lock-type-face)
("defconst" k font-lock-variable-name-face)))
(test-flan-fln--is (format "a fallback %s's head is a keyword" (car c))
(funcall face (concat (car c) "(")) 'font-lock-keyword-face)
(test-flan-fln--is (format "and the name it defines, %s" (cadr c))
(save-excursion
(goto-char (point-min))
(search-forward (concat (car c) "("))
(get-text-property (point) 'face))
(nth 2 c))))
(let ((index (imenu--generic-function flan-fln-imenu-generic-expression)))
(test-flan--check "imenu lists a fallback defmacro"
(assoc "m" (cdr (assoc "Macros" index))))
(test-flan--check "a fallback defmethod"
(assoc "area" (cdr (assoc "Functions" index))))
(test-flan--check "a fallback defclass and defstruct"
(and (assoc "Shape" (cdr (assoc "Types" index)))
(assoc "Io" (cdr (assoc "Types" index)))))
(test-flan--check "and a fallback defconst"
(assoc "k" (cdr (assoc "Variables" index))))))
(test-flan-fln--in "fn far(a: i64,\n b: i64) -> Point\n match a\n Some(x) -> Other\n" (test-flan-fln--in "fn far(a: i64,\n b: i64) -> Point\n match a\n Some(x) -> Other\n"
(font-lock-ensure) (font-lock-ensure)
(let ((face (lambda (needle) (let ((face (lambda (needle)
@ -756,7 +853,7 @@ of its line with AT-END."
(test-flan-fln--is "after a trailing colon too" (test-flan-fln--is "after a trailing colon too"
(test-flan-fln--tabs "rl/with-drawing():\n|" 1) 2) (test-flan-fln--tabs "rl/with-drawing():\n|" 1) 2)
(test-flan-fln--is "and after let x =" (test-flan-fln--is "and after let x ="
(test-flan-fln--tabs "def colors =\n|" 1) 2) (test-flan-fln--tabs "let colors =\n|" 1) 2)
(test-flan-fln--is "but not after a one-line fn" (test-flan-fln--is "but not after a one-line fn"
(test-flan-fln--tabs "fn f() -> i32 = 1\n|" 1) 0) (test-flan-fln--tabs "fn f() -> i32 = 1\n|" 1) 0)
(test-flan-fln--is "else goes to its if's column, whatever the depth" (test-flan-fln--is "else goes to its if's column, whatever the depth"
@ -782,11 +879,94 @@ of its line with AT-END."
("let f = fn(a, b)" "a lambda header") ("let f = fn(a, b)" "a lambda header")
("let f = fn(a: i64, b) -> i64" "a typed lambda header") ("let f = fn(a: i64, b) -> i64" "a typed lambda header")
("let f = fn(g: Fn(i64) -> i64) -> Option(i64)" "one with a function type in it") ("let f = fn(g: Fn(i64) -> i64) -> Option(i64)" "one with a function type in it")
("let r = loop i = 0, acc = 1" "a let's loop")
("loop i = 0, acc = 1" "a loop")
("fn(a: i64) -> i64" "a typed lambda as a statement"))) ("fn(a: i64) -> i64" "a typed lambda as a statement")))
(test-flan-fln--is (format "unless its value goes on under it: %s" (cadr c)) (test-flan-fln--is (format "unless its value goes on under it: %s" (cadr c))
(test-flan-fln--tabs (concat "fn f()\n " (car c) "\n|") 1) 4)) (test-flan-fln--tabs (concat "fn f()\n " (car c) "\n|") 1) 4))
(test-flan-fln--is "but not a typed lambda with its body on the line" (test-flan-fln--is "but not a typed lambda with its body on the line"
(test-flan-fln--tabs "fn f()\n let f = fn(a: i64) -> i64 = a\n|" 1) 2) (test-flan-fln--tabs "fn f()\n let f = fn(a: i64) -> i64 = a\n|" 1) 2)
(test-flan-fln--is "a header word being assigned opens nothing"
(test-flan-fln--tabs "fn f()\n for = 1\n|" 1) 2)
(test-flan-fln--in "fn f()\n handler-case\n g()\n on E(c)\n h(c)\n on = 2\n data += 1\n"
(font-lock-ensure)
(goto-char (point-min))
(search-forward "on = 2")
(test-flan--check "nor is a clause word being assigned a clause"
(not (flan-fln--clause-line-p (line-beginning-position))))
(test-flan-fln--is "or drawn as a keyword"
(get-text-property (match-beginning 0) 'face) nil)
(search-forward "data")
(test-flan-fln--is "and a header word assigned is not either"
(get-text-property (match-beginning 0) 'face) nil))
(test-flan-fln--is "a macro opens a block"
(test-flan-fln--tabs "macro repeat(i, n, & body)\n|" 1) 2)
(test-flan-fln--is "and a struct with a parent"
(test-flan-fln--tabs "struct DiskFull :parent IoError\n|" 1) 2)
(test-flan-fln--in "let speed: i64 = 3\n\nfn f()\n let x = 1\n x\n"
(font-lock-ensure)
(test-flan-fln--is "a top-level let's name is a variable's"
(save-excursion (goto-char (point-min)) (search-forward "speed")
(get-text-property (match-beginning 0) 'face))
'font-lock-variable-name-face)
(test-flan-fln--is "and installs as a def" (flan-fln--declaration-head-at (point-min)) "def")
(test-flan--check "imenu lists it"
(assoc "speed" (cdr (assoc "Variables" (imenu--generic-function
flan-fln-imenu-generic-expression)))))
(test-flan--check "it is no local let" (not (flan-fln--let-p (point-min))))
(goto-char (point-min))
(search-forward "let x")
(test-flan--check "one in a fn is" (flan-fln--let-p (line-beginning-position)))
(test-flan-fln--is "and its name is not a global's"
(get-text-property (match-end 0) 'face) nil))
(test-flan-fln--is "a class with a slot per line opens a block"
(test-flan-fln--tabs "class point\n|" 1) 2)
(test-flan-fln--is "not one on one line"
(test-flan-fln--tabs "class point(x, y)\n|" 1) 0)
(test-flan-fln--is "a method opens its block"
(test-flan-fln--tabs "method area(p: point)\n|" 1) 2)
(test-flan-fln--is "but not one with its value on the line"
(test-flan-fln--tabs "method kind(v) when :int = 1\n|" 1) 0)
(test-flan-fln--is "a multi with a block opens it"
(test-flan-fln--tabs "multi kind(v) -> dyn\n|" 1) 2)
(test-flan-fln--is "a generic never does"
(test-flan-fln--tabs "generic area(p) -> dyn\n|" 1) 0)
(test-flan-fln--in "class point(x, y)\n\ngeneric area(p) -> dyn\n\nmethod area(p: point)\n 1\n\nmulti kind(v) -> dyn = type-of(v)\n\nmethod kind(v) when :int = 2\n"
(font-lock-ensure)
(let ((face (lambda (needle)
(save-excursion (goto-char (point-min)) (search-forward needle)
(get-text-property (match-beginning 0) 'face)))))
(test-flan-fln--is "class is a keyword" (funcall face "class") 'font-lock-keyword-face)
(test-flan-fln--is "and its name a type" (funcall face "point(") 'font-lock-type-face)
(test-flan-fln--is "a generic's name is a function's" (funcall face "area(p)") 'font-lock-function-name-face)
(test-flan-fln--is "a method's class is a type" (funcall face "point)") 'font-lock-type-face)
(test-flan-fln--is "a method's when is a keyword" (funcall face "when") 'font-lock-keyword-face))
(let ((index (imenu--generic-function flan-fln-imenu-generic-expression)))
(test-flan--check "imenu lists the class, the generic and the multi"
(and (assoc "point" (cdr (assoc "Types" index)))
(assoc "area" (cdr (assoc "Functions" index)))
(assoc "kind" (cdr (assoc "Functions" index))))))
(goto-char (point-min))
(search-forward "method area")
(test-flan-fln--is "a method installs as a defmethod"
(flan-fln--declaration-head-at (line-beginning-position)) "defmethod"))
(test-flan-fln--is "but not a struct on one line"
(test-flan-fln--tabs "struct Pt(x: i32, y: i32)\n|" 1) 0)
(test-flan-fln--is "nor one with a parent"
(test-flan-fln--tabs "struct D(free: i64) :parent IoError\n|" 1) 0)
(test-flan-fln--in "struct D(free: i64) :parent IoError\n\nunion U(a: i32)\n"
(font-lock-ensure)
(let ((face (lambda (needle)
(save-excursion (goto-char (point-min)) (search-forward needle)
(get-text-property (match-beginning 0) 'face)))))
(test-flan-fln--is "a one-line struct's name is a type" (funcall face "D(") 'font-lock-type-face)
(test-flan-fln--is "its field's type too" (funcall face "i64") 'font-lock-type-face)
(test-flan-fln--is "and its parent" (funcall face "IoError") 'font-lock-type-face)
(test-flan-fln--is "a one-line union's name" (funcall face "U(") 'font-lock-type-face))
(goto-char (point-min))
(test-flan-fln--is "a one-line struct is a top-level form of one line"
(test-flan-fln--thing 'flan-fln-toplevel)
"struct D(free: i64) :parent IoError"))
(test-flan-fln--is "a one-line fn whose value is a match opens it" (test-flan-fln--is "a one-line fn whose value is a match opens it"
(test-flan-fln--tabs "fn f(x) = match x\n|" 1) 2) (test-flan-fln--tabs "fn f(x) = match x\n|" 1) 2)
(test-flan-fln--is "no deeper after a one-line else" (test-flan-fln--is "no deeper after a one-line else"

176
lib/indent_printer.ml
View File

@ -499,10 +499,15 @@ let rec ty (f : Form.t) =
primitive, a capitalised or [$] name, or a bracket. [[x y]] with a primitive, a capitalised or [$] name, or a bracket. [[x y]] with a
lowercase [y] keeps the fallback, because what it means depends on lowercase [y] keeps the fallback, because what it means depends on
whether [y] names a type. *) whether [y] names a type. *)
(* The file's own class names, which are types and lowercase. Set by
[program]. *)
let classes : string list ref = ref []
let type_shaped (f : Form.t) = let type_shaped (f : Form.t) =
match f.v with match f.v with
| Form.Sym t -> | Form.Sym t ->
List.mem t Types.primitive_names || (t <> "" && t.[0] = '$') || R.capitalised t List.mem t Types.primitive_names || (t <> "" && t.[0] = '$') || R.capitalised t
|| List.mem t !classes
| Form.List [] | Form.List ({ v = Form.Sym _; _ } :: _) | Form.Vec _ -> true | Form.List [] | Form.List ({ v = Form.Sym _; _ } :: _) | Form.Vec _ -> true
| _ -> false | _ -> false
@ -544,7 +549,17 @@ let lead_word text =
(* A statement whose text leads with a reserved word, parenthesised. *) (* A statement whose text leads with a reserved word, parenthesised. *)
let guard text = let guard text =
let w, spaced = lead_word text in let w, spaced = lead_word text in
if spaced && List.mem w reserved then paren text else text (* [data = 3]: a name being assigned is read as one, header word or not. *)
let assigned =
let k = String.length w + 1 in
List.exists
(fun op ->
let o = op ^ " " in
String.length text >= k + String.length o
&& String.sub text k (String.length o) = o)
[ "="; "+="; "-="; "*="; "/=" ]
in
if spaced && List.mem w reserved && not assigned then paren text else text
let stmts_of (f : Form.t) = let stmts_of (f : Form.t) =
match f.v with match f.v with
@ -771,6 +786,9 @@ and value_lines n prefix (v : Form.t) =
| _ -> false | _ -> false
in in
if is_do then [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v) if is_do then [ ind n ^ prefix ^ " =" ] @ block (n + 2) (stmts_of v)
else if loop_head v <> None then
let head, body = Option.get (loop_head v) in
[ ind n ^ prefix ^ " = " ^ head ] @ block (n + 2) body
else if n + String.length inline <= width then [ ind n ^ inline ] else if n + String.length inline <= width then [ ind n ^ inline ]
else else
match v.v with match v.v with
@ -789,6 +807,23 @@ and value_lines n prefix (v : Form.t) =
and slot n (f : Form.t) = block n (stmts_of f) and slot n (f : Form.t) = block n (stmts_of f)
(* [(loop [x a y b] body ...)] as the header [loop x = a, y = b] and its
body, when every binding is a plain name. A lambda or one-line if as a
value is parenthesised, so its else cannot run on into the next binding. *)
and loop_head (f : Form.t) =
match f.v with
| Form.List ({ v = Form.Sym "loop"; _ } :: { v = Form.Vec bs; _ } :: (_ :: _ as body)) ->
(match pairs bs with
| Some (_ :: _ as prs)
when List.for_all (fun ((x : Form.t), _) ->
match x.v with Form.Sym x -> def_name x | _ -> false) prs ->
Some
("loop "
^ String.concat ", " (List.map (fun (x, v) -> fst (expr x) ^ " = " ^ at 1 v) prs),
body)
| _ -> None)
| _ -> None
and label_of = function and label_of = function
| ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", rest) | ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", rest)
| rest -> ("", rest) | rest -> ("", rest)
@ -979,9 +1014,12 @@ and sugar n (f : Form.t) : string list option =
| Form.List ({ v = Form.Sym (("def" | "defonce" | "defconst") as d); _ } | Form.List ({ v = Form.Sym (("def" | "defonce" | "defconst") as d); _ }
:: { v = Form.Sym name; _ } :: rest) :: { v = Form.Sym name; _ } :: rest)
when def_name name -> when def_name name ->
let w = match d with "def" -> "def" | "defonce" -> "once" | _ -> "const" in (* A global [def] is a top-level [let]; nested, where a let is local, it
keeps the fallback. *)
let w = match d with "def" -> "let" | "defonce" -> "once" | _ -> "const" in
let pre = i ^ w ^ " " ^ name in let pre = i ^ w ^ " " ^ name in
(match d, rest with (match d, rest with
| "def", _ when n > 0 -> None
| "defconst", [ v ] -> Some (value_lines n (w ^ " " ^ name) v) | "defconst", [ v ] -> Some (value_lines n (w ^ " " ^ name) v)
| "defconst", [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v) | "defconst", [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v)
| "defconst", _ -> None | "defconst", _ -> None
@ -989,14 +1027,64 @@ and sugar n (f : Form.t) : string list option =
| _, [ t ] when type_shaped t -> Some [ pre ^ ": " ^ ty t ] | _, [ t ] when type_shaped t -> Some [ pre ^ ": " ^ ty t ]
| _, [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v) | _, [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v)
| _ -> None) | _ -> None)
| Form.List [ { v = Form.Sym (("defstruct" | "defunion") as d); _ }; | Form.List ({ v = Form.Sym "loop"; _ } :: _) when loop_head f <> None ->
{ v = Form.Sym name; _ }; { v = Form.Vec fs; _ } ] let head, body = Option.get (loop_head f) in
Some ((i ^ head) :: block (n + 2) body)
| Form.List ({ v = Form.Sym "defmacro"; _ } :: { v = Form.Sym name; _ }
:: { v = Form.Vec ps; _ } :: (_ :: _ as body))
when def_name name -> when def_name name ->
(* A parameter is a name, a destructuring vector, or & and the rest's
name, last. *)
let rec go = function
| [] -> Some []
| [ { Form.v = Form.Sym "&"; _ }; { Form.v = Form.Sym r; _ } ] when def_name r ->
Some [ "& " ^ r ]
| { Form.v = Form.Sym x; _ } :: rest when def_name x && x <> "&" ->
Option.map (fun r -> x :: r) (go rest)
| ({ Form.v = Form.Vec _; _ } as v) :: rest ->
Option.map (fun r -> fst (expr v) :: r) (go rest)
| _ -> None
in
Option.map
(fun pt ->
(i ^ "macro " ^ name ^ "(" ^ String.concat ", " pt ^ ")") :: block (n + 2) body)
(go ps)
| Form.List ({ v = Form.Sym (("defstruct" | "defunion") as d); _ }
:: { v = Form.Sym name; _ } :: rest)
when def_name name
&& (match d, rest with
| _, [ { v = Form.Vec _; _ } ] -> true
(* [(defstruct N :parent P [])] keeps the fallback: no field lines
reads as the form with no vector. *)
| "defstruct", [ { v = Form.Kw "parent"; _ }; { v = Form.Sym pn; _ } ]
| "defstruct", [ { v = Form.Kw "parent"; _ }; { v = Form.Sym pn; _ };
{ v = Form.Vec (_ :: _); _ } ] ->
def_name pn
| _ -> false) ->
let parent, fs =
match rest with
| [ { v = Form.Vec fs; _ } ] -> ("", fs)
| [ _; pf ] -> (" :parent " ^ ty pf, [])
| [ _; pf; { v = Form.Vec fs; _ } ] -> (" :parent " ^ ty pf, fs)
| _ -> assert false
in
(* One line when it fits, [struct Pt(x: i32, y: i32)], and a line per
field otherwise. *)
let one =
match fs, params_text fs with
| _ :: _, Some pt ->
let line =
i ^ (if d = "defstruct" then "struct " else "union ") ^ name ^ "(" ^ pt ^ ")" ^ parent
in
if String.length line <= width && not (!inside f) then Some [ line ] else None
| _ -> None
in
(match pairs fs with (match pairs fs with
| _ when one <> None -> one
| Some prs when List.for_all (fun ((f : Form.t), _) -> | Some prs when List.for_all (fun ((f : Form.t), _) ->
match f.v with Form.Sym x -> def_name x | _ -> false) prs -> match f.v with Form.Sym x -> def_name x | _ -> false) prs ->
Some Some
((i ^ (if d = "defstruct" then "struct " else "union ") ^ name) ((i ^ (if d = "defstruct" then "struct " else "union ") ^ name ^ parent)
:: List.map :: List.map
(fun ((f : Form.t), t) -> (fun ((f : Form.t), t) ->
let fname = fst (expr f) in let fname = fst (expr f) in
@ -1004,6 +1092,58 @@ and sugar n (f : Form.t) : string list option =
(ind (n + 2) ^ if is_sym "dyn" t then fname else fname ^ ": " ^ ty t)) (ind (n + 2) ^ if is_sym "dyn" t then fname else fname ^ ": " ^ ty t))
prs) prs)
| _ -> None) | _ -> None)
| Form.List [ { v = Form.Sym "defclass"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec ss; _ } ]
when def_name name ->
(* A name, and the type after it when the next item is shaped like one:
read back, the slots are the same items in the same order. *)
let rec walk = function
| [] -> Some []
| ({ Form.v = Form.Sym x; _ } as xf) :: t :: rest when def_name x && type_shaped t ->
Option.map (fun r -> (xf, Some t) :: r) (walk rest)
| ({ Form.v = Form.Sym x; _ } as xf) :: rest when def_name x ->
Option.map (fun r -> (xf, None) :: r) (walk rest)
| _ -> None
in
let slots = walk ss in
Option.map
(fun sl ->
let one (x, t) =
fst (expr x) ^ match t with Some t -> ": " ^ ty t | None -> ""
in
let line = i ^ "class " ^ name ^ "(" ^ String.concat ", " (List.map one sl) ^ ")" in
if sl = [] then [ i ^ "class " ^ name ]
else if String.length line <= width && not (!inside f) then [ line ]
else
(i ^ "class " ^ name)
:: List.map (fun ((x : Form.t), t) ->
Source_text.tag x.loc.Loc.line (ind (n + 2) ^ one (x, t))) sl)
slots
| Form.List [ { v = Form.Sym "defgeneric"; _ }; { v = Form.Sym name; _ };
{ v = Form.Vec ps; _ }; r ]
when def_name name && List.for_all sym_param ps && not (is_sym "_" r) ->
Some [ i ^ "generic " ^ name ^ "(" ^ commas ps ^ ") -> " ^ ty r ]
| Form.List ({ v = Form.Sym "defmulti"; _ } :: { v = Form.Sym name; _ }
:: { v = Form.Vec ps; _ } :: r :: (_ :: _ as body))
when def_name name && List.for_all sym_param ps && not (is_sym "_" r) ->
Some (fn_like n f (i ^ "multi " ^ name ^ "(" ^ commas ps ^ ") -> " ^ ty r) body)
| Form.List ({ v = Form.Sym "defmethod"; _ } :: { v = Form.Sym name; _ } :: key
:: { v = Form.Vec ps; _ } :: (_ :: _ as body))
when def_name name && List.for_all sym_param ps ->
(* A class written as the first parameter's type; any other value, and a
class with no parameter to hang it on, after when. *)
let head =
match key.v, ps with
| Form.Sym k, p0 :: rest when k <> "true" && k <> "false" && name_ok k ->
Some ("(" ^ fst (expr p0) ^ ": " ^ ty key
^ String.concat "" (List.map (fun p -> ", " ^ fst (expr p)) rest) ^ ")")
| (Form.Kw _ | Form.Str _ | Form.Int _ | Form.Sym _), _ ->
Some ("(" ^ commas ps ^ ") when " ^ at 9 key)
| _ -> None
in
Option.map (fun h -> fn_like n f (i ^ "method " ^ name ^ h) body) head
| Form.List [ { v = Form.Sym "defalias"; _ }; { v = Form.Sym name; _ }; t ]
when def_name name && type_shaped t ->
Some [ i ^ "type " ^ name ^ " = " ^ ty t ]
| Form.List [ { v = Form.Sym "defdata"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec cs; _ } ] | Form.List [ { v = Form.Sym "defdata"; _ }; { v = Form.Sym name; _ }; { v = Form.Vec cs; _ } ]
when def_name name -> when def_name name ->
let case (c : Form.t) = let case (c : Form.t) =
@ -1044,6 +1184,19 @@ and sugar n (f : Form.t) : string list option =
and is_else (f : Form.t) = match f.v with Form.Kw "else" -> true | _ -> false and is_else (f : Form.t) = match f.v with Form.Kw "else" -> true | _ -> false
(* A header and its body: [head = value] when the body is one value that
fits the line, else the block under it, as a [fn]'s. *)
and fn_like n (f : Form.t) head body =
match body with
| [ x ] when (match x.v with
| Form.List (({ v = Form.Sym h; _ } as hf) :: args) ->
not (List.mem h sugar_heads) && body_split hf args = None
| _ -> true)
&& String.length head + 3 + String.length (at 0 x) <= width
&& not (!inside f) ->
[ head ^ " = " ^ unit_text x ]
| _ -> head :: block (n + 2) body
and handler_clauses n cls = and handler_clauses n cls =
let clause (c : Form.t) = let clause (c : Form.t) =
match c.v with match c.v with
@ -1080,6 +1233,13 @@ and let_lines n prs body =
file's own macros are known and no imported package's. *) file's own macros are known and no imported package's. *)
let program ?source ?macros:m (fs : Form.t list) : string = let program ?source ?macros:m (fs : Form.t list) : string =
macros := (match m with Some m -> m | None -> Body_macros.table fs); macros := (match m with Some m -> m | None -> Body_macros.table fs);
classes :=
List.filter_map
(fun (f : Form.t) ->
match f.v with
| Form.List [ { v = Form.Sym "defclass"; _ }; { v = Form.Sym c; _ }; _ ] -> Some c
| _ -> None)
fs;
spelling := spelling :=
(match source with Some src -> Source_text.spelling src | None -> fun _ -> None); (match source with Some src -> Source_text.spelling src | None -> fun _ -> None);
let cs = match source with Some src -> Source_text.comments src | None -> [] in let cs = match source with Some src -> Source_text.comments src | None -> [] in
@ -1089,8 +1249,8 @@ let program ?source ?macros:m (fs : Form.t list) : string =
(fun (c : Source_text.comment) -> (fun (c : Source_text.comment) ->
f.loc.Loc.line <= c.line && c.line < f.loc.Loc.eline) f.loc.Loc.line <= c.line && c.line < f.loc.Loc.eline)
cs); cs);
(* A flat [let] at the top level would take in the forms after it, so one (* A [let] at the top level is a global, so a local one goes in a [do:]
that is not last goes in a [do:] block. *) block. *)
let top x = let top x =
Hashtbl.reset used; Hashtbl.reset used;
Hashtbl.reset made; Hashtbl.reset made;
@ -1099,7 +1259,6 @@ let program ?source ?macros:m (fs : Form.t list) : string =
in in
let rec go = function let rec go = function
| [] -> [] | [] -> []
| [ x ] -> [ (x, top x) ]
| x :: rest -> (x, top (if let_sugar x then in_do x else x)) :: go rest | x :: rest -> (x, top (if let_sugar x then in_do x else x)) :: go rest
in in
let text = let text =
@ -1108,6 +1267,7 @@ let program ?source ?macros:m (fs : Form.t list) : string =
in in
spelling := (fun _ -> None); spelling := (fun _ -> None);
inside := (fun _ -> false); inside := (fun _ -> false);
classes := [];
(* With the source, its comments go back where they were; without it the (* With the source, its comments go back where they were; without it the
tags come out and nothing goes in. *) tags come out and nothing goes in. *)
Source_text.weave ~starts:(Source_text.form_starts fs) Source_text.weave ~starts:(Source_text.form_starts fs)

313
lib/indent_reader.ml
View File

@ -1048,8 +1048,15 @@ let is_lambda_candidate (e : Form.t) =
List.for_all (fun (a : Form.t) -> match a.v with Form.Sym _ -> true | _ -> false) args List.for_all (fun (a : Form.t) -> match a.v with Form.Sym _ -> true | _ -> false) args
| _ -> false | _ -> false
(* The word at the head of the line is a variable being assigned, [data = 3]
or [on += 1], whatever else it could start. *)
let assigns p =
let n = peek_at p 1 in
n.sp && (match n.tok with NAME x -> x = "=" || List.mem_assoc x assign_ops | _ -> false)
let header_follow p s = let header_follow p s =
let n = peek_at p 1 in let n = peek_at p 1 in
(not (assigns p)) &&
let plain_name = function let plain_name = function
| NAME x -> not (is_op_word x || x = "=" || List.mem_assoc x assign_ops) | NAME x -> not (is_op_word x || x = "=" || List.mem_assoc x assign_ops)
| _ -> false | _ -> false
@ -1066,6 +1073,26 @@ let header_follow p s =
let a = peek_at p 2 in let a = peek_at p 2 in
a.tok = LP && not a.sp a.tok = LP && not a.sp
| _ -> true) | _ -> true)
(* [macro name(...)]: the name and its glued parenthesis. *)
| "macro" ->
n.sp && plain_name n.tok
&& (let a = peek_at p 2 in a.tok = LP && not a.sp)
(* [class Lambda(...)] or [class Lambda] over its slot lines. *)
| "class" -> n.sp && plain_name n.tok
(* [generic describe(v)], [multi kind(v)], [method describe(f: C)]: the
name and its glued parenthesis. *)
| "generic" | "multi" | "method" ->
n.sp && plain_name n.tok
&& (let a = peek_at p 2 in a.tok = LP && not a.sp)
(* [type Row = Vec(i32)]: a name and its [=]. *)
| "type" -> n.sp && plain_name n.tok && (peek_at p 2).tok = NAME "="
(* [loop x = a, ...]: a name and its [=]. A name and a comma or the end
of the line, or [loop] alone over a block, is a loop missing its first
values, which [header] answers. *)
| "loop" ->
(n.sp && plain_name n.tok
&& (match (peek_at p 2).tok with NAME "=" | COMMA | NEWLINE -> true | _ -> false))
|| (n.tok = NEWLINE && (peek_at p 2).tok = INDENT)
| "return" -> n.tok = NEWLINE || (n.sp && starts_value n.tok) | "return" -> n.tok = NEWLINE || (n.sp && starts_value n.tok)
| "break" | "continue" -> | "break" | "continue" ->
n.tok = NEWLINE || (n.sp && (match n.tok with KW _ -> true | _ -> false)) n.tok = NEWLINE || (n.sp && (match n.tok with KW _ -> true | _ -> false))
@ -1122,6 +1149,28 @@ let params p (lp : token) =
in in
go [] go []
(* [(a, b: T)] as each name and its type when one is written. *)
let named_params p (lp : token) =
let rec go acc =
let t = peek p in
match t.tok with
| RP -> ignore (advance p); List.rev acc
| EOF -> unclosed p '(' lp.loc
| _ ->
let n = name_tok p ~what:"a parameter's name" in
let tyf =
match (peek p).tok with
| COLON -> ignore (advance p); Some (ty p)
| _ -> None
in
(match (peek p).tok with
| COMMA -> ignore (advance p)
| RP -> ()
| _ -> stray p ~after:(text_of (match tyf with Some t -> t | None -> n)));
go ((n, tyf) :: acc)
in
go []
(* [fn(a: C, b) -> R = body] is [(the (Fn [C dyn] R) (fn [a b] body))]: the (* [fn(a: C, b) -> R = body] is [(the (Fn [C dyn] R) (fn [a b] body))]: the
paren [fn] takes its parameters' types from where it is written, and [the] paren [fn] takes its parameters' types from where it is written, and [the]
is the form that says what a value is, as in [let x: T = v]. An untyped is the form that says what a value is, as in [let x: T = v]. An untyped
@ -1209,7 +1258,7 @@ and value_line ?(block_ok = false) (s : st) ~after : Form.t =
match (peek p).tok with match (peek p).tok with
(* [let r = match a] with its arms under it, and [let r = if c] with its (* [let r = match a] with its arms under it, and [let r = if c] with its
branches: a header read as the value, block and all. *) branches: a header read as the value, block and all. *)
| NAME (("match" | "handler-case" | "handler-bind" | "restart-case") as w) | NAME (("match" | "handler-case" | "handler-bind" | "restart-case" | "loop") as w)
when header_follow p w -> when header_follow p w ->
header s w header s w
| NAME "if" when header_follow p "if" && not (then_on_line p) -> header s "if" | NAME "if" when header_follow p "if" && not (then_on_line p) -> header s "if"
@ -1331,6 +1380,7 @@ and stmt (s : st) : Form.t =
let t = peek p in let t = peek p in
match t.tok with match t.tok with
| NAME w when header_follow p w -> header s w | NAME w when header_follow p w -> header s w
| NAME _ when assigns p -> expr_stmt s
| NAME (("else" | "elif") as w) when else_if_above p t -> | NAME (("else" | "elif") as w) when else_if_above p t ->
failk "orphan-else" t.loc failk "orphan-else" t.loc
"the else above took the one-line if after it as its value, so this %s \ "the else above took the one-line if after it as its value, so this %s \
@ -1473,6 +1523,9 @@ and header (s : st) w : Form.t =
named (if w = "fn" then "defn" else "defn-") named (if w = "fn" then "defn" else "defn-")
(name :: Form.make (Form.Vec ps) lp.loc :: ret :: (where_clause @ body)) (name :: Form.make (Form.Vec ps) lp.loc :: ret :: (where_clause @ body))
| "def" | "once" | "const" -> | "def" | "once" | "const" ->
(* A top-level [let] is read here too, as [def]: [w] is then "def" and
[t] the let. *)
let shown = match t.tok with NAME "let" -> "let" | _ -> w in
let name = name_tok p ~what:"the name being defined" in let name = name_tok p ~what:"the name being defined" in
let tyf = let tyf =
match (peek p).tok with match (peek p).tok with
@ -1483,7 +1536,7 @@ and header (s : st) w : Form.t =
match (peek p).tok with match (peek p).tok with
| NAME "=" -> | NAME "=" ->
ignore (advance p); ignore (advance p);
Some (value_line s ~after:(w ^ " " ^ text_of name ^ " =")) Some (value_line s ~after:(shown ^ " " ^ text_of name ^ " ="))
| _ -> | _ ->
expect_eol p ~after:(match tyf with Some f -> text_of f | None -> text_of name); expect_eol p ~after:(match tyf with Some f -> text_of f | None -> text_of name);
None None
@ -1491,6 +1544,18 @@ and header (s : st) w : Form.t =
let head = let head =
match w with "def" -> "def" | "once" -> "defonce" | _ -> "defconst" match w with "def" -> "def" | "once" -> "defonce" | _ -> "defconst"
in in
if shown = "def" then
failk "def-is-let" l0
"a global is written with let, at the file's top level:\n\n let %s%s%s"
(text_of name)
(match tyf, v with
| Some t, _ -> ": " ^ text_of t
| None, None -> ": i32"
| None, Some _ -> "")
(match v, tyf with
| Some v, _ -> " = " ^ text_of v
| None, None -> " = 0"
| None, Some _ -> "");
let items = let items =
match w, tyf, v with match w, tyf, v with
| "const", None, Some v -> [ name; v ] | "const", None, Some v -> [ name; v ]
@ -1505,13 +1570,39 @@ and header (s : st) w : Form.t =
failk "def-empty" l0 failk "def-empty" l0
"%s %s names neither a type nor a value. Give it one or both: %s %s: \ "%s %s names neither a type nor a value. Give it one or both: %s %s: \
i32 = 0" i32 = 0"
w (text_of name) w (text_of name) shown (text_of name) shown (text_of name)
in in
named head items named head items
| "struct" | "union" -> | "struct" | "union" ->
let name = name_tok p ~what:"the type's name" in let name = name_tok p ~what:"the type's name" in
expect_eol_block p ~after:(w ^ " " ^ text_of name); (* [struct Pt(x: i32, y: i32)]: the fields on the header's line, as a
data case writes them, with no block under it. *)
let inline =
match (peek p).tok with
| LP when not (peek p).sp -> let lp = advance p in Some (params p lp)
| _ -> None
in
(* [struct DiskFull :parent IoError]: a condition's parent, before the
fields as in the paren form. *)
let parent =
match (peek p).tok with
| KW "parent" when w = "struct" ->
let kt = advance p in
let pt = ty p in
Some (Form.make (Form.Kw "parent") kt.loc, pt)
| _ -> None
in
let after =
match parent, inline with
| Some (_, pt), _ -> text_of pt
| None, Some _ -> ")"
| None, None -> w ^ " " ^ text_of name
in
let fields = let fields =
match inline with
| Some fs -> expect_eol p ~after; fs
| None ->
expect_eol_block p ~after;
lines s (fun () -> lines s (fun () ->
let f = name_tok p ~what:"a field's name" in let f = name_tok p ~what:"a field's name" in
let tf = let tf =
@ -1522,8 +1613,196 @@ and header (s : st) w : Form.t =
expect_eol p ~after:(text_of tf); expect_eol p ~after:(text_of tf);
[ f; tf ]) [ f; tf ])
in in
let fv = Form.make (Form.Vec fields) (span p name.loc) in
(* No field lines under a parent is the category form, which has no
field vector. *)
named (if w = "struct" then "defstruct" else "defunion") named (if w = "struct" then "defstruct" else "defunion")
[ name; Form.make (Form.Vec fields) (span p name.loc) ] (match parent with
| None -> [ name; fv ]
| Some (k, pt) -> name :: k :: pt :: (if fields = [] then [] else [ fv ]))
| "class" ->
let name = name_tok p ~what:"the class's name" in
let ps =
match (peek p).tok with
| LP when not (peek p).sp ->
let lp = advance p in
let ps = named_params p lp in
expect_eol p ~after:")";
ps
| _ ->
expect_eol_block p ~after:("class " ^ text_of name);
let acc = ref [] in
ignore
(lines s (fun () ->
let f = name_tok p ~what:"a slot's name" in
let t =
match (peek p).tok with
| COLON -> ignore (advance p); Some (ty p)
| _ -> None
in
expect_eol p ~after:(match t with Some t -> text_of t | None -> text_of f);
acc := (f, t) :: !acc;
[]));
List.rev !acc
in
(* Each slot's name, and its type after it when one is written: the
paren form's [(defclass c [a b n i32])], whose untyped slots are dyn. *)
let slots =
List.concat_map (fun (n, t) -> match t with Some t -> [ n; t ] | None -> [ n ]) ps
in
named "defclass" [ name; Form.make (Form.Vec slots) (span p name.loc) ]
| "generic" | "multi" | "method" ->
let name = name_tok p ~what:(Printf.sprintf "the %s's name" w) in
let lp = advance p in
let ps = named_params p lp in
(* A method's first parameter may name the class it answers for; every
other parameter of these is dyn, so it takes no type. *)
let names = String.concat ", " (List.map (fun ((n : Form.t), _) -> text_of n) ps) in
let first = match ps with (n, _) :: _ -> text_of n | [] -> "v" in
let first_class = ref None in
List.iteri
(fun k ((n : Form.t), t) ->
match t with
| Some (tf : Form.t) when k = 0 && w = "method" -> first_class := Some tf
| Some tf ->
failk "dyn-parameter" tf.loc
"every parameter of a %s is dyn, so %s takes no type: write %s %s(%s)%s"
w (text_of n) w (text_of name)
(String.concat ", "
(List.mapi
(fun k ((n : Form.t), t) ->
match t with
| Some t when k = 0 && w = "method" -> text_of n ^ ": " ^ text_of t
| _ -> text_of n)
ps))
(if w = "method" then "" else " -> dyn")
| None -> ())
ps;
let pv = Form.make (Form.Vec (List.map fst ps)) (span p lp.loc) in
let ret () =
match (peek p).tok with
| NAME "->" -> ignore (advance p); ty p
| _ ->
(* At the end of the header's line, where the arrow goes. *)
let e = (last p).loc in
failk "generic-return"
{ e with Loc.line = e.Loc.eline; col = e.Loc.ecol }
"a %s states the type every method returns: %s %s(%s) -> dyn"
w w (text_of name) names
in
let body ~after ~prev =
match (peek p).tok with
| NAME "=" ->
ignore (advance p);
[ value_line s ~after:"=" ]
| NEWLINE ->
ignore (advance p);
block s ~after
| _ -> stray p ~after:prev
in
(match w with
| "generic" ->
let r = ret () in
expect_eol p ~after:(text_of r);
named "defgeneric" [ name; pv; r ]
| "multi" ->
let r = ret () in
named "defmulti"
(name :: pv :: r :: body ~after:("multi " ^ text_of name ^ "(...)") ~prev:(text_of r))
| _ ->
let key =
match (peek p).tok, !first_class with
| NAME "when", Some tf ->
failk "method-key" (peek p).loc
"this method already answers for %s, its first parameter's type. \
Write the type or the when, not both"
(text_of tf)
| NAME "when", None ->
ignore (advance p);
fst (unary p)
| _, Some tf -> tf
| _, None ->
failk "method-key" (where_ p)
"a method says what it answers for: a class as its first \
parameter's type, method %s(%s: point), or a value after when, \
method %s(%s) when :int"
(text_of name) first (text_of name) names
in
named "defmethod"
(name :: key :: pv
:: body ~after:("method " ^ text_of name ^ "(...)")
~prev:(if !first_class = None then text_of key else ")")))
| "type" ->
let name = name_tok p ~what:"the alias's name" in
expect_name p "=" ~what:"= and the type it names";
let t = ty p in
expect_eol p ~after:(text_of t);
named "defalias" [ name; t ]
| "macro" ->
let name = name_tok p ~what:"the macro's name" in
let lp = glued_lp p ~what:"the parameters, in parentheses glued to the name" in
let rec go acc =
let t = peek p in
match t.tok with
| RP -> ignore (advance p); List.rev acc
| EOF -> unclosed p '(' lp.loc
| _ ->
let one =
match t.tok with
| NAME "&" ->
ignore (advance p);
[ name_tok p ~what:"the rest parameter's name after &"; sym t.loc "&" ]
| LB -> [ fst (primary p) ]
| _ -> [ name_tok p ~what:"a parameter's name" ]
in
(match (peek p).tok with
| COMMA -> ignore (advance p)
| RP -> ()
| _ -> stray p ~after:(text_of (List.hd one)));
go (one @ acc)
in
let ps = go [] in
let n = List.length ps in
List.iteri
(fun k (a : Form.t) ->
if a.v = Form.Sym "&" && k < n - 2 then begin
let r = List.nth ps (k + 1) in
let others = List.filteri (fun j _ -> j <> k && j <> k + 1) ps in
failk "macro-rest-last" a.loc
"& %s takes the arguments left over, so it comes last: macro %s(%s)"
(text_of r) (text_of name)
(String.concat ", " (List.map text_of others @ [ "& " ^ text_of r ]))
end)
ps;
let pv = Form.make (Form.Vec ps) (span p lp.loc) in
expect_line_end p ~after:")";
let body = block s ~after:("macro " ^ text_of name ^ "(...)") in
named "defmacro" (name :: pv :: body)
| "loop" ->
let missing () =
failk "loop-bindings" l0
"loop names each variable with its first value: loop i = 0, acc = 1. \
A loop with no variables is written loop([]):"
in
if (peek p).tok = NEWLINE then missing ();
let rec binds acc =
let n = name_tok p ~what:"a loop variable's name" in
(match (peek p).tok with
| NAME "=" -> ignore (advance p)
| _ ->
failk "loop-bindings" n.loc
"%s needs its first value: loop %s = 0. Each variable of a loop \
takes one, separated by commas: loop i = 0, acc = 1"
(text_of n) (text_of n));
let v, _ = expr p in
match (peek p).tok with
| COMMA -> ignore (advance p); binds (v :: n :: acc)
| _ -> List.rev (v :: n :: acc)
in
let bs = binds [] in
expect_line_end p ~after:(text_of (List.nth bs (List.length bs - 1)));
let body = block s ~after:"loop" in
form (Form.make (Form.Vec bs) (span_of_list (List.hd bs).loc bs) :: body)
| "data" -> | "data" ->
let name = name_tok p ~what:"the type's name" in let name = name_tok p ~what:"the type's name" in
expect_eol_block p ~after:("data " ^ text_of name); expect_eol_block p ~after:("data " ^ text_of name);
@ -1578,7 +1857,7 @@ and header (s : st) w : Form.t =
let clauses ~oneline body = let clauses ~oneline body =
let rec elifs acc = let rec elifs acc =
match (peek p).tok with match (peek p).tok with
| NAME "elif" -> | NAME "elif" when not (assigns p) ->
ignore (advance p); ignore (advance p);
let c, _ = binary p 1 in let c, _ = binary p 1 in
(match (peek p).tok with (match (peek p).tok with
@ -1600,7 +1879,7 @@ and header (s : st) w : Form.t =
let els_ = elifs [] in let els_ = elifs [] in
let else_ = let else_ =
match (peek p).tok with match (peek p).tok with
| NAME "else" -> | NAME "else" when not (assigns p) ->
let et = advance p in let et = advance p in
(match (peek p).tok with (match (peek p).tok with
| NEWLINE -> ignore (advance p); Some (et.loc, block s ~after:"else") | NEWLINE -> ignore (advance p); Some (et.loc, block s ~after:"else")
@ -1748,7 +2027,7 @@ and header (s : st) w : Form.t =
let body = block s ~after:w in let body = block s ~after:w in
let rec clauses acc = let rec clauses acc =
match (peek p).tok, (peek_at p 1) with match (peek p).tok, (peek_at p 1) with
| NAME "on", n when n.sp -> | NAME "on", n when n.sp && not (assigns p) ->
let ot = advance p in let ot = advance p in
let head, _ = postfix p in let head, _ = postfix p in
let ty, var = let ty, var =
@ -1777,7 +2056,7 @@ and header (s : st) w : Form.t =
let body = block s ~after:w in let body = block s ~after:w in
let rec clauses acc = let rec clauses acc =
match (peek p).tok, (peek_at p 1) with match (peek p).tok, (peek_at p 1) with
| NAME "restart", n when n.sp -> | NAME "restart", n when n.sp && not (assigns p) ->
ignore (advance p); ignore (advance p);
let name = name_tok p ~what:"the restart's name" in let name = name_tok p ~what:"the restart's name" in
let lp = glued_lp p ~what:"the restart's parameters in parentheses" in let lp = glued_lp p ~what:"the restart's parameters in parentheses" in
@ -1863,7 +2142,7 @@ and lines (s : st) (one : unit -> Form.t list) : Form.t list =
(** All top-level forms in a [.fln] source string. [col] is the column the (** All top-level forms in a [.fln] source string. [col] is the column the
text's top level starts at, 1 for a file. *) text's top level starts at, 1 for a file. *)
let read_all ?(line = 1) ?col ?indent ~file src = let read_all ?(line = 1) ?col ?indent ?(global_let = true) ~file src =
let snippet = col <> None in let snippet = col <> None in
let col = Option.value col ~default:1 in let col = Option.value col ~default:1 in
let saved = !source in let saved = !source in
@ -1875,7 +2154,19 @@ let read_all ?(line = 1) ?col ?indent ~file src =
Fun.protect ~finally:(fun () -> source := saved) (fun () -> Fun.protect ~finally:(fun () -> source := saved) (fun () ->
let toks = layout ~snippet ~base:col ?indent (lex ~line ~col ~file src) in let toks = layout ~snippet ~base:col ?indent (lex ~line ~col ~file src) in
let s = { p = { toks; i = 0 }; lets = [] } in let s = { p = { toks; i = 0 }; lets = [] } in
let fs = stmts s in (* At the top level, a [let] is a global, [(def x dyn v)]: a let there has
no block to be local to. Not in an expression the editor sends, where
a let is the statement it is in a body. *)
let rec top () =
match (peek s.p).tok with
| EOF -> []
| DEDENT -> ignore (advance s.p); []
| NAME "let" when header_follow s.p "let" ->
let f = header s "def" in
f :: top ()
| _ -> let f = stmt s in f :: top ()
in
let fs = if global_let then top () else stmts s in
(match (peek s.p).tok with (match (peek s.p).tok with
| EOF -> () | EOF -> ()
| tk -> failk "unexpected-token" (where_ s.p) "unexpected %s" (show tk)); | tk -> failk "unexpected-token" (where_ s.p) "unexpected %s" (show tk));

11
lib/source.ml
View File

@ -72,9 +72,11 @@ let read_paren ?(line = 1) ?(col = 1) ~file src =
in in
go [] go []
(** Editor code, in the request's syntax and at its position. With [expr], an (** Editor code, in the request's syntax and at its position. With [expr],
indented snippet of several statements is one expression, [(do ...)]: a an indented snippet of several statements is one expression,
block of lines means its lines in order. *) [(do ...)]: a block of lines means its lines in order. A [let] is a
global only in code from column 1 that is not an expression: a form cut
from inside a body, for a macroexpansion say, keeps its lets local. *)
let read_code ?(expr = false) ~file code = let read_code ?(expr = false) ~file code =
let line, col = let line, col =
match !code_at with Some (l, c) -> (l, c) | None -> (1, 1) match !code_at with Some (l, c) -> (l, c) | None -> (1, 1)
@ -82,7 +84,8 @@ let read_code ?(expr = false) ~file code =
match !code_syntax with match !code_syntax with
| Paren -> read_paren ~line ~col ~file code | Paren -> read_paren ~line ~col ~file code
| Indented -> | Indented ->
(match Indent_reader.read_all ~line ~col ?indent:!code_indent ~file code with (match Indent_reader.read_all ~line ~col ?indent:!code_indent ~global_let:(not expr && col = 1)
~file code with
| (first :: _ :: _ as forms) when expr -> | (first :: _ :: _ as forms) when expr ->
let last = List.nth forms (List.length forms - 1) in let last = List.nth forms (List.length forms - 1) in
let loc = let loc =

43
spec-syntax.md
View File

@ -280,20 +280,45 @@ Each item: the proposal, then the reason in one line.
becomes `where ordered?($t)` after the return type. **Built**; with no becomes `where ordered?($t)` after the return type. **Built**; with no
`-> R` the return is `_`, read off the body. Several predicates are `-> R` the return is `_`, read off the body. Several predicates are
`where p, q`. `where p, q`.
- `def x = v`, `def x: T = v`, `once x: T`, `once x = v`, `const n = 3`, - A `let` at the top level is a global: `let x = v`, `let x: T = v`,
`def scratch: [4 u8] = uninit`. **Built.** `def x = v` and `once x = v` read `let scratch: [4 u8] = uninit` read `(def x dyn v)`, `(def x T v)`;
with `dyn`; `const n = 3` reads `(defconst n 3)`, its type inferred as today. `once x: T`, `once x = v`, `const n = 3`. **Built.** `let x = v` and
`once x = v` read with `dyn`; `const n = 3` reads `(defconst n 3)`, its type
inferred as today. `def` is refused with the `let` to write. A `let` in a
block, `comment:`'s included, is local, and so is one in code the editor
evaluates as an expression.
- `struct Cell` with a `name: Type` line per field. `data Shape` with a line per - `struct Cell` with a `name: Type` line per field. `data Shape` with a line per
case: `Circle(r: f32)`, `Empty`. `enum K` with `lo = -1`, `mid`. `union U` like case: `Circle(r: f32)`, `Empty`. `enum K` with `lo = -1`, `mid`. `union U` like
`struct`. **Built** (an untyped field is `dyn`; `Empty()` is `(Empty [])`). `struct`. **Built** (an untyped field is `dyn`; `Empty()` is `(Empty [])`).
A member is `:mid` or `K.mid`, in a value and in a match arm, in both A member is `:mid` or `K.mid`, in a value and in a match arm, in both
syntaxes (section 3, item 8). syntaxes (section 3, item 8). A condition names its parent after the name,
`struct DiskFull :parent IoError` with its field lines, reading
`(defstruct DiskFull :parent IoError [free i64])`; with no field lines it
reads `(defstruct IoError :parent Error)`. A struct or union fits on one
line with its fields in parentheses, `struct Pt(x: i32, y: i32)` or
`struct DiskFull(free: i64) :parent IoError`; `flan convert` writes that
when it fits the line and no comment sits among the fields. **Built.**
- `type Row = Vec(i32)` reads `(defalias Row (Vec i32))`. **Built.**
- `macro repeat(i, n, & body)` plus a block reads
`(defmacro repeat [i n & body] …)`. A parameter is a bare name, a
destructuring vector `[a b]`, or `& rest`, last. **Built.**
- `loop x = a, y = b` plus a block reads `(loop [x a y b] …)`, as a statement
or as a value, `let r = loop i = 0`. `recur(y, x % y)` is a call. A loop with
no variables is the fallback, `loop([]):`. **Built.**
- `class lambda(param, body, env)`, or `class lambda` with a slot per line,
reads `(defclass lambda [param body env])`; a typed slot is `pause: bool`
and its type follows its name in the vector. **Built.**
- `generic describe(v) -> dyn` reads `(defgeneric describe [v] dyn)`;
`multi kind(v) -> dyn = type-of(v)`, or plus a block, reads
`(defmulti kind [v] dyn (type-of v))`. Their parameters are bare names.
**Built.**
- `method describe(f: lambda)` plus a block reads
`(defmethod describe lambda [f] …)`: a class is the first parameter's type.
Any other dispatch value follows `when`: `method kind(v) when :int`,
`when :else` for the default. `= value` for a one-line body. **Built.**
- `import rl "vendor:raylib"`. **Built.** - `import rl "vendor:raylib"`. **Built.**
- **Every other form uses the fallback** (next item) until someone asks for - **Every other form uses the fallback** (next item) until someone asks for
sugar: `defclass`, `defgeneric`, `defmulti`, `defmethod`, `declare`, sugar: `declare`, `declare-c`, `array-fill`. **Built.**
`declare-c`, `defalias`, `defmacro`, `loop`/`recur`, `array-fill`. **Built.**
The class forms keep the fallback for good (2026-09-26):
`defmethod(area, point, [p]):` reads well enough.
### The fallback ### The fallback
@ -317,7 +342,7 @@ value, `vec-new(Fn([i32], i32))` is the call spelling).
### Macro templates ### Macro templates
``` ```
defmacro(with-mode-2d, [camera & body]): macro with-mode-2d(camera, & body)
quote quote
begin-mode-2d(~camera) begin-mode-2d(~camera)
~@body ~@body

4
test/syntax/handwritten/csv.fln
View File

@ -8,11 +8,11 @@ enum State
quote-in-quoted quote-in-quoted
once rows-seen: i32 once rows-seen: i32
def fields-seen: i32 = 0 let fields-seen: i32 = 0
const separator = \, const separator = \,
; Frame the body's output with a title line and a closing rule. ; Frame the body's output with a title line and a closing rule.
defmacro(with-section, [title & body]): macro with-section(title, & body)
quote quote
println("--", ~title, "--") println("--", ~title, "--")
~@body ~@body

8
test/syntax/handwritten/inventory.fln
View File

@ -8,24 +8,24 @@ struct Rule
label: str label: str
applies: CFn(stock/Item) -> bool applies: CFn(stock/Item) -> bool
def report-width: i32 = 28 let report-width: i32 = 28
once runs: i32 once runs: i32
const reorder-below = 5 const reorder-below = 5
; Run the body n times, counting passes in the name given. ; Run the body n times, counting passes in the name given.
defmacro(repeat, [i n & body]): macro repeat(i, n, & body)
quote quote
for ~i in range(~n) for ~i in range(~n)
~@body ~@body
; Say what went wrong when a check does not hold. ; Say what went wrong when a check does not hold.
defmacro(expect, [test message]): macro expect(test, message)
quote quote
if not ~test if not ~test
println("expected:", ~message) println("expected:", ~message)
fn gcd(a: i32, b: i32) -> i32 fn gcd(a: i32, b: i32) -> i32
loop([x a y b]): loop x = a, y = b
if y == 0 then x else recur(y, x % y) if y == 0 then x else recur(y, x % y)
fn line(it: stock/Item) -> () fn line(it: stock/Item) -> ()

8
test/syntax/handwritten/ledger.fln
View File

@ -2,11 +2,11 @@
; overdraw signals, and the caller picks a restart: skip it, cap it at what ; overdraw signals, and the caller picks a restart: skip it, cap it at what
; the account holds, or allow an overdraft up to a limit it supplies. ; the account holds, or allow an overdraft up to a limit it supplies.
defstruct(Overdraft, :parent, Error, [account i32 short i64]) struct Overdraft :parent Error
struct Audit
account: i32 account: i32
amount: i64 short: i64
struct Audit(account: i32, amount: i64)
once balances: [4 i64] once balances: [4 i64]
once audits: i32 once audits: i32

15
test/syntax/handwritten/lisp.fln
View File

@ -2,22 +2,21 @@
; first element is a keyword naming the operation, variables are keywords, ; first element is a keyword naming the operation, variables are keywords,
; and environments are dyn maps chained through a :parent key. ; and environments are dyn maps chained through a :parent key.
defclass(lambda, [param body env]) class lambda(param, body, env)
defgeneric(describe, [v], dyn) generic describe(v) -> dyn
defmethod(describe, lambda, [f]): method describe(f: lambda)
"a function of one argument" "a function of one argument"
defmulti(kind, [v], dyn, type-of(v)) multi kind(v) -> dyn = type-of(v)
defmethod(kind, :int, [v]): method kind(v) when :int
"number" "number"
defmethod(kind, :vec, [v]): method kind(v) when :vec = "form"
"form"
defmethod(kind, :else, [v]): method kind(v) when :else
"value" "value"
once steps = 0 once steps = 0

6
test/syntax/sand.fln
View File

@ -15,8 +15,8 @@ const brush-size = 10
fn dyn->f64(v: f64) -> f64 = v fn dyn->f64(v: f64) -> f64 = v
fn dyn->u32(v: i64) -> u32 = u32(v) fn dyn->u32(v: i64) -> u32 = u32(v)
def gravity = 0.05 let gravity = 0.05
def colors = let colors =
let v = vec-new(dyn) let v = vec-new(dyn)
push(v, 0xFFF00FFF) push(v, 0xFFF00FFF)
push(v, 0x3B6E8CFF) push(v, 0x3B6E8CFF)
@ -121,7 +121,7 @@ fn game-draw() -> ()
rl/draw-fps(20, 20) rl/draw-fps(20, 20)
once frame: Allocator = arena-new(262144) once frame: Allocator = arena-new(262144)
def game-data = let game-data =
handler-case handler-case
edn/read-file("game-data.edn") edn/read-file("game-data.edn")
on FileError(c) on FileError(c)

8
test/test_acceptance.ml
View File

@ -7314,6 +7314,14 @@ level "1"
cli_case "check on a file that is not there" cli_case "check on a file that is not there"
"check no-such-file.flan" ~code:1 "check no-such-file.flan" ~code:1
~says:[ "no-such-file.flan"; "No such file or directory" ]; ~says:[ "no-such-file.flan"; "No such file or directory" ];
(* A file that checks prints nothing; --defs lists what it defined. *)
(match cli "check programs/recur.flan" with
| 0, "" -> ()
| code, text ->
incr failures;
Printf.printf "FAIL a clean check prints nothing\n got: %S (exit %d)\n" text code);
cli_case "check --defs lists the definitions" "check programs/recur.flan --defs" ~code:0
~says:[ "defn gcd : (Fn [i32 i32] i32)" ];
(* And every other front end takes the same route, since the arm is on the (* And every other front end takes the same route, since the arm is on the
one wrapper they all go through. *) one wrapper they all go through. *)
cli_case "build on a file that is not there" cli_case "build on a file that is not there"

127
test/test_syntax.ml
View File

@ -411,17 +411,19 @@ let () =
(* ── Lexical edge cases ────────────────────────────────────────────── *) (* ── Lexical edge cases ────────────────────────────────────────────── *)
let read src = Indent_reader.read_all ~file:"<syntax>" src (* [~global:false] reads as an expression the editor sends, where a [let] is
local; a file's top-level [let] is a global. *)
let read ?(global = true) src = Indent_reader.read_all ~global_let:global ~file:"<syntax>" src
let reads name src want = let reads ?global name src want =
match read src with match read ?global src with
| forms -> | forms ->
let got = String.concat "\n" (List.map Form.to_string forms) in let got = String.concat "\n" (List.map Form.to_string forms) in
if got <> want then fail "%s: read %s, wanted %s" name got want if got <> want then fail "%s: read %s, wanted %s" name got want
| exception e -> fail "%s: refused: %s" name (diag_text e) | exception e -> fail "%s: refused: %s" name (diag_text e)
let refuses name src kind needle = let refuses ?global name src kind needle =
match read src with match read ?global src with
| forms -> | forms ->
fail "%s: read %s, wanted the refusal %s" name fail "%s: read %s, wanted the refusal %s" name
(String.concat " " (List.map Form.to_string forms)) kind (String.concat " " (List.map Form.to_string forms)) kind
@ -462,7 +464,7 @@ let () =
reads "character literals" "x = [\\( \\, \\space \\)]" "(set x [\\( \\, \\space \\)])"; reads "character literals" "x = [\\( \\, \\space \\)]" "(set x [\\( \\, \\space \\)])";
reads "character arguments" "f(\\,, \\))" "(f \\, \\))"; reads "character arguments" "f(\\,, \\))" "(f \\, \\))";
(* Keywords and annotations. *) (* Keywords and annotations. *)
reads "keyword" "def k = :else" "(def k dyn :else)"; reads "keyword" "let k = :else" "(def k dyn :else)";
reads "annotation" "once grid: [4 [8 u32]]" "(defonce grid [4 [8 u32]])"; reads "annotation" "once grid: [4 [8 u32]]" "(defonce grid [4 [8 u32]])";
reads "keyword argument" "rl/key-pressed?(:key-r)" "(rl/key-pressed? :key-r)"; reads "keyword argument" "rl/key-pressed?(:key-r)" "(rl/key-pressed? :key-r)";
refuses "colon inside a name" "fn f(x:i32) -> () = x" "indent/colon-in-name" "x: i32"; refuses "colon inside a name" "fn f(x:i32) -> () = x" "indent/colon-in-name" "x: i32";
@ -521,8 +523,8 @@ let () =
(* Statements. *) (* Statements. *)
reads "lets merge" "fn f() -> i32\n let a = 1\n let b = 2\n a + b" reads "lets merge" "fn f() -> i32\n let a = 1\n let b = 2\n a + b"
"(defn f [] i32 (let [a 1 b 2] (+ a b)))"; "(defn f [] i32 (let [a 1 b 2] (+ a b)))";
refuses "let with a block" "let a = 1\n a\nb" "indent/let-block" "go at the let's column"; refuses ~global:false "let with a block" "let a = 1\n a\nb" "indent/let-block" "go at the let's column";
reads "flat let" "let a = 1\na\nb" "(let [a 1] a b)"; reads ~global:false "flat let" "let a = 1\na\nb" "(let [a 1] a b)";
reads "elif" "if a\n 1\nelif b\n 2\nelse\n 3" "(cond a 1 b 2 :else 3)"; reads "elif" "if a\n 1\nelif b\n 2\nelse\n 3" "(cond a 1 b 2 :else 3)";
reads "one-line if" "x = if a then 1 else 2" "(set x (if a 1 2))"; reads "one-line if" "x = if a then 1 else 2" "(set x (if a 1 2))";
reads "assignment ops" "a[i] += 1" "(set (at a i) (+ (at a i) 1))"; reads "assignment ops" "a[i] += 1" "(set (at a i) (+ (at a i) 1))";
@ -553,7 +555,63 @@ let () =
"(defdata Shape [(Circle [r f32]) Empty])"; "(defdata Shape [(Circle [r f32]) Empty])";
reads "enum" "enum K\n lo = -1\n mid" "(defenum K [lo -1 mid])"; reads "enum" "enum K\n lo = -1\n mid" "(defenum K [lo -1 mid])";
reads "struct" "struct Cell\n row: i32\n tag" "(defstruct Cell [row i32 tag dyn])"; reads "struct" "struct Cell\n row: i32\n tag" "(defstruct Cell [row i32 tag dyn])";
reads "read-only pointer" "def p: Ptr(const u8) = uninit" "(def p (Ptr const u8) uninit)"; reads "struct with a parent" "struct DiskFull :parent IoError\n free: i64"
"(defstruct DiskFull :parent IoError [free i64])";
reads "type alias" "type Row = Vec(i32)" "(defalias Row (Vec i32))";
reads "type alias of an array" "type V2 = [2 f32]" "(defalias V2 [2 f32])";
reads "a local named type" "type = 3" "(set type 3)";
reads "a header word assigned" "data += 3" "(set data (+ data 3))";
reads "a clause word assigned after its header"
"handler-case\n g()\non E(c)\n h(c)\non = 2"
"(handler-case (g) [(E [c] (h c))])\n(set on 2)";
reads "an else assigned after an if" "if a\n b\nelse = 2" "(when a b)\n(set else 2)";
reads "class" "class lambda(param, body, env)" "(defclass lambda [param body env])";
reads "class with typed slots" "class state\n pause: bool\n tag"
"(defclass state [pause bool tag])";
reads "generic" "generic describe(v) -> dyn" "(defgeneric describe [v] dyn)";
reads "multi" "multi kind(v) -> dyn = type-of(v)" "(defmulti kind [v] dyn (type-of v))";
reads "method on a class" "method describe(f: lambda, x)\n g(f)"
"(defmethod describe lambda [f x] (g f))";
reads "method on a value" "method kind(v) when :else = 1" "(defmethod kind :else [v] 1)";
refuses "a generic's typed parameter" "generic g(p: point) -> dyn" "indent/dyn-parameter"
"write generic g(p) -> dyn";
refuses "a method with no dispatch" "method g(p)\n 1" "indent/method-key"
"method g(p: point)";
refuses "a method with both" "method g(p: point) when :x\n 1" "indent/method-key"
"not both";
reads "a top-level let is a global" "let g = 1\nlet h: i32 = 2\nlet s: [4 u8]\nf(g)"
"(def g dyn 1)\n(def h i32 2)\n(def s [4 u8])\n(f g)";
refuses "def" "def g: i32 = 1" "indent/def-is-let" "let g: i32 = 1";
refuses "a bare def" "def g" "indent/def-is-let" "let g: i32 = 0";
(match read "generic f(a)\n\nfn g() = 1" with
| exception Loc.Error d when d.Loc.dloc.Loc.line = 1 && d.Loc.dloc.Loc.col = 13 -> ()
| exception Loc.Error d ->
fail "a generic with no arrow is refused at %d:%d, not at its line's end"
d.Loc.dloc.Loc.line d.Loc.dloc.Loc.col
| _ -> fail "a generic with no arrow was read");
reads "a let in a comment block stays local" "comment:\n let x = 1\n f(x)"
"(comment (let [x 1] (f x)))";
reads "and in a fn" "fn f() -> i32\n let x = 1\n x" "(defn f [] i32 (let [x 1] x))";
reads "a one-line struct" "struct Pt(x: i32, y)" "(defstruct Pt [x i32 y dyn])";
reads "a one-line union" "union U(a: i32)" "(defunion U [a i32])";
reads "a one-line struct with a parent" "struct D(free: i64) :parent Io"
"(defstruct D :parent Io [free i64])";
refuses "a one-line struct takes no block" "struct Pt(x: i32)\n y: i32" "indent/stray-indent"
"takes no block";
reads "a parent and no fields" "struct Io :parent Error" "(defstruct Io :parent Error)";
reads "macro" "macro repeat(i, n, & body)\n quote\n f(~i)\n ~@body"
"(defmacro repeat [i n & body] (quasiquote (do (f (unquote i)) (unquote-splicing body))))";
reads "macro with a pattern" "macro m([a b], c)\n a" "(defmacro m [[a b] c] a)";
reads "macro with no parameters" "macro m()\n a" "(defmacro m [] a)";
refuses "a rest parameter not last" "macro m(& a, b)\n a" "indent/macro-rest-last"
"comes last: macro m(b, & a)";
reads "loop" "loop x = a, y = b + 1\n recur(y, x)" "(loop [x a y (+ b 1)] (recur y x))";
reads ~global:false "a let-bound loop" "let r = loop i = 0\n recur(i)\nr" "(let [r (loop [i 0] (recur i))] r)";
reads "the loop call stays a call" "loop([x 1]):\n x" "(loop [x 1] x)";
refuses "a loop with no values" "loop\n g()" "indent/loop-bindings" "loop([]):";
refuses "a loop variable with no value" "loop x, y = 1\n g()" "indent/loop-bindings"
"loop x = 0";
reads "read-only pointer" "let p: Ptr(const u8) = uninit" "(def p (Ptr const u8) uninit)";
(* Statements that fit on a line, in one-line slots. *) (* Statements that fit on a line, in one-line slots. *)
reads "arm statements" "match s\n 1 -> break\n 2 -> continue :outer\n _ -> x += 1" reads "arm statements" "match s\n 1 -> break\n 2 -> continue :outer\n _ -> x += 1"
"(match s 1 (break) 2 (continue :outer) _ (set x (+ x 1)))"; "(match s 1 (break) 2 (continue :outer) _ (set x (+ x 1)))";
@ -569,9 +627,9 @@ let () =
refuses "two assignments" "if a then b = c = d" "indent/assign-in-test" "if a then b = c,"; refuses "two assignments" "if a then b = c = d" "indent/assign-in-test" "if a then b = c,";
refuses "a let-bound if with no block" "let r = if a > 1\nr" "indent/expected-block" "if a > 1 takes"; refuses "a let-bound if with no block" "let r = if a > 1\nr" "indent/expected-block" "if a > 1 takes";
refuses "two bindings on a line" "let v: i32 = a, w = b" "indent/one-binding" "a is followed by a comma"; refuses "two bindings on a line" "let v: i32 = a, w = b" "indent/one-binding" "a is followed by a comma";
reads "a let-bound match" "let r = match a\n 1 -> 2\n _ -> 3\nr" "(let [r (match a 1 2 _ 3)] r)"; reads ~global:false "a let-bound match" "let r = match a\n 1 -> 2\n _ -> 3\nr" "(let [r (match a 1 2 _ 3)] r)";
reads "a let-bound if" "let q = if a\n 1\nelse\n 2\nq" "(let [q (if a 1 2)] q)"; reads ~global:false "a let-bound if" "let q = if a\n 1\nelse\n 2\nq" "(let [q (if a 1 2)] q)";
reads "a let-bound call with a block" "let v = foo(a):\n x\nv" "(let [v (foo a x)] v)"; reads ~global:false "a let-bound call with a block" "let v = foo(a):\n x\nv" "(let [v (foo a x)] v)";
refuses "colon after if" "if c:\n y" "indent/header-colon" "no colon"; refuses "colon after if" "if c:\n y" "indent/header-colon" "no colon";
refuses "colon after a return type" "fn f() -> i32:\n 0" "indent/header-colon" "no colon"; refuses "colon after a return type" "fn f() -> i32:\n 0" "indent/header-colon" "no colon";
refuses "colon after a number" "while x < 3:\n y" "indent/header-colon" "no colon"; refuses "colon after a number" "while x < 3:\n y" "indent/header-colon" "no colon";
@ -583,7 +641,7 @@ let () =
refuses "mixed separators" "x = [1 2, 3]" "indent/mixed-separators" "[1, 2, 3]"; refuses "mixed separators" "x = [1 2, 3]" "indent/mixed-separators" "[1, 2, 3]";
reads "one-line quote" "defmacro(m, [x]):\n quote ~x + 1" reads "one-line quote" "defmacro(m, [x]):\n quote ~x + 1"
"(defmacro m [x] (quasiquote (+ (unquote x) 1)))"; "(defmacro m [x] (quasiquote (+ (unquote x) 1)))";
reads "typed let" "let x: i32 = 5\nx" "(let [x (the i32 5)] x)"; reads ~global:false "typed let" "let x: i32 = 5\nx" "(let [x (the i32 5)] x)";
refuses "a let takes no block" "fn f() -> ()\n let x = 1\n g(x)\n h(x)" refuses "a let takes no block" "fn f() -> ()\n let x = 1\n g(x)\n h(x)"
"indent/let-block" "go at the let's column"; "indent/let-block" "go at the let's column";
(* Mistakes carried over from other languages, answered in this one. *) (* Mistakes carried over from other languages, answered in this one. *)
@ -612,7 +670,7 @@ let () =
"indent/orphan-else" "goes at the if's column"; "indent/orphan-else" "goes at the if's column";
reads "a typed lambda" "f = fn(a: C, b) -> bool = a.n < b" reads "a typed lambda" "f = fn(a: C, b) -> bool = a.n < b"
"(set f (the (Fn [C dyn] bool) (fn [a b] (< (.n a) b))))"; "(set f (the (Fn [C dyn] bool) (fn [a b] (< (.n a) b))))";
reads "a typed lambda with a block" "let f = fn(x: i32) -> i32\n let y = x + 1\n y\ng(f)" reads ~global:false "a typed lambda with a block" "let f = fn(x: i32) -> i32\n let y = x + 1\n y\ng(f)"
"(let [f (the (Fn [i32] i32) (fn [x] (let [y (+ x 1)] y)))] (g f))"; "(let [f (the (Fn [i32] i32) (fn [x] (let [y (+ x 1)] y)))] (g f))";
refuses "a typed lambda states its return type" "f = fn(a: C) = a" refuses "a typed lambda states its return type" "f = fn(a: C) = a"
"indent/lambda-return" "fn(a: C) -> R = value"; "indent/lambda-return" "fn(a: C) -> R = value";
@ -796,9 +854,9 @@ let () =
"restart retry() \"Try again\"\n 7"; "restart retry() \"Try again\"\n 7";
prints "adjacent one-line globals stay adjacent" prints "adjacent one-line globals stay adjacent"
"(defonce a i32)\n(def b i32 2)\n\n(defconst c 3)\n" "(defonce a i32)\n(def b i32 2)\n\n(defconst c 3)\n"
"once a: i32\ndef b: i32 = 2\n\nconst c = 3"; "once a: i32\nlet b: i32 = 2\n\nconst c = 3";
back "adjacent one-line globals stay adjacent in parens" back "adjacent one-line globals stay adjacent in parens"
"once a: i32\ndef b: i32 = 2\n\nconst c = 3\n" "once a: i32\nlet b: i32 = 2\n\nconst c = 3\n"
"(defonce a i32)\n(def b i32 2)\n\n(defconst c 3)"; "(defonce a i32)\n(def b i32 2)\n\n(defconst c 3)";
prints "a field of a field chains" "(defn f [] () (g (.count (.x w))))" "g(w.x.count)"; prints "a field of a field chains" "(defn f [] () (g (.count (.x w))))" "g(w.x.count)";
prints "an else-if chain on one line" prints "an else-if chain on one line"
@ -807,7 +865,42 @@ let () =
prints "a long vector wraps" ("(defn f [] () (let [v [" ^ String.concat " " (List.init 30 string_of_int) ^ "]] (g v)))") prints "a long vector wraps" ("(defn f [] () (let [v [" ^ String.concat " " (List.init 30 string_of_int) ^ "]] (g v)))")
" let v = [0 1 2 3"; " let v = [0 1 2 3";
prints "a template's for keeps its unquotes" prints "a template's for keeps its unquotes"
"(defmacro m [i n & body] `(dotimes [~i ~n] ~@body))" "for ~i in range(~n)" "(defmacro m [i n & body] `(dotimes [~i ~n] ~@body))" "for ~i in range(~n)";
prints "a macro" "(defmacro m [[a b] n & body] `(do ~@body))" "macro m([a b], n, & body)\n quote";
prints "a header word assigned keeps no parentheses"
"(defn f [] () (set data 3) (set loop 4) (set on 5))" " data = 3\n loop = 4\n on = 5";
prints "a class" "(defclass point [x y])" "class point(x, y)";
prints "a class's typed slots, and one typed as a class of the file"
"(defclass state [pause bool tag])\n(defclass node [owner state n])"
"class state(pause: bool, tag)\n\nclass node(owner: state, n)";
prints "a generic" "(defgeneric area [self] dyn)" "generic area(self) -> dyn";
prints "a multi" "(defmulti kind [v] dyn (type-of v))" "multi kind(v) -> dyn = type-of(v)";
prints "a method on a class" "(defmethod area point [p] (g p) (h p))"
"method area(p: point)\n g(p)\n h(p)";
prints "a method on a value" "(defmethod kind :int [v] \"n\")" "method kind(v) when :int = \"n\"";
prints "a global is a top-level let" "(def g dyn 1)\n(def h i32 2)" "let g = 1\nlet h: i32 = 2";
prints "a def inside a form keeps the fallback" "(comment (def g i32 1))" "comment:\n def(g, i32, 1)";
prints "a local let at the top level goes in a do block" "(let [x 1] (f x))"
"do:\n let x = 1\n f(x)";
prints "a type alias" "(defalias Row (Vec i32))" "type Row = Vec(i32)";
prints "a struct with a parent" "(defstruct D :parent Io [free i64])"
"struct D(free: i64) :parent Io";
prints "a struct on one line" "(defstruct Pt [x i32 y dyn])" "struct Pt(x: i32, y)\n";
prints "a union too" "(defunion U [a i32 b f32])" "union U(a: i32, b: f32)";
prints "a struct too long for a line takes a line per field"
("(defstruct W [" ^ String.concat " " (List.init 8 (Printf.sprintf "field-number-%d i32")) ^ "])")
"struct W\n field-number-0: i32\n";
prints "and so does one with a comment among its fields"
"(defstruct C [a i32 ; first\n b i32])" "struct C\n a: i32 ; first\n b: i32";
prints "a parent with no fields" "(defstruct D :parent Io)" "struct D :parent Io";
prints "an empty field vector under a parent keeps the fallback"
"(defstruct D :parent Io [])" "defstruct(D, :parent, Io, [])";
prints "a loop" "(defn f [a i32] i32 (loop [x a y 0] (if (= x 0) y (recur (- x 1) (+ y 1)))))"
" loop x = a, y = 0\n if x == 0 then y";
prints "a let-bound loop" "(defn f [] i32 (let [r (loop [i 0] (recur i))] r))"
" let r = loop i = 0\n recur(i)";
prints "a lambda as a loop's value is parenthesised"
"(defn f [] () (loop [g (fn [x] x) n 0] (recur g n)))" "loop g = (fn(x) = x), n = 0"
(* ── Spans, for pause marks and error overlays ──────────────────────── *) (* ── Spans, for pause marks and error overlays ──────────────────────── *)

7
web/examples/quotes.sh
View File

@ -81,10 +81,9 @@ do
name=${pair%%:*}; src=${pair#*:} name=${pair%%:*}; src=${pair#*:}
printf '%s\n' "$src" > "$here/.q.flan" printf '%s\n' "$src" > "$here/.q.flan"
out=$("$FLAN" check "$here/.q.flan" 2>&1) out=$("$FLAN" check "$here/.q.flan" 2>&1)
# A probe that compiles is the failure this loop is most likely to meet, and # A probe that compiles is the failure this loop is most likely to meet:
# it is the one that used to be unreadable: `flan check` answers a clean # `flan check` prints nothing for it, so the needle would be empty and the
# program with its whole symbol table, so the needle became eighty lines of # diff would say nothing. Say what actually happened.
# prelude signatures and the diff said nothing. Say what actually happened.
if "$FLAN" check "$here/.q.flan" >/dev/null 2>&1; then if "$FLAN" check "$here/.q.flan" >/dev/null 2>&1; then
echo "FAIL message: $name" echo "FAIL message: $name"
echo " this program compiles now — the page still says it is refused" echo " this program compiles now — the page still says it is refused"