diff --git a/TODO.org b/TODO.org index 9a98629b..d39595c0 100644 --- a/TODO.org +++ b/TODO.org @@ -650,44 +650,29 @@ 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: ~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 Indices separate like vector elements +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 +needs them, ~grid[r + 1, c]~. -** 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. +** WAIT Calls without parentheses +Held 2026-09-26 by the author: F#-style ~f x y~ or Nim-style one-argument calls +without parentheses. Collides with space-separated vector and index elements. -** 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. +** TODO RET inside an open call puts the closer at the statement's column +In a .fln buffer, ~if and(state.paused|)~ then RET leaves ~)~ at the ~if~'s column, so +the next argument cannot be typed where it belongs. A line inside open brackets, +closer-led or not, goes to the continuation column (aligned after the opening bracket). -** 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 not is a prefix word +Decided 2026-09-26: .fln writes ~not x~ (binding like F#'s ~not~, tighter than +~and~/~or~, looser than comparisons); ~not(x)~ keeps working as a call. ** NEXT A let takes several bindings on indented lines Decided 2026-09-26: lines indented under a ~let~ that are ~name = v~ or ~name: T = v~ are more bindings of the same let; anything else there stays refused. flan convert writes 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 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 diff --git a/bin/main.ml b/bin/main.ml index 0a6184cd..2da76c62 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -226,9 +226,14 @@ let no_gc_flag = "--no-gc" downstream that it ran. *) 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 = [ 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 standard [file:line:col:] shape, with the squiggle [Loc.entry] draws, so @@ -355,6 +360,7 @@ let () = files | _ :: "check" :: args when List.exists (fun a -> not (is_flag a)) args -> 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 List.iter (fun path -> @@ -366,26 +372,28 @@ let () = program that checked, which is what leaves the exit status alone. *) if warn_memory then print_memory_warnings ~file:path p; - List.iter - (fun (g : Flan.Tast.global) -> - Printf.printf "%s %s %s\n" - (* The three defining forms, told apart the way the compiler - tells them apart: [gconst] is the image, and [grerun] is - what a re-run does to the storage. A listing that called - both mutable forms one name could not answer the question - someone runs [flan check] on a dev file to ask. *) - (if g.gconst then "defconst" - else if g.grerun then "def" else "defonce") - g.gname (Flan.Types.to_string g.gty)) - p.globals; - List.iter - (fun (f : Flan.Tast.fn) -> - if not (Flan.Check.internal_name f.name) then - Printf.printf "defn %s : (Fn [%s] %s) %d slots\n" f.name - (String.concat " " - (List.map Flan.Types.to_string f.params)) - (Flan.Types.to_string f.ret) (Array.length f.slots)) - p.fns)) + if defs then begin + List.iter + (fun (g : Flan.Tast.global) -> + Printf.printf "%s %s %s\n" + (* The three defining forms, told apart the way the compiler + tells them apart: [gconst] is the image, and [grerun] is + what a re-run does to the storage. A listing that called + both mutable forms one name could not answer the question + someone runs [flan check] on a dev file to ask. *) + (if g.gconst then "defconst" + else if g.grerun then "def" else "defonce") + g.gname (Flan.Types.to_string g.gty)) + p.globals; + List.iter + (fun (f : Flan.Tast.fn) -> + if not (Flan.Check.internal_name f.name) then + Printf.printf "defn %s : (Fn [%s] %s) %d slots\n" f.name + (String.concat " " + (List.map Flan.Types.to_string f.params)) + (Flan.Types.to_string f.ret) (Array.length f.slots)) + p.fns + end)) files (* 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 @@ -982,7 +990,7 @@ let () = | None -> code)) | _ -> prerr_endline - "usage: flan (read|parse|check|emit|shim) ...\n flan check ... [--warn-memory]\n flan emit [--x86] [--dev] [--debug] [--no-bounds-checks]\n\ + "usage: flan (read|parse|check|emit|shim) ...\n flan check ... [--warn-memory] [--defs]\n flan emit [--x86] [--dev] [--debug] [--no-bounds-checks]\n\ \ flan import-c [package.flan...] [clang flags...]\n\ \ flan generate-c \n\ \ flan build [-o out] [-O0|-O1|-O2|-O3] \ diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index 0814dafc..a92bdc6c 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -1205,7 +1205,7 @@ Use `C-c C-g` if you need frames. | `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-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 | | `C-c <` / `C-c >` | `<` / `>` | shift the region's lines a level | | `M-` / `M-` | same | move the statement past its neighbour | diff --git a/emacs/flan-fln-mode.el b/emacs/flan-fln-mode.el index 7e538382..ca652587 100644 --- a/emacs/flan-fln-mode.el +++ b/emacs/flan-fln-mode.el @@ -83,8 +83,14 @@ fine here. Brackets and strings are still paired." (defconst flan-fln--clause-words '("else" "elif" "on" "restart") "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 - "\\(else\\|elif\\|on\\|restart\\)\\(?:[ \t]\\|$\\)") + (concat "\\(else\\|elif\\|on\\|restart\\)" flan-fln--word-end-re)) (defconst flan-fln--clause-headers '(("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" "if" "elif" "else" "while" "until" "for" "match" "let" "return" "break" "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 ;; `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 '("fn" "fn-" "struct" "union" "data" "enum" "if" "elif" "else" "while" "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 '(("fn" . "defn") ("fn-" . "defn-") ("def" . "def") ("once" . "defonce") ("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.") ;;; Syntax @@ -324,15 +334,16 @@ depth, outside strings and comments, or nil." (defun flan-fln--value-opens-p (l) "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 -a lambda header. These are the values lib/indent_reader.ml's `value_line' -reads a block for, besides a bare `=' and a call ending in `:'." +`= match x', `= if c' with no `then', `= handler-case', `= restart-case', +`= loop i = 0', or a lambda header. These are the values +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)) (end (flan-fln--joined-end l))) (and v (< v end) (save-excursion (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))) (flan-fln--lambda-header-p v end)))))) @@ -602,7 +613,7 @@ the form." (defun flan-fln--declaration-head-at (pos &optional heads) "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 -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, `flan--declaration-heads' by default." (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'. 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." - (save-excursion (goto-char (flan-fln--first-char start)) - (looking-at "let[ \t]"))) + (and (> (flan-fln--indent-at start) 0) + (save-excursion (goto-char (flan-fln--first-char start)) + (looking-at "let[ \t]")))) (defun flan-fln--block-rest (start) "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) (back-to-indentation) (and (looking-at (concat (regexp-opt flan-fln--opener-words t) - "\\(?:[ \t]\\|$\\)")) + flan-fln--word-end-re)) (let* ((w (match-string-no-properties 1)) (w-end (match-end 1)) (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 ;; `else x' after an if's block is the whole else. ((member w '("defer" "quote" "else")) alone) - ((member w '("fn" "fn-")) + ((member w '("fn" "fn-" "multi" "method")) (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))) (t t))))) ;; `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))) (or (looking-back ":" 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. (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(){},;\":]+\\)" "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) "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." @@ -1554,13 +1594,36 @@ lambda or a `Fn(...)' type, and not after a match arm's." (defvar flan-fln-font-lock-keywords `(;; 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. - (,(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) - (,(concat "^\\(fn-?\\)[ \t]+" flan-fln--name-re) + (,(concat "^\\(fn-?\\|macro\\|generic\\|multi\\|method\\)[ \t]+" flan-fln--name-re) 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) - (,(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) ;; A restart clause's name, `restart retry() "Try again"'. (,(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'.") (defvar flan-fln-imenu-generic-expression - `(("Functions" ,(concat "^fn-?[ \t]+" flan-fln--name-re) 1) - ("Macros" ,(concat "^defmacro(" flan-fln--name-re) 1) - ("Types" ,(concat "^\\(?:struct\\|data\\|union\\|enum\\)[ \t]+" flan-fln--name-re) 1) - ("Variables" ,(concat "^\\(?:def\\|once\\|const\\)[ \t]+" flan-fln--name-re) 1)) + `(("Functions" ,(concat "^\\(?:fn-?\\|generic\\|multi\\|method\\)[ \t]+" flan-fln--name-re) 1) + ("Functions" ,(flan-fln--fallback-re flan-fln--fallback-function-heads) 2) + ("Macros" ,(concat "^\\(?:macro[ \t]+\\|defmacro(\\)" 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'.") (defun flan-fln-current-defun-name () @@ -1605,7 +1671,7 @@ lambda or a `Fn(...)' type, and not after a match arm's." (when s (save-excursion (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)) (match-string-no-properties 1)))))) diff --git a/emacs/test-flan-fln-live.el b/emacs/test-flan-fln-live.el index 5c36ff93..28576aa0 100644 --- a/emacs/test-flan-fln-live.el +++ b/emacs/test-flan-fln-live.el @@ -85,6 +85,55 @@ fn dir(d: Dir) -> i64 Dir.north -> 7 _ -> 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(): if 1 < 2 and 3 < 4 @@ -209,12 +258,48 @@ comment(): ("fn size" "(size 20)" "2") ("fn lam" "(lam 3)" "7") ("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) (flan-fln-eval-defun) (test-flan--check (funcall name (format "C-c C-c installs %s" needle)) (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 ;; answers `:pause' only when a form the reader made starts exactly ;; 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") ("Dir.north" "an enum member's arm, 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)) (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" diff --git a/emacs/test-flan-fln.el b/emacs/test-flan-fln.el index 10721aaf..50ba7673 100644 --- a/emacs/test-flan-fln.el +++ b/emacs/test-flan-fln.el @@ -203,7 +203,7 @@ fn step() -> () (test-flan-fln--is "before any form, the next one" (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" (save-excursion (beginning-of-defun) (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 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--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" (font-lock-ensure) (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--tabs "rl/with-drawing():\n|" 1) 2) (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--tabs "fn f() -> i32 = 1\n|" 1) 0) (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: i64, b) -> i64" "a typed lambda header") ("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"))) (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--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--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--tabs "fn f(x) = match x\n|" 1) 2) (test-flan-fln--is "no deeper after a one-line else" diff --git a/lib/indent_printer.ml b/lib/indent_printer.ml index 0214b69a..93867f51 100644 --- a/lib/indent_printer.ml +++ b/lib/indent_printer.ml @@ -499,10 +499,15 @@ let rec ty (f : Form.t) = primitive, a capitalised or [$] name, or a bracket. [[x y]] with a lowercase [y] keeps the fallback, because what it means depends on 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) = match f.v with | Form.Sym 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 | _ -> false @@ -544,7 +549,17 @@ let lead_word text = (* A statement whose text leads with a reserved word, parenthesised. *) let guard text = 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) = match f.v with @@ -771,6 +786,9 @@ and value_lines n prefix (v : Form.t) = | _ -> false in 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 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) +(* [(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 | ({ Form.v = Form.Kw k; _ }) :: rest when kw_ok k -> (":" ^ k ^ " ", 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); _ } :: { v = Form.Sym name; _ } :: rest) 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 (match d, rest with + | "def", _ when n > 0 -> None | "defconst", [ v ] -> Some (value_lines n (w ^ " " ^ name) v) | "defconst", [ t; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v) | "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; v ] -> Some (value_lines n (w ^ " " ^ name ^ ": " ^ ty t) v) | _ -> None) - | Form.List [ { v = Form.Sym (("defstruct" | "defunion") as d); _ }; - { v = Form.Sym name; _ }; { v = Form.Vec fs; _ } ] + | Form.List ({ v = Form.Sym "loop"; _ } :: _) when loop_head f <> None -> + 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 -> + (* 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 + | _ when one <> None -> one | Some prs when List.for_all (fun ((f : Form.t), _) -> match f.v with Form.Sym x -> def_name x | _ -> false) prs -> Some - ((i ^ (if d = "defstruct" then "struct " else "union ") ^ name) + ((i ^ (if d = "defstruct" then "struct " else "union ") ^ name ^ parent) :: List.map (fun ((f : Form.t), t) -> 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)) prs) | _ -> 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; _ } ] when def_name name -> 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 +(* 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 = let clause (c : Form.t) = 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. *) let program ?source ?macros:m (fs : Form.t list) : string = 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 := (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 @@ -1089,8 +1249,8 @@ let program ?source ?macros:m (fs : Form.t list) : string = (fun (c : Source_text.comment) -> f.loc.Loc.line <= c.line && c.line < f.loc.Loc.eline) cs); - (* A flat [let] at the top level would take in the forms after it, so one - that is not last goes in a [do:] block. *) + (* A [let] at the top level is a global, so a local one goes in a [do:] + block. *) let top x = Hashtbl.reset used; Hashtbl.reset made; @@ -1099,7 +1259,6 @@ let program ?source ?macros:m (fs : Form.t list) : string = in let rec go = function | [] -> [] - | [ x ] -> [ (x, top x) ] | x :: rest -> (x, top (if let_sugar x then in_do x else x)) :: go rest in let text = @@ -1108,6 +1267,7 @@ let program ?source ?macros:m (fs : Form.t list) : string = in spelling := (fun _ -> None); inside := (fun _ -> false); + classes := []; (* With the source, its comments go back where they were; without it the tags come out and nothing goes in. *) Source_text.weave ~starts:(Source_text.form_starts fs) diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index 4aaa75f0..7c007aea 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -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 | _ -> 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 n = peek_at p 1 in + (not (assigns p)) && let plain_name = function | NAME x -> not (is_op_word x || x = "=" || List.mem_assoc x assign_ops) | _ -> false @@ -1066,6 +1073,26 @@ let header_follow p s = let a = peek_at p 2 in a.tok = LP && not a.sp | _ -> 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) | "break" | "continue" -> n.tok = NEWLINE || (n.sp && (match n.tok with KW _ -> true | _ -> false)) @@ -1122,6 +1149,28 @@ let params p (lp : token) = in 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 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 @@ -1209,7 +1258,7 @@ and value_line ?(block_ok = false) (s : st) ~after : Form.t = match (peek p).tok with (* [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. *) - | 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 -> header s w | 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 match t.tok with | 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 -> failk "orphan-else" t.loc "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-") (name :: Form.make (Form.Vec ps) lp.loc :: ret :: (where_clause @ body)) | "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 tyf = match (peek p).tok with @@ -1483,7 +1536,7 @@ and header (s : st) w : Form.t = match (peek p).tok with | NAME "=" -> 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); None @@ -1491,6 +1544,18 @@ and header (s : st) w : Form.t = let head = match w with "def" -> "def" | "once" -> "defonce" | _ -> "defconst" 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 = match w, tyf, v with | "const", None, Some v -> [ name; v ] @@ -1505,13 +1570,39 @@ and header (s : st) w : Form.t = failk "def-empty" l0 "%s %s names neither a type nor a value. Give it one or both: %s %s: \ i32 = 0" - w (text_of name) w (text_of name) + shown (text_of name) shown (text_of name) in named head items | "struct" | "union" -> 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 = + match inline with + | Some fs -> expect_eol p ~after; fs + | None -> + expect_eol_block p ~after; lines s (fun () -> let f = name_tok p ~what:"a field's name" in let tf = @@ -1522,8 +1613,196 @@ and header (s : st) w : Form.t = expect_eol p ~after:(text_of tf); [ f; tf ]) 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") - [ 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" -> let name = name_tok p ~what:"the type's name" in 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 rec elifs acc = match (peek p).tok with - | NAME "elif" -> + | NAME "elif" when not (assigns p) -> ignore (advance p); let c, _ = binary p 1 in (match (peek p).tok with @@ -1600,7 +1879,7 @@ and header (s : st) w : Form.t = let els_ = elifs [] in let else_ = match (peek p).tok with - | NAME "else" -> + | NAME "else" when not (assigns p) -> let et = advance p in (match (peek p).tok with | 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 rec clauses acc = 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 head, _ = postfix p in let ty, var = @@ -1777,7 +2056,7 @@ and header (s : st) w : Form.t = let body = block s ~after:w in let rec clauses acc = 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); let name = name_tok p ~what:"the restart's name" 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 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 col = Option.value col ~default:1 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 () -> let toks = layout ~snippet ~base:col ?indent (lex ~line ~col ~file src) 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 | EOF -> () | tk -> failk "unexpected-token" (where_ s.p) "unexpected %s" (show tk)); diff --git a/lib/source.ml b/lib/source.ml index 48966744..ba670faf 100644 --- a/lib/source.ml +++ b/lib/source.ml @@ -72,9 +72,11 @@ let read_paren ?(line = 1) ?(col = 1) ~file src = in go [] -(** Editor code, in the request's syntax and at its position. With [expr], an - indented snippet of several statements is one expression, [(do ...)]: a - block of lines means its lines in order. *) +(** Editor code, in the request's syntax and at its position. With [expr], + an indented snippet of several statements is one expression, + [(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 line, col = 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 | Paren -> read_paren ~line ~col ~file code | 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 -> let last = List.nth forms (List.length forms - 1) in let loc = diff --git a/spec-syntax.md b/spec-syntax.md index ca66d31e..0f1f0381 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -284,20 +284,45 @@ Each item: the proposal, then the reason in one line. becomes `where ordered?($t)` after the return type. **Built**; with no `-> R` the return is `_`, read off the body. Several predicates are `where p, q`. -- `def x = v`, `def x: T = v`, `once x: T`, `once x = v`, `const n = 3`, - `def scratch: [4 u8] = uninit`. **Built.** `def x = v` and `once x = v` read - with `dyn`; `const n = 3` reads `(defconst n 3)`, its type inferred as today. +- A `let` at the top level is a global: `let x = v`, `let x: T = v`, + `let scratch: [4 u8] = uninit` read `(def x dyn v)`, `(def x T v)`; + `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 case: `Circle(r: f32)`, `Empty`. `enum K` with `lo = -1`, `mid`. `union U` like `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 - 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.** - **Every other form uses the fallback** (next item) until someone asks for - sugar: `defclass`, `defgeneric`, `defmulti`, `defmethod`, `declare`, - `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. + sugar: `declare`, `declare-c`, `array-fill`. **Built.** ### The fallback @@ -321,7 +346,7 @@ value, `vec-new(Fn([i32], i32))` is the call spelling). ### Macro templates ``` -defmacro(with-mode-2d, [camera & body]): +macro with-mode-2d(camera, & body) quote begin-mode-2d(~camera) ~@body diff --git a/test/syntax/handwritten/csv.fln b/test/syntax/handwritten/csv.fln index 7aa9f652..e5de89b4 100644 --- a/test/syntax/handwritten/csv.fln +++ b/test/syntax/handwritten/csv.fln @@ -8,11 +8,11 @@ enum State quote-in-quoted once rows-seen: i32 -def fields-seen: i32 = 0 +let fields-seen: i32 = 0 const separator = \, ; Frame the body's output with a title line and a closing rule. -defmacro(with-section, [title & body]): +macro with-section(title, & body) quote println("--", ~title, "--") ~@body diff --git a/test/syntax/handwritten/inventory.fln b/test/syntax/handwritten/inventory.fln index 94bcd51c..c76e21be 100644 --- a/test/syntax/handwritten/inventory.fln +++ b/test/syntax/handwritten/inventory.fln @@ -8,24 +8,24 @@ struct Rule label: str applies: CFn(stock/Item) -> bool -def report-width: i32 = 28 +let report-width: i32 = 28 once runs: i32 const reorder-below = 5 ; Run the body n times, counting passes in the name given. -defmacro(repeat, [i n & body]): +macro repeat(i, n, & body) quote for ~i in range(~n) ~@body ; Say what went wrong when a check does not hold. -defmacro(expect, [test message]): +macro expect(test, message) quote if not ~test println("expected:", ~message) 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) fn line(it: stock/Item) -> () diff --git a/test/syntax/handwritten/ledger.fln b/test/syntax/handwritten/ledger.fln index bea43893..02ba52ef 100644 --- a/test/syntax/handwritten/ledger.fln +++ b/test/syntax/handwritten/ledger.fln @@ -2,11 +2,11 @@ ; 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. -defstruct(Overdraft, :parent, Error, [account i32 short i64]) - -struct Audit +struct Overdraft :parent Error account: i32 - amount: i64 + short: i64 + +struct Audit(account: i32, amount: i64) once balances: [4 i64] once audits: i32 diff --git a/test/syntax/handwritten/lisp.fln b/test/syntax/handwritten/lisp.fln index 9b7c8743..6e4ab048 100644 --- a/test/syntax/handwritten/lisp.fln +++ b/test/syntax/handwritten/lisp.fln @@ -2,22 +2,21 @@ ; first element is a keyword naming the operation, variables are keywords, ; 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" -defmulti(kind, [v], dyn, type-of(v)) +multi kind(v) -> dyn = type-of(v) -defmethod(kind, :int, [v]): +method kind(v) when :int "number" -defmethod(kind, :vec, [v]): - "form" +method kind(v) when :vec = "form" -defmethod(kind, :else, [v]): +method kind(v) when :else "value" once steps = 0 diff --git a/test/syntax/sand.fln b/test/syntax/sand.fln index 00c5bd9c..6a63d6fe 100644 --- a/test/syntax/sand.fln +++ b/test/syntax/sand.fln @@ -15,8 +15,8 @@ const brush-size = 10 fn dyn->f64(v: f64) -> f64 = v fn dyn->u32(v: i64) -> u32 = u32(v) -def gravity = 0.05 -def colors = +let gravity = 0.05 +let colors = let v = vec-new(dyn) push(v, 0xFFF00FFF) push(v, 0x3B6E8CFF) @@ -121,7 +121,7 @@ fn game-draw() -> () rl/draw-fps(20, 20) once frame: Allocator = arena-new(262144) -def game-data = +let game-data = handler-case edn/read-file("game-data.edn") on FileError(c) diff --git a/test/test_acceptance.ml b/test/test_acceptance.ml index ab9f246b..84df81db 100644 --- a/test/test_acceptance.ml +++ b/test/test_acceptance.ml @@ -7379,6 +7379,14 @@ level "1" cli_case "check on a file that is not there" "check no-such-file.flan" ~code:1 ~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 one wrapper they all go through. *) cli_case "build on a file that is not there" diff --git a/test/test_syntax.ml b/test/test_syntax.ml index 1b3843a1..3427a6e1 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -411,17 +411,19 @@ let () = (* ── Lexical edge cases ────────────────────────────────────────────── *) -let read src = Indent_reader.read_all ~file:"" 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:"" src -let reads name src want = - match read src with +let reads ?global name src want = + match read ?global src with | forms -> 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 | exception e -> fail "%s: refused: %s" name (diag_text e) -let refuses name src kind needle = - match read src with +let refuses ?global name src kind needle = + match read ?global src with | forms -> fail "%s: read %s, wanted the refusal %s" name (String.concat " " (List.map Form.to_string forms)) kind @@ -462,7 +464,7 @@ let () = reads "character literals" "x = [\\( \\, \\space \\)]" "(set x [\\( \\, \\space \\)])"; reads "character arguments" "f(\\,, \\))" "(f \\, \\))"; (* 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 "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"; @@ -521,8 +523,8 @@ let () = (* Statements. *) 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)))"; - refuses "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)"; + refuses ~global:false "let with a block" "let a = 1\n a\nb" "indent/let-block" "go at the let's column"; + 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 "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))"; @@ -553,7 +555,63 @@ let () = "(defdata Shape [(Circle [r f32]) Empty])"; 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 "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. *) 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)))"; @@ -569,9 +627,9 @@ let () = 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 "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 "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 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 if" "let q = if a\n 1\nelse\n 2\nq" "(let [q (if a 1 2)] q)"; + 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 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"; @@ -583,7 +641,7 @@ let () = refuses "mixed separators" "x = [1 2, 3]" "indent/mixed-separators" "[1, 2, 3]"; reads "one-line quote" "defmacro(m, [x]):\n quote ~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)" "indent/let-block" "go at the let's column"; (* Mistakes carried over from other languages, answered in this one. *) @@ -612,7 +670,7 @@ let () = "indent/orphan-else" "goes at the if's column"; 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))))"; - 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))"; refuses "a typed lambda states its return type" "f = fn(a: C) = a" "indent/lambda-return" "fn(a: C) -> R = value"; @@ -796,9 +854,9 @@ let () = "restart retry() \"Try again\"\n 7"; prints "adjacent one-line globals stay adjacent" "(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" - "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)"; 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" @@ -807,7 +865,42 @@ let () = 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"; 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 ──────────────────────── *) diff --git a/web/examples/quotes.sh b/web/examples/quotes.sh index 630157fd..631bf749 100644 --- a/web/examples/quotes.sh +++ b/web/examples/quotes.sh @@ -81,10 +81,9 @@ do name=${pair%%:*}; src=${pair#*:} printf '%s\n' "$src" > "$here/.q.flan" out=$("$FLAN" check "$here/.q.flan" 2>&1) - # A probe that compiles is the failure this loop is most likely to meet, and - # it is the one that used to be unreadable: `flan check` answers a clean - # program with its whole symbol table, so the needle became eighty lines of - # prelude signatures and the diff said nothing. Say what actually happened. + # A probe that compiles is the failure this loop is most likely to meet: + # `flan check` prints nothing for it, so the needle would be empty and the + # diff would say nothing. Say what actually happened. if "$FLAN" check "$here/.q.flan" >/dev/null 2>&1; then echo "FAIL message: $name" echo " this program compiles now — the page still says it is refused"