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

Merge branch 'master' into worktree-agent-a9ad2e8b56d1fbd10

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 21:18:18 +07:00
commit bd70dfa913
24 changed files with 3472 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
TODO.org
View File

@ -296,6 +296,15 @@ keyword resolves against the expected type and against nothing else, so two enum
could always share a member spelling. What the prefix buys is the call site read could always share a member spelling. What the prefix buys is the call site read
on its own. on its own.
** WAIT ML-style patterns
Held 2026-09-25 as a future direction, like the JS backend: nested destructuring,
guards, or-patterns, literals at any depth, exhaustiveness over the nesting.
** DONE match over numbers and strings
CLOSED: [2026-09-25]
Rules out a literal the scrutinee's type cannot hold (refused, not widened as =(=)=
would), keyword arms over a dyn, and a bare-name catch-all: a bare name is a nullary case.
** DONE match over enums ** DONE match over enums
CLOSED: [2026-09-25] CLOSED: [2026-09-25]
=Ast.Pkw= is the keyword pattern; =Check.check_match= resolves it against the =Ast.Pkw= is the keyword pattern; =Check.check_match= resolves it against the

49
emacs/MANUAL.md
View File

@ -1187,6 +1187,54 @@ Use `C-c C-g` if you need frames.
--- ---
## Indented files (.fln)
`.fln` files open in `flan-fln-mode`. The session keys (`C-c C-b`, `C-c C-i`,
`C-c C-k`, the REPL, watch, dape) work as in a `.flan` file; these differ.
| Holy | Evil | Does |
|---|---|---|
| `C-c C-c`, `C-M-x` | same | the top-level form: a declaration installed, anything else evaluated |
| `C-u C-c C-c` | same | ...and stop at the innermost bracket group, else the statement on point's line: an elif's condition, an else's block, a match arm's value (`C-u C-u`: on entry) |
| `C-x C-e` | same, cursor on the line's last character | at a line's end, the innermost statement ending there: a match arm's value, an if/elif/while condition, or the whole statement a header or clause line opens; elsewhere, the term before point |
| `C-c C-e` | same | the statement at point with its body and clauses, or the region's whole lines; on a bare `let x = v`, the `let` and the rest of its block |
| `C-c C-n` | same | `C-c C-e`, then move to the next statement |
| `C-c C-s` | same | step through the top-level `fn` at point |
| `C-c C-k` | same | the whole buffer |
| `C-M-a` / `C-M-e` / `C-M-h` | `[[` / `]]` | top-level form: start, end, mark |
| `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 |
| `DEL` in indentation | same | drop one level |
| `C-c <` / `C-c >` | `<` / `>` | shift the region's lines a level |
| `M-<up>` / `M-<down>` | same | move the statement past its neighbour |
| `M-<right>` / `M-<left>` | same | pull the next statement into this block / push its last one out |
| `M-r` | same | replace the block's owner with the statement at point |
| `M-k` | `das` | kill the statement's lines |
| — | `ie` `ae` | term |
| — | `is` `as` | statement (`as`: whole lines) |
| — | `ii` `ai` | body / whole statement |
| — | `ik` `ak` | clause's block / clause |
| — | `id` `ad` | top-level form with the comment block directly above it (`ad`: and the empty lines after it, or before it for the last form) |
`else`, `elif`, `on` and `restart` snap to their header's column as you type
them. `indent-region` and `C-y` move lines only as a block, never one line
against another. expand-region steps term, group, statement, clause,
enclosing statement, top-level form.
- **term**: a run with no space outside brackets — `f(a, b)`, `grid[r, c]`, `p.x`.
- **group**: a bracket pair and what is inside it.
- **statement**: a line, the deeper lines under it, lines inside brackets it leaves open, lines an operator continues, and `else`/`elif`/`on`/`restart` at its column. Blank and comment lines inside never end it.
- **body**: a statement's own block, up to its first clause.
- **clause**: one `else`/`elif`/`on`/`restart` line and its block.
- **top-level form**: a column-0 line that is code, not a clause and not a continuation, through the last code line before the next one.
`flan-fln-indent-offset` (2) is one level. `flan-fln-smartparens` (`t`) turns
on plain `smartparens-mode`, which pairs brackets and strings but not `'`.
---
## Full key reference ## Full key reference
| Key | Does | | Key | Does |
@ -1267,6 +1315,7 @@ fix is to delete `-dev` from it.
| File | What it is | | File | What it is |
|---|---| |---|---|
| `flan-mode.el` | the major mode: syntax, indentation, imenu, the keymap | | `flan-mode.el` | the major mode: syntax, indentation, imenu, the keymap |
| `flan-fln-mode.el` | the mode for indented `.fln` files: objects, keys, indentation |
| `flan.el` | the client — the socket, evaluation, xref, eldoc, completion | | `flan.el` | the client — the socket, evaluation, xref, eldoc, completion |
| `flan-repl.el` | the `*flan-repl*` buffer | | `flan-repl.el` | the `*flan-repl*` buffer |
| `flan-watch.el` | watched values: the program pushes, this paints them in a buffer and inline | | `flan-watch.el` | watched values: the program pushes, this paints them in a buffer and inline |

12
emacs/flan-dape.el
View File

@ -89,14 +89,14 @@ does and does not buy."
:type '(repeat string)) :type '(repeat string))
(defun flan-dape--source () (defun flan-dape--source ()
"The .flan file this session is about. "The .flan or .fln file this session is about.
The buffer's own file, or the nearest one up from it — so M-x flan-debug The buffer's own file, or the nearest one up from it — so M-x flan-debug
from a *compilation* buffer or a dired still has an answer." from a *compilation* buffer or a dired still has an answer."
(or (and buffer-file-name (or (and buffer-file-name
(string-suffix-p ".flan" buffer-file-name) (string-match-p "\\.fla?n\\'" buffer-file-name)
buffer-file-name) buffer-file-name)
(car (directory-files default-directory t "\\.flan\\'")) (car (directory-files default-directory t "\\.fla?n\\'"))
(user-error "No .flan file here to debug"))) (user-error "No .flan or .fln file here to debug")))
(defun flan-dape--binary (source) (defun flan-dape--binary (source)
"Where the debug build of SOURCE goes. "Where the debug build of SOURCE goes.
@ -126,7 +126,7 @@ one made by `flan build'."
;; can just read `buffer-file-name'. `dape' itself expects an already ;; can just read `buffer-file-name'. `dape' itself expects an already
;; evaluated config, so `flan-debug' below must not hand it the raw entry. ;; evaluated config, so `flan-debug' below must not hand it the raw entry.
(defconst flan-dape-config (defconst flan-dape-config
'(modes (flan-mode) '(modes (flan-base-mode)
ensure dape-ensure-command ensure dape-ensure-command
command-cwd dape-command-cwd command-cwd dape-command-cwd
compile (flan-dape--compile-command (flan-dape--source)) compile (flan-dape--compile-command (flan-dape--source))
@ -178,7 +178,7 @@ common case is one command rather than a config prompt."
;; thing entirely. ;; thing entirely.
;;;###autoload ;;;###autoload
(with-eval-after-load 'flan-mode (with-eval-after-load 'flan-mode
(define-key (symbol-value 'flan-mode-map) (kbd "C-c C-g") #'flan-debug)) (define-key (symbol-value 'flan-base-mode-map) (kbd "C-c C-g") #'flan-debug))
;;; --dev and --debug are different builds ;;; --dev and --debug are different builds
;; ;;

1715
emacs/flan-fln-mode.el Normal file
View File

File diff suppressed because it is too large Load Diff

57
emacs/flan-mode.el
View File

@ -439,19 +439,16 @@ For `syntax-propertize-function'."
;; not. Either way forward, which is the whole of why this terminates. ;; not. Either way forward, which is the whole of why this terminates.
(goto-char (or fin from))))) (goto-char (or fin from)))))
(defvar flan-mode-map ;; The keys both syntaxes share: everything that talks to the running program
;; about a name, a value or the session rather than about a piece of the text.
;; The keys that pick text out of the buffer -- which form C-c C-c means --
;; are each child mode's own, because what a form is differs between them.
(defvar flan-base-mode-map
(let ((map (make-sparse-keymap))) (let ((map (make-sparse-keymap)))
;; Autoloaded from flan.el, so the client loads on first use. ;; Autoloaded from flan.el, so the client loads on first use.
(define-key map (kbd "C-c C-c") #'flan-eval-defun)
;; The same command on the binding SLIME and CIDER put it on. Emacs binds
;; C-M-x to eval-defun only in `emacs-lisp-mode-map', so a mode derived
;; from `lisp-mode' inherits nothing and the key is undefined — which
;; reads as the client being broken rather than as the key being free.
(define-key map (kbd "C-M-x") #'flan-eval-defun)
(define-key map (kbd "C-c C-k") #'flan-eval-buffer) (define-key map (kbd "C-c C-k") #'flan-eval-buffer)
;; The stepper: the defn at point, installed to stop before each form. ;; The stepper: the defn at point, installed to stop before each form.
(define-key map (kbd "C-c C-s") #'flan-step-defun) (define-key map (kbd "C-c C-s") #'flan-step-defun)
(define-key map (kbd "C-x C-e") #'flan-eval-last-sexp)
(define-key map (kbd "C-c C-z") #'flan-connect) (define-key map (kbd "C-c C-z") #'flan-connect)
(define-key map (kbd "C-c C-q") #'flan-disconnect) (define-key map (kbd "C-c C-q") #'flan-disconnect)
(define-key map (kbd "C-c C-d") #'flan-describe) (define-key map (kbd "C-c C-d") #'flan-describe)
@ -502,23 +499,45 @@ For `syntax-propertize-function'."
;; because it is the one that works from any state. ;; because it is the one that works from any state.
(define-key map (kbd "C-c C-M-x") #'flan-rerun) (define-key map (kbd "C-c C-M-x") #'flan-rerun)
map) map)
"Keymap for every Flan source buffer, `flan-mode' and `flan-fln-mode'.")
(defvar flan-mode-map
(let ((map (make-sparse-keymap)))
(set-keymap-parent map flan-base-mode-map)
(define-key map (kbd "C-c C-c") #'flan-eval-defun)
;; The same command on the binding SLIME and CIDER put it on. Emacs binds
;; C-M-x to eval-defun only in `emacs-lisp-mode-map', so a mode derived
;; from `lisp-mode' inherits nothing and the key is undefined — which
;; reads as the client being broken rather than as the key being free.
(define-key map (kbd "C-M-x") #'flan-eval-defun)
(define-key map (kbd "C-x C-e") #'flan-eval-last-sexp)
map)
"Keymap for `flan-mode'.") "Keymap for `flan-mode'.")
;; The parent of both source modes. Everything the dev loop asks of a buffer
;; -- is this Flan, set up eldoc and completion, draw the program's names,
;; paint watched values -- asks it of this mode, so a .fln buffer gets it the
;; same way a .flan buffer does. What each syntax reads as a form is its
;; child's business.
(define-derived-mode flan-base-mode prog-mode "Flan"
"Parent mode of the Flan source modes, `flan-mode' and `flan-fln-mode'."
(setq-local comment-start ";")
(setq-local comment-start-skip ";+ *")
(setq-local comment-add 1)
;; Spaces. The whole corpus is written with them, and alignment that is
;; correct here is alignment under a specific *column* — a tab makes that
;; depend on a setting the file cannot carry. In a .fln file a tab in the
;; indentation is an error besides.
(setq-local indent-tabs-mode nil))
;;;###autoload ;;;###autoload
(define-derived-mode flan-mode prog-mode "Flan" (define-derived-mode flan-mode flan-base-mode "Flan"
"Major mode for editing Flan. "Major mode for editing Flan.
\\{flan-mode-map}" \\{flan-mode-map}"
:syntax-table flan-mode-syntax-table :syntax-table flan-mode-syntax-table
(setq-local comment-start ";")
(setq-local comment-start-skip ";+ *")
(setq-local comment-add 1)
(setq-local font-lock-defaults '(flan-font-lock-keywords)) (setq-local font-lock-defaults '(flan-font-lock-keywords))
(setq-local indent-line-function #'lisp-indent-line) (setq-local indent-line-function #'lisp-indent-line)
;; Spaces. The whole corpus is written with them, and alignment that is
;; correct here is alignment under a specific *column* — a tab makes that
;; depend on a setting the file cannot carry.
(setq-local indent-tabs-mode nil)
(setq-local lisp-indent-function #'flan-indent-function) (setq-local lisp-indent-function #'flan-indent-function)
(setq-local outline-regexp ";;;;+[ \t]*") (setq-local outline-regexp ";;;;+[ \t]*")
(setq-local imenu-generic-expression flan-imenu-generic-expression) (setq-local imenu-generic-expression flan-imenu-generic-expression)
@ -800,6 +819,12 @@ decision to `calculate-lisp-indent'."
;;;###autoload ;;;###autoload
(add-to-list 'auto-mode-alist '("\\.flan\\'" . flan-mode)) (add-to-list 'auto-mode-alist '("\\.flan\\'" . flan-mode))
;; The indented syntax's mode lives in its own file; a buffer of it is the first
;; thing that loads it.
;;;###autoload
(autoload 'flan-fln-mode "flan-fln-mode" nil t)
;;;###autoload
(add-to-list 'auto-mode-alist '("\\.fln\\'" . flan-fln-mode))
;;; The other Flan buffers under Evil ;;; The other Flan buffers under Evil

10
emacs/flan-watch.el
View File

@ -249,15 +249,19 @@ inline it has no modeline beside it to say so.")
(let (bufs) (let (bufs)
(dolist (w (window-list-1 nil 'nomini t)) (dolist (w (window-list-1 nil 'nomini t))
(let ((b (window-buffer w))) (let ((b (window-buffer w)))
(when (and (eq (buffer-local-value 'major-mode b) 'flan-mode) (when (and (provided-mode-derived-p (buffer-local-value 'major-mode b)
'flan-base-mode)
(not (memq b bufs))) (not (memq b bufs)))
(push b bufs)))) (push b bufs))))
bufs)) bufs))
(defun flan-watch--ghost-sites () (defun flan-watch--ghost-sites ()
"Watch call sites in the current buffer, as a list of (NAME . END-OF-LINE)." "Watch call sites in the current buffer, as a list of (NAME . END-OF-LINE)."
(let ((re (concat "(\\s-*" flan-watch-ghost-call-regexp ;; Either syntax: `(watch "name" v)' in a .flan file, `watch("name", v)' in
"\\s-+\"\\([^\"\n]*\\)\"")) ;; a .fln one, where the call is the name glued to its parenthesis.
(let ((re (concat "\\(?:(\\s-*\\(?:" flan-watch-ghost-call-regexp "\\)\\s-+"
"\\|\\_<\\(?:" flan-watch-ghost-call-regexp "\\)(\\s-*\\)"
"\"\\([^\"\n]*\\)\""))
(sites nil)) (sites nil))
(save-excursion (save-excursion
(goto-char (point-min)) (goto-char (point-min))

15
emacs/flan.el
View File

@ -986,7 +986,7 @@ refuses: callers cannot silently discard a running program's state."
;; buffer is not what you meant — and it still only changes what is asked, ;; buffer is not what you meant — and it still only changes what is asked,
;; never which file the unasked case picks. ;; never which file the unasked case picks.
(let ((file (and buffer-file-name (let ((file (and buffer-file-name
(string-suffix-p ".flan" buffer-file-name) (string-match-p "\\.fla?n\\'" buffer-file-name)
(expand-file-name buffer-file-name)))) (expand-file-name buffer-file-name))))
(list (if (and file (not current-prefix-arg)) (list (if (and file (not current-prefix-arg))
file file
@ -1176,7 +1176,7 @@ the state with something to answer in it."
(defun flan-mode-line () (defun flan-mode-line ()
"The Flan connection indicator, for `mode-line-misc-info'." "The Flan connection indicator, for `mode-line-misc-info'."
(when (derived-mode-p 'flan-mode 'flan-repl-mode) (when (derived-mode-p 'flan-base-mode 'flan-repl-mode)
(pcase (flan-state) (pcase (flan-state)
;; First, and it names the condition: a stopped program looks exactly ;; First, and it names the condition: a stopped program looks exactly
;; like a running one from anywhere else in Emacs, and the whole reason ;; like a running one from anywhere else in Emacs, and the whole reason
@ -2141,7 +2141,7 @@ Leaves its face in `flan--dynamic-face' for the rule that calls this."
(defun flan--dynamic-install () (defun flan--dynamic-install ()
"Add or remove the dynamic rules in the current buffer, and redraw it. "Add or remove the dynamic rules in the current buffer, and redraw it.
Called for its effect on one buffer; `flan--dynamic-sync' does every buffer." Called for its effect on one buffer; `flan--dynamic-sync' does every buffer."
(when (derived-mode-p 'flan-mode) (when (derived-mode-p 'flan-base-mode)
;; Removed first in both branches, because adding is not idempotent: a ;; Removed first in both branches, because adding is not idempotent: a
;; second install would put the rule in twice and every refresh after that ;; second install would put the rule in twice and every refresh after that
;; would add another. ;; would add another.
@ -2160,7 +2160,7 @@ Called for its effect on one buffer; `flan--dynamic-sync' does every buffer."
;; A file opened while a session is already up: the two moments the table is ;; A file opened while a session is already up: the two moments the table is
;; rebuilt are both in the past by then, so the buffer has to ask on its way in. ;; rebuilt are both in the past by then, so the buffer has to ask on its way in.
(add-hook 'flan-mode-hook #'flan--dynamic-install) (add-hook 'flan-base-mode-hook #'flan--dynamic-install)
(defun flan--forget-defs () (defun flan--forget-defs ()
"Drop what is known about the program's names." "Drop what is known about the program's names."
@ -2447,14 +2447,14 @@ someone editing Flan with no program running and this file never loaded."
(setq-local mode-line-misc-info (setq-local mode-line-misc-info
(append mode-line-misc-info '((:eval (flan-mode-line))))))) (append mode-line-misc-info '((:eval (flan-mode-line)))))))
(add-hook 'flan-mode-hook #'flan-setup) (add-hook 'flan-base-mode-hook #'flan-setup)
;; Buffers that were already in flan-mode when this file loaded: the client is ;; Buffers that were already in flan-mode when this file loaded: the client is
;; autoloaded on first use, so by the time it arrives the file being edited has ;; autoloaded on first use, so by the time it arrives the file being edited has
;; long since had its mode hooks run. ;; long since had its mode hooks run.
(dolist (b (buffer-list)) (dolist (b (buffer-list))
(with-current-buffer b (with-current-buffer b
(when (derived-mode-p 'flan-mode) (flan-setup)))) (when (derived-mode-p 'flan-base-mode) (flan-setup))))
;;; Evaluating ;;; Evaluating
@ -2667,7 +2667,8 @@ columns already were, because a top-level form starts at column 1."
.fln file, the paren reader's for anything else. Sent explicitly because the .fln file, the paren reader's for anything else. Sent explicitly because the
daemon cannot tell from `:file' — an expansion shown in parens is sent back daemon cannot tell from `:file' — an expansion shown in parens is sent back
under the name of the .fln file it came from." under the name of the .fln file it came from."
(if (and buffer-file-name (string-suffix-p ".fln" buffer-file-name)) (if (or (derived-mode-p 'flan-fln-mode)
(and buffer-file-name (string-suffix-p ".fln" buffer-file-name)))
"indented" "indented"
"paren")) "paren"))

5
emacs/test-flan-cider.el
View File

@ -2052,6 +2052,11 @@ stopped program, which is the case where it should fire."
(file-name-directory load-file-name)) (file-name-directory load-file-name))
nil t) nil t)
;; The .fln mode: its objects, keys, indentation and text objects, from text.
(load (expand-file-name "test-flan-fln.el"
(file-name-directory load-file-name))
nil t)
;; Ghost text, which is the same kind of thing: rows in, overlays out, and the ;; Ghost text, which is the same kind of thing: rows in, overlays out, and the
;; buffer it reads is a fixture like any other reply here. Loaded for the same ;; buffer it reads is a fixture like any other reply here. Loaded for the same
;; reason. ;; reason.

250
emacs/test-flan-fln-live.el Normal file
View File

@ -0,0 +1,250 @@
;;; test-flan-fln-live.el --- The .fln keys against a real daemon -*- lexical-binding: t; -*-
;; Loaded by test-flan.el, near its end, with `flan-command' already the
;; compiler under test. test-flan-fln.el checks which text each key picks;
;; this checks the reader accepts that text as a whole form, on both backends:
;; a daemon of its own on a .fln file with no main, once on x86 and once on
;; LLVM, each key sent at least once, and a pause mark the daemon must find.
;;; Code:
(require 'flan-fln-mode)
(declare-function test-flan--check "test-flan" (name ok))
(declare-function test-flan--result "test-flan" ())
(defvar test-flan-fln-live-dir)
(defvar test-flan-fln-live-socket)
(defconst test-flan-fln-live--program
"fn fib(n: i64) -> i64
if n < 2
n
else
fib(n - 1) + fib(n - 2)
fn twice(n: i64) -> i64 = n * 2
fn total(n: i32) -> i32
let t = 0
for i in range(n)
t = t + i
t
fn sign(n: i64) -> i64
if n < 0
-1
elif n == 0
0
else
1
enum Dir
north
south
east
fn pick(d: Dir) -> i64
match d
:north -> 10
:south -> 20
:east -> 1 +
2
_ ->
twice(3)
comment():
if 1 < 2 and
3 < 4
twice(1)
elif 1 > 2 or
3 > 4
0
twice(4)
if 2 > 1
twice(2)
else
0
let x = 3
twice(x) + 1
")
(defun test-flan-fln-live--run (backend args)
(let* ((sock (concat test-flan-fln-live-socket "-fln-" backend))
(file (expand-file-name (format "fln-live-%s.fln" backend)
test-flan-fln-live-dir))
(flan-daemon-args args)
(name (lambda (s) (format "%s: %s" backend s)))
(value (lambda (code)
(plist-get (flan--request
(list :op "eval-expr" :code code :file "<test>"))
:value)))
(goto (lambda (needle &optional after)
(goto-char (point-min))
(search-forward needle)
(unless after (goto-char (match-beginning 0)))))
(shows (lambda (v)
(let ((r (test-flan--result)))
(prog1 (and r (string-match-p (concat "=> " (regexp-quote v) "\\'")
(string-trim r)))
(flan-clear-result))))))
(with-temp-file file (insert test-flan-fln-live--program))
(ignore-errors (delete-file sock))
(flan file sock)
(test-flan--check (funcall name "a daemon starts on a .fln file")
(process-live-p flan--connection))
(unwind-protect
(with-current-buffer (find-file-noselect file)
(test-flan--check (funcall name "which opens in flan-fln-mode")
(eq major-mode 'flan-fln-mode))
;; C-c C-c, from inside a fn changed in the buffer.
(funcall goto "n * 2")
(delete-char 5)
(insert "n * 3")
(flan-fln-eval-defun)
(test-flan--check (funcall name "C-c C-c installs the fn at point")
(equal (funcall value "(twice 7)") "21"))
;; C-x C-e at the end of a column-0 declaration.
(funcall goto "n * 3")
(delete-char 5)
(insert "n * 4")
(flan-fln-eval-last)
(test-flan--check (funcall name "C-x C-e at the end of a column-0 fn installs it")
(equal (funcall value "(twice 7)") "28"))
;; C-x C-e at the end of an inner statement: text from column 3.
(funcall goto "twice(4)" t)
(flan-fln-eval-last)
(test-flan--check (funcall name "C-x C-e sends the statement ending at point")
(funcall shows "16"))
;; ...and inside a line, the term before point.
(funcall goto "twice(4)")
(let ((at (point)))
(insert "fib(10) + ")
(goto-char (+ at (length "fib(10)")))
(flan-fln-eval-last)
(test-flan--check (funcall name "C-x C-e inside a line sends the term before point")
(funcall shows "55"))
(delete-region at (+ at (length "fib(10) + "))))
;; C-c C-e on a clause: the whole if, from column 3, clauses and all.
(funcall goto "else\n 0")
(flan-fln-eval-statement)
(test-flan--check (funcall name "C-c C-e on a clause sends its if, and it reads")
(funcall shows "8"))
;; A bare let: it and the rest of its block, which is its scope.
(funcall goto "let x = 3")
(flan-fln-eval-statement)
(test-flan--check (funcall name "C-c C-e on a bare let sends its scope with it")
(funcall shows "13"))
;; A region of several statements reads as one (do ...).
(funcall goto "twice(4)")
(transient-mark-mode 1)
(set-mark (point))
(funcall goto "else\n 0" t)
(flan-fln-eval-statement)
(test-flan--check (funcall name "C-c C-e on a region of statements evaluates them in order")
(funcall shows "8"))
;; C-c C-n sends and moves on.
(funcall goto "twice(4)")
(flan-fln-eval-statement-and-next)
(test-flan--check (funcall name "C-c C-n sends the statement")
(funcall shows "16"))
(test-flan--check (funcall name "and moves to the next")
(looking-at "if 2 > 1"))
;; 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
;; a column off to show the answer can be no.
;; C-x C-e on an arm's value, and on a condition line.
(funcall goto ":south -> 20" t)
(flan-fln-eval-last)
(test-flan--check (funcall name "C-x C-e at the end of a match arm evaluates its value")
(funcall shows "20"))
(funcall goto ":east -> 1 +" t)
(flan-fln-eval-last)
(test-flan--check (funcall name "C-x C-e on an arm's wrapped value evaluates all of it")
(funcall shows "3"))
(funcall goto "if 1 < 2 and" t)
(flan-fln-eval-last)
(test-flan--check (funcall name "C-x C-e on a wrapped condition evaluates all of it")
(funcall shows "true"))
;; An error on the wrapped line of a condition or value cut out
;; mid-line is reported where it is in the buffer, column and all.
(let ((refused
(lambda (needle bad fix)
(funcall goto needle t)
(let ((line (1+ (line-number-at-pos))) col)
(save-excursion
(forward-line 1)
(search-forward fix (line-end-position))
(replace-match bad t t)
(setq col (1+ (- (point) (line-beginning-position)
(length (car (last (split-string bad " "))))))))
(prog1 (list (condition-case err (progn (flan-fln-eval-last) nil)
(user-error (error-message-string err)))
(format ":%d:%d)" line col))
(save-excursion
(goto-char (point-min))
(search-forward bad)
(replace-match fix t t)))))))
(pcase-dolist (`(,what ,needle ,bad ,fix)
'(("an if condition" "if 1 < 2 and" "3 < 4 4" "3 < 4")
("an elif condition" "elif 1 > 2 or" "3 > 4 4" "3 > 4")
("an arm's value" ":east -> 1 +" "2 2" "2")))
(let ((r (funcall refused needle bad fix)))
(test-flan--check
(funcall name (format "an error on the wrapped line of %s is reported at its column" what))
(and (car r) (string-suffix-p (cadr r) (car r))))
(unless (and (car r) (string-suffix-p (cadr r) (car r)))
(message " want ...%s\n got %S" (cadr r) (car r))))))
(flan-clear-errors)
(funcall goto "if 2 > 1" t)
(flan-fln-eval-last)
(test-flan--check (funcall name "C-x C-e at the end of an if line evaluates the condition")
(funcall shows "true"))
(dolist (c '(("n - 1)" "a call, from its name")
("elif n" "an elif, at its condition")
("else\n 1" "an else, at its block")
(":south -> 20" "a match arm, at its value")
("_ ->" "a match arm, at its block")
("n < 2" "an if statement")
("t = 0" "a let")
("i in range" "a for")
("+ i" "an assignment")))
(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"
(cadr c)))
(plist-get reply :pause)))
(flan-fln-eval-defun))
(test-flan--check (funcall name "and a plain C-c C-c takes the mark down")
(null (flan--pause-overlays)))
(funcall goto "fib(n - 1)")
(let* ((b (flan-fln--toplevel-bounds (point)))
(off (condition-case nil
(plist-get (flan--eval (flan--text (car b) (cdr b)) "defn"
nil nil (cons (1+ (point)) (+ 3 (point))))
:pause)
(user-error nil))))
(test-flan--check (funcall name "a position one column off the call is not taken")
(null off)))
(flan-fln-eval-defun)
(set-buffer-modified-p nil)
(kill-buffer))
;; Stopped whatever happened above: a daemon this started is its own to end.
(flan-quit))
(ignore-errors (delete-file sock))
(ignore-errors (delete-file file))))
(message "\nthe .fln keys, against a daemon on each backend")
(test-flan-fln-live--run "x86" nil)
(test-flan-fln-live--run "llvm" '("--llvm"))
;;; test-flan-fln-live.el ends here

952
emacs/test-flan-fln.el Normal file
View File

@ -0,0 +1,952 @@
;;; test-flan-fln.el --- The .fln mode, from written-out text -*- lexical-binding: t; -*-
;; Loaded by test-flan-cider.el, which runs under `dune test', for the reason
;; test-flan-mode.el is: `emacs/*.el' is already that stanza's dependency.
;; Nothing here needs a daemon; what the daemon makes of what these commands
;; send is test-flan-fln-live.el's, run from test-flan.el.
;;
;; Every snippet is text; each check says where point is with a `|' written
;; into it, which is removed before the check runs.
;;; Code:
(require 'flan-fln-mode)
(require 'flan)
(declare-function test-flan--check "test-flan-cider" (name ok))
(defmacro test-flan-fln--in (text &rest body)
"Run BODY in a .fln buffer holding TEXT, point where TEXT has its `|'."
(declare (indent 1))
`(with-temp-buffer
(insert ,text)
(flan-fln-mode)
(goto-char (point-min))
(when (search-forward "|" nil t)
(delete-char -1))
,@body))
(defun test-flan-fln--text (b)
(and b (cdr b) (buffer-substring-no-properties (car b) (cdr b))))
(defun test-flan-fln--is (name got want)
(test-flan--check name (equal got want))
(unless (equal got want)
(message " want %S\n got %S" want got)))
(defun test-flan-fln--thing (thing)
(test-flan-fln--text (bounds-of-thing-at-point thing)))
(message "\nthe .fln mode")
;;; One parent
(test-flan--check "flan-mode is a flan-base-mode"
(provided-mode-derived-p 'flan-mode 'flan-base-mode))
(test-flan--check "flan-fln-mode is a flan-base-mode"
(provided-mode-derived-p 'flan-fln-mode 'flan-base-mode))
(test-flan--check ".fln opens in flan-fln-mode"
(eq (cdr (assoc "\\.fln\\'" auto-mode-alist)) 'flan-fln-mode))
(test-flan-fln--in "fn f() -> i32 = 1\n"
(test-flan--check "a .fln buffer sends the indented syntax"
(equal (flan--syntax) "indented"))
(test-flan--check "and gets the client's completion, as a .flan one does"
(memq #'flan-completion-at-point completion-at-point-functions))
(test-flan--check "and the modeline indicator"
(member '(:eval (flan-mode-line)) mode-line-misc-info))
(test-flan--check "the shared keys reach it through the parent's map"
(eq (key-binding (kbd "C-c C-b")) 'flan-cnr-show))
(test-flan--check "and its own keys pick .fln forms"
(and (eq (key-binding (kbd "C-c C-c")) 'flan-fln-eval-defun)
(eq (key-binding (kbd "C-x C-e")) 'flan-fln-eval-last))))
(require 'flan-watch)
(let ((b (generate-new-buffer "ghost.fln")))
(with-current-buffer b (flan-fln-mode))
(switch-to-buffer b)
(test-flan--check "watch paints ghost text in a shown .fln buffer"
(memq b (flan-watch--ghost-buffers)))
(with-current-buffer b
(insert "fn f() -> ()\n watch-i64(\"x\", 1)\n")
(test-flan--check "and finds a watch call written as a .fln call"
(equal (mapcar #'car (flan-watch--ghost-sites)) '("x"))))
(kill-buffer b))
(require 'flan-dape)
(test-flan--check "dape offers its config in any Flan buffer"
(equal (plist-get flan-dape-config 'modes) '(flan-base-mode)))
(let ((buffer-file-name "/tmp/x.fln"))
(test-flan--check "and debugs the .fln file it was started from"
(equal (flan-dape--source) "/tmp/x.fln")))
;;; The objects
(defconst test-flan-fln--settle
"fn settle(row: i32, col: i32) -> ()
let vel = f32(gravity) + velocity[row, col]
while y > row
if 0 == grid[y, col]
grid[y, col] = grid[row, col]
; a comment inside the body
return
let left? = col > 0
if left? or right?
let side =
if not left?
1
elif not right?
-1
else
if f32(rand()) < 0.5 then 1 else -1
grid[y, col + side] = grid[row, col]
y = y - 1
velocity[row, col] = 0.0
; trailing comment, not part of the function
fn step() -> ()
paint-at(i32(m.y) / cell-size,
i32(m.x) / cell-size)
if r >= 0 and r < rows - 1
and c >= 0
grid[r, c] = 1
step()
")
(defun test-flan-fln--at (text needle)
"TEXT with a `|' before the first NEEDLE."
(let ((i (string-search needle text)))
(concat (substring text 0 i) "|" (substring text i))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "if 0 == grid")
(test-flan-fln--is "a statement takes its body, through blank and comment lines"
(test-flan-fln--thing 'flan-fln-statement)
"if 0 == grid[y, col]
grid[y, col] = grid[row, col]
; a comment inside the body
return")
(test-flan-fln--is "its body is the lines under its first"
(test-flan-fln--thing 'flan-fln-body)
"grid[y, col] = grid[row, col]
; a comment inside the body
return"))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "elif not right")
(test-flan-fln--is "on a clause, the statement is its header's, clauses and all"
(test-flan-fln--thing 'flan-fln-statement)
"if not left?
1
elif not right?
-1
else
if f32(rand()) < 0.5 then 1 else -1")
(test-flan-fln--is "and the clause is its own line and block"
(test-flan-fln--thing 'flan-fln-clause)
"elif not right?
-1"))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "1\n elif")
(test-flan-fln--is "a clause is not found from the header's own block"
(test-flan-fln--thing 'flan-fln-clause) nil))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "if f32(rand())")
(test-flan-fln--is "from inside else's block, the clause is the else"
(test-flan-fln--thing 'flan-fln-clause)
"else
if f32(rand()) < 0.5 then 1 else -1"))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "let side =")
(test-flan-fln--is "let x = with the value as a block"
(test-flan-fln--thing 'flan-fln-statement)
"let side =
if not left?
1
elif not right?
-1
else
if f32(rand()) < 0.5 then 1 else -1"))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "i32(m.x)")
(test-flan-fln--is "a line inside a bracket is part of its statement"
(test-flan-fln--thing 'flan-fln-statement)
"paint-at(i32(m.y) / cell-size,
i32(m.x) / cell-size)")
(test-flan-fln--is "a term is glued, brackets and all"
(test-flan-fln--thing 'flan-fln-term) "i32(m.x)")
(test-flan-fln--is "a group is a bracket pair"
(test-flan-fln--thing 'flan-fln-group)
"(i32(m.y) / cell-size,
i32(m.x) / cell-size)"))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "and c >= 0")
(test-flan-fln--is "an operator continuation line is part of its statement"
(test-flan-fln--thing 'flan-fln-statement)
"if r >= 0 and r < rows - 1
and c >= 0
grid[r, c] = 1")
(test-flan-fln--is "and not the start of the body"
(test-flan-fln--thing 'flan-fln-body) "grid[r, c] = 1"))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "velocity[row, col] = 0.0")
(test-flan-fln--is "a top-level form ends before trailing comment lines"
(test-flan-fln--thing 'flan-fln-toplevel)
(substring test-flan-fln--settle 0
(+ (string-search "= 0.0" test-flan-fln--settle) 5))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "trailing comment")
(test-flan--check "a comment between forms belongs to the form above"
(string-prefix-p "fn settle"
(test-flan-fln--thing 'flan-fln-toplevel))))
(test-flan-fln--in "; a header comment\n|\nfn f() -> i32 = 1\n"
(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--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)))
"fnx() -> i32 = 1"))
(test-flan-fln--in "x = 1\nhandler-case\n f()\non E(c)\n nil\n|restart y\n"
(test-flan--check "on and restart at column 0 are clauses, not forms"
(progn (beginning-of-defun)
(looking-at "handler-case"))))
(test-flan-fln--in "let on = 3\nfoo(x):|\n bar()\n"
(test-flan-fln--is "a term ends before the trailing colon of a call's block"
(test-flan-fln--text (flan-fln--term-before (point))) "foo(x)"))
(test-flan-fln--in "f(\\(, \\) , x.y)|\n"
(test-flan-fln--is "a character literal is not a bracket"
(test-flan-fln--text (flan-fln--term-before (point)))
"f(\\(, \\) , x.y)"))
;;; Top-level motion
(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle " y = y - 1")
(beginning-of-defun)
(test-flan--check "C-M-a goes to the form's first line" (looking-at "fn settle"))
(end-of-defun)
(test-flan--check "C-M-e goes past its last code line, not its trailing comment"
(save-excursion (forward-line -1)
(looking-at " velocity\\[row, col\\] = 0.0")))
(end-of-defun)
(test-flan--check "and the next C-M-e ends the next form"
(= (point) (point-max)))
(goto-char (point-max))
(beginning-of-defun)
(test-flan--check "C-M-a from the end reaches the last form" (looking-at "fn step"))
(mark-defun)
(test-flan--check "C-M-h marks the form"
(let ((m (buffer-substring (region-beginning) (region-end))))
(and (string-prefix-p "fn step" (string-trim-left m "\n"))
(string-suffix-p " step()\n" m)))))
;;; Statement motion
(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle " let left?")
(flan-fln-backward-statement)
(test-flan--check "M-a at a statement's start goes to the one before at its level"
(looking-at "if 0 == grid"))
(flan-fln-backward-statement)
(test-flan--check "and out to the owner when there is none" (looking-at "while y"))
(flan-fln-forward-statement)
(test-flan--check "M-e goes to the end of the statement, body and all"
(looking-back "y = y - 1" (line-beginning-position)))
(flan-fln-forward-statement)
(test-flan--check "and again, to the end of the next"
(looking-back "= 0.0" (line-beginning-position))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle " -1")
(flan-fln-up)
(test-flan--check "C-M-u goes to the line that owns the block"
(looking-at "elif not right"))
(flan-fln-up)
(test-flan--check "and from there to its owner's" (looking-at "let side")))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "m.x)")
(flan-fln-up)
(test-flan--check "C-M-u inside a bracket goes to the bracket" (looking-at "(m.x)")))
;;; What each key sends
;; The request, captured where it leaves: the daemon's answer is the live
;; test's business, and here what matters is which text went out and where
;; it said the text starts.
(defvar test-flan-fln--sent nil)
(defmacro test-flan-fln--sending (&rest body)
`(progn
(setq test-flan-fln--sent nil)
(cl-letf (((symbol-function 'flan--request)
(lambda (form) (push form test-flan-fln--sent)
(list :status "ok" :value "0")))
((symbol-function 'pulse-momentary-highlight-region) #'ignore))
,@body)
(car test-flan-fln--sent)))
(defun test-flan-fln--sent-code (req)
(plist-get req :code))
(defconst test-flan-fln--prog
"fn fib(n: i64) -> i64
if n < 2
n
else
fib(n - 1) + fib(n - 2)
comment():
twice(4)
let x = 3
if x > 2
twice(x)
else
0
fn twice(n: i64) -> i64 = n * 2
")
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "fib(n - 1)")
(test-flan--check "C-c C-s is the .fln stepper"
(eq (key-binding (kbd "C-c C-s")) 'flan-fln-step-defun))
(let ((r (test-flan-fln--sending (flan-fln-step-defun))))
(test-flan--check "which installs the fn at point to step through"
(and (equal (plist-get r :op) "eval")
(eq (plist-get r :step) t)
(string-prefix-p "fn fib" (test-flan-fln--sent-code r))
(string-suffix-p "fib(n - 2)" (test-flan-fln--sent-code r))))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "twice(4)")
(test-flan--check "and refuses what is not a declaration"
(condition-case nil
(progn (test-flan-fln--sending (flan-fln-step-defun)) nil)
(user-error t))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "fib(n - 1)")
(let ((r (test-flan-fln--sending (flan-fln-eval-defun))))
(test-flan--check "C-c C-c inside a fn installs the whole fn"
(and (equal (plist-get r :op) "eval")
(string-suffix-p "fib(n - 1) + fib(n - 2)"
(test-flan-fln--sent-code r))
(string-prefix-p "fn fib" (test-flan-fln--sent-code r))
(equal (plist-get r :syntax) "indented")))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "twice(4)")
(let ((r (test-flan-fln--sending (flan-fln-eval-defun))))
(test-flan--check "C-c C-c on a column-0 call evaluates it"
(equal (plist-get r :op) "eval-expr"))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "\n let x")
(let ((r (test-flan-fln--sending (flan-fln-eval-last))))
(test-flan--check "C-x C-e at a line's end sends the statement ending there"
(and (equal (plist-get r :op) "eval-expr")
(equal (test-flan-fln--sent-code r) "twice(4)")
(equal (plist-get r :line) 8)
(equal (plist-get r :col) 3)))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "\n else\n 0")
(let ((r (test-flan-fln--sending (flan-fln-eval-last))))
(test-flan--check "the innermost one: the last line of a block, not the if"
(equal (test-flan-fln--sent-code r) "twice(x)"))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "(4)")
(let ((r (test-flan-fln--sending (flan-fln-eval-last))))
(test-flan--check "C-x C-e inside a line sends the term before point"
(and (equal (test-flan-fln--sent-code r) "twice")
(equal (plist-get r :col) 3)))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "\n\ncomment")
(let ((r (test-flan-fln--sending (flan-fln-eval-last))))
(test-flan--check "at the end of a fn's last line, the innermost statement, not the fn"
(equal (test-flan-fln--sent-code r) "fib(n - 1) + fib(n - 2)"))))
(test-flan-fln--in test-flan-fln--prog
(goto-char (point-max))
(skip-chars-backward "\n")
(let ((r (test-flan-fln--sending (flan-fln-eval-last))))
(test-flan--check "a column-0 one-line fn at its end is installed"
(and (equal (plist-get r :op) "eval")
(string-suffix-p "fn twice(n: i64) -> i64 = n * 2"
(test-flan-fln--sent-code r))))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "else\n 0")
(let ((r (test-flan-fln--sending (flan-fln-eval-statement))))
(test-flan--check "C-c C-e on a clause sends its whole statement"
(and (equal (test-flan-fln--sent-code r)
"if x > 2\n twice(x)\n else\n 0")
(equal (plist-get r :line) 10)
(equal (plist-get r :col) 3)))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "let x = 3")
(let ((r (test-flan-fln--sending (flan-fln-eval-statement))))
(test-flan--check "C-c C-e on a bare let sends it with the rest of its block"
(equal (test-flan-fln--sent-code r)
"let x = 3\n if x > 2\n twice(x)\n else\n 0"))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "twice(4)")
(let ((r (test-flan-fln--sending (flan-fln-eval-statement-and-next))))
(test-flan--check "C-c C-n sends the statement"
(equal (test-flan-fln--sent-code r) "twice(4)"))
(test-flan--check "and moves to the next" (looking-at "let x = 3"))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "twice(4)")
(transient-mark-mode 1)
(set-mark (point))
(search-forward "twice(x)")
(forward-char -3)
(let ((r (test-flan-fln--sending (flan-fln-eval-statement))))
(test-flan--check "C-c C-e sends the region's whole lines"
(equal (test-flan-fln--sent-code r)
"twice(4)\n let x = 3\n if x > 2\n twice(x)"))))
;; The pause target. The position sent is where the reader starts the form,
;; which for a call is its name and not its parenthesis; the live test checks
;; the daemon finds a form there.
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "n - 1)")
(let ((r (test-flan-fln--sending (flan-fln-eval-defun '(4)))))
(test-flan-fln--is "C-u C-c C-c in a call marks the call, from its name"
(plist-get r :pause) '(5 5))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "< 2")
(let ((r (test-flan-fln--sending (flan-fln-eval-defun '(4)))))
(test-flan-fln--is "outside a bracket, the statement on point's line"
(plist-get r :pause) '(2 3))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--prog "n < 2")
(let ((r (test-flan-fln--sending (flan-fln-eval-defun '(16)))))
(test-flan-fln--is "C-u C-u, the fn: stop on entry"
(plist-get r :pause) '(1 1))))
(test-flan-fln--in "fn f(x: i64) -> i64\n g((x| + 1), [x 2])\n"
(let ((r (test-flan-fln--sending (flan-fln-eval-defun '(4)))))
(test-flan-fln--is "a free parenthesis marks the value inside it"
(plist-get r :pause) '(2 6))))
;;; Match arms, header lines, clauses, comments
(defconst test-flan-fln--arms
"fn pick(n: i64) -> i64
let r = match n
0 -> 10
1 ->
twice(1)
twice(2)
k -> k + 1
if n < 0
-1
elif n == 0
or n == 1
0
else
r
handler-case
f()
on Error(e)
nil
; a comment, twice(9)
r
comment:
twice(4)
")
(defun test-flan-fln--last-at (needle &optional fn)
"What FN, C-x C-e by default, sends with point at the end of NEEDLE's line."
(test-flan-fln--in (test-flan-fln--at test-flan-fln--arms needle)
(end-of-line)
(let ((r (test-flan-fln--sending (funcall (or fn #'flan-fln-eval-last)))))
(and r (list (plist-get r :op) (test-flan-fln--sent-code r))))))
(test-flan-fln--is "C-x C-e at the end of a match arm sends its value"
(test-flan-fln--last-at "0 -> 10") '("eval-expr" "10"))
(test-flan-fln--is "at the end of an arm with a block, the block"
(test-flan-fln--last-at "1 ->")
'("eval-expr" "twice(1)\n twice(2)"))
(test-flan-fln--is "an arm whose pattern binds a name sends the whole match"
(cadr (test-flan-fln--last-at "k -> k"))
(substring test-flan-fln--arms (string-search "let r" test-flan-fln--arms)
(+ (string-search "k + 1" test-flan-fln--arms) 5)))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--arms "twice(2)")
(test-flan-fln--is "C-c C-e on an arm's block sends the block, not the arm"
(test-flan-fln--sent-code
(test-flan-fln--sending
(search-backward "1 ->") (flan-fln-eval-statement)))
"twice(1)\n twice(2)"))
(test-flan-fln--is "C-x C-e at the end of an if line sends its condition"
(test-flan-fln--last-at "if n < 0") '("eval-expr" "n < 0"))
(test-flan-fln--is "and of an elif, all of its condition"
(test-flan-fln--last-at "or n == 1")
'("eval-expr" "n == 0\n or n == 1"))
(test-flan-fln--is "and the same from the end of the condition's first line"
(test-flan-fln--last-at "elif n == 0")
'("eval-expr" "n == 0\n or n == 1"))
(defconst test-flan-fln--wrapped
"fn f(o: Option(i64)) -> i64
match o
Some(_) -> 5
Some(n) -> n + 1
Some(m) -> 7
None -> 1 +
2
if 1 < 2 and
3 < 4
x = 1 +
2
")
(defun test-flan-fln--wrapped-at (needle fn)
(test-flan-fln--in (test-flan-fln--at test-flan-fln--wrapped needle)
(end-of-line)
(let ((r (test-flan-fln--sending (funcall fn))))
(and r (test-flan-fln--sent-code r)))))
(test-flan-fln--is "an arm's value wrapped onto a second line goes whole"
(test-flan-fln--wrapped-at "None" #'flan-fln-eval-last)
"1 +\n 2")
(test-flan-fln--is "from its second line too"
(test-flan-fln--wrapped-at " 2\n if" #'flan-fln-eval-last)
"1 +\n 2")
(test-flan-fln--is "and C-c C-e on it sends the same"
(test-flan-fln--wrapped-at "None" #'flan-fln-eval-statement)
"1 +\n 2")
(test-flan-fln--is "a wrapped if condition, from the end of its first line"
(test-flan-fln--wrapped-at "if 1 < 2" #'flan-fln-eval-last)
"1 < 2 and\n 3 < 4")
(test-flan-fln--is "a statement wrapped by an operator, from the end of its first line"
(test-flan-fln--wrapped-at "x = 1 +" #'flan-fln-eval-last)
"x = 1 +\n 2")
(test-flan-fln--in (test-flan-fln--at test-flan-fln--wrapped "None")
(end-of-line)
(let ((r (test-flan-fln--sending (flan-fln-eval-last))))
(test-flan-fln--is "a value cut mid-line says where its statement starts"
(list (plist-get r :line) (plist-get r :col) (plist-get r :indent))
'(6 13 5))))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--wrapped "x = 1")
(end-of-line)
(let ((r (test-flan-fln--sending (flan-fln-eval-last))))
(test-flan--check "a whole statement does not" (null (plist-member r :indent)))))
(test-flan-fln--is "an arm whose pattern binds nothing sends its value"
(test-flan-fln--wrapped-at "Some(_)" #'flan-fln-eval-last) "5")
(test-flan-fln--is "nor one whose value does not use what it binds"
(test-flan-fln--wrapped-at "Some(m)" #'flan-fln-eval-last) "7")
(dolist (c '(("Some(_v) -> _v + 1" "a name starting with _")
("Some(éé) -> éé" "a name that is not ASCII")
("Some(N) -> N" "a capitalised name")
("Some(p) -> p.x" "a name used as a field's base")
("Some(n) -> -n" "a name its value negates")
("Some(p) -> -p.x" "a name whose field its value negates")))
(test-flan-fln--in (concat "fn f(o: Option(i64)) -> i64\n match o\n " (car c) "\n")
(goto-char (point-max))
(skip-chars-backward "\n")
(test-flan--check (format "an arm binding %s its value uses sends the match" (cadr c))
(string-prefix-p "match o"
(test-flan-fln--sent-code
(test-flan-fln--sending (flan-fln-eval-last)))))))
(test-flan--check "one whose value uses its binding sends the match"
(string-prefix-p "match o"
(test-flan-fln--wrapped-at "Some(n)" #'flan-fln-eval-last)))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--wrapped "5")
(test-flan-fln--is "a match arm is a clause"
(test-flan-fln--thing 'flan-fln-clause) "Some(_) -> 5"))
(test-flan-fln--is "at the end of an else line, the whole if"
(cadr (test-flan-fln--last-at "else\n r"))
"if n < 0\n -1\n elif n == 0\n or n == 1\n 0\n else\n r")
(test-flan-fln--is "at the end of an on line, the whole handler-case"
(cadr (test-flan-fln--last-at "on Error"))
"handler-case\n f()\n on Error(e)\n nil")
(test-flan-fln--is "at the end of a fn header, the fn, installed"
(car (test-flan-fln--last-at "fn pick")) "eval")
(test-flan-fln--is "at the end of comment:, the whole block"
(test-flan-fln--last-at "comment:")
'("eval-expr" "comment:\n twice(4)"))
(test-flan-fln--in (test-flan-fln--at test-flan-fln--arms "; a comment")
(end-of-line)
(let ((r (test-flan-fln--sending
(condition-case nil (flan-fln-eval-last) (user-error nil)))))
(test-flan--check "C-x C-e on a comment line sends nothing from the comment"
(null r))))
(defun test-flan-fln--pause-at (needle)
(test-flan-fln--in (test-flan-fln--at test-flan-fln--arms needle)
(plist-get (test-flan-fln--sending (flan-fln-eval-defun '(4))) :pause)))
(test-flan-fln--is "C-u C-c C-c on an arm's pattern stops at its value"
(test-flan-fln--pause-at "0 -> 10") '(3 10))
(test-flan-fln--is "on an arm with a block, at the block"
(test-flan-fln--pause-at "1 ->") '(5 7))
(test-flan-fln--is "on an elif line, at its condition"
(test-flan-fln--pause-at "elif") '(10 8))
(test-flan-fln--is "and from its condition's continuation line too"
(test-flan-fln--pause-at "or n == 1") '(10 8))
(test-flan-fln--is "on an else line, at its block"
(test-flan-fln--pause-at "else\n r") '(14 5))
(test-flan-fln--is "on an on line, at its block"
(test-flan-fln--pause-at "on Error") '(18 5))
;;; Names and colours
(test-flan-fln--in "fn f(x: i64) -> i64\n comment:\n g(:key-r, x)\n 0x1F + 12\n"
(search-forward "x:")
(backward-char 1)
(test-flan-fln--is "a colon glued to a name is not part of it"
(thing-at-point 'symbol t) "x")
(search-forward "comment")
(test-flan-fln--is "nor to a name that takes a block"
(thing-at-point 'symbol t) "comment")
(test-flan--check "font-lock draws the buffer without an error"
(condition-case nil (progn (font-lock-ensure) t) (error nil)))
(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 number is drawn as one" (funcall face "12") 'font-lock-number-face)
(test-flan-fln--is "a keyword as a constant" (funcall face ":key-r") 'font-lock-constant-face)
(test-flan-fln--is "a header word as a keyword" (funcall face "fn") 'font-lock-keyword-face)
(test-flan-fln--is "a type after its colon" (funcall face "i64") 'font-lock-type-face)
(test-flan--check "and the name before the colon is not a keyword"
(null (funcall face "x:")))))
;;; Indentation
(defun test-flan-fln--tabs (text n)
"The column TEXT's `|' line reaches after N TABs."
(test-flan-fln--in text
(let ((last-command nil) (this-command 'indent-for-tab-command))
(dotimes (_ n)
(indent-for-tab-command)
(setq last-command 'indent-for-tab-command)))
(current-indentation)))
(defconst test-flan-fln--nest
"fn f() -> ()
while a
if b
c()
|")
(test-flan-fln--is "the first TAB after a block goes to its column"
(test-flan-fln--tabs test-flan-fln--nest 1) 6)
(test-flan-fln--is "each TAB after that steps out one"
(list (test-flan-fln--tabs test-flan-fln--nest 2)
(test-flan-fln--tabs test-flan-fln--nest 3)
(test-flan-fln--tabs test-flan-fln--nest 4)
(test-flan-fln--tabs test-flan-fln--nest 5))
'(4 2 0 6))
(test-flan-fln--is "a line of code already at a valid column stays there"
(test-flan-fln--tabs "fn f() -> ()\n if a\n b\n| let b = 2" 1) 2)
(test-flan-fln--is "and a second TAB steps it out"
(test-flan-fln--tabs "fn f() -> ()\n if a\n b\n| let b = 2" 2) 0)
(test-flan-fln--is "a line of code at no valid column goes to the deepest"
(test-flan-fln--tabs "fn f() -> ()\n if a\n b\n| let b = 2" 1) 4)
(test-flan-fln--is "after a header, one level deeper first"
(test-flan-fln--tabs "fn f() -> ()\n while a\n|" 1) 4)
(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--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"
(test-flan-fln--tabs "if a\n if b\n c\n |else" 1) 2)
(test-flan-fln--is "and a second TAB to the outer if's"
(test-flan-fln--tabs "if a\n if b\n c\n |else" 2) 0)
(test-flan-fln--is "on goes to its handler-case's"
(test-flan-fln--tabs " handler-case\n f()\n |on E(c)" 1) 2)
(test-flan-fln--is "inside a call, under its first argument"
(test-flan-fln--tabs " paint-at(i32(m.y) / cell-size,\n|i32(m.x))" 1) 11)
(test-flan-fln--is "inside a bracket with nothing after it, one level in"
(test-flan-fln--tabs " let v = [\n|1 2]" 1) 4)
(test-flan-fln--is "a closing bracket, at its opening line's column"
(test-flan-fln--tabs " let v = [\n 1 2\n|]" 1) 2)
(test-flan-fln--is "after a line ending in an operator, deeper than its statement"
(test-flan-fln--tabs " if a and\n|b" 1) 4)
(test-flan-fln--in "fn f() -> ()\n while a\n b()\n |"
(flan-fln-dedent-or-delete 1)
(test-flan-fln--is "backspace in the indentation drops one level"
(current-indentation) 2)
(flan-fln-dedent-or-delete 1)
(test-flan-fln--is "and another" (current-indentation) 0))
(test-flan-fln--in "fn f() -> ()\n ab|"
(flan-fln-dedent-or-delete 1)
(test-flan-fln--is "backspace after text deletes a character"
(buffer-substring (line-beginning-position) (point)) " a"))
(test-flan-fln--in "if a\n if b\n c\n els|"
(let ((last-command-event ?e))
(insert "e")
(run-hooks 'post-self-insert-hook))
(let ((last-command-event ?\s))
(insert " ")
(run-hooks 'post-self-insert-hook))
(test-flan-fln--is "else snaps to its if as it is typed"
(current-indentation) 2))
(test-flan-fln--in "fn f() -> ()\n if a\n b\n| c\n d\n"
(indent-region (point) (point-max))
(test-flan-fln--is "indent-region moves a block rigidly"
(buffer-substring (point) (point-max))
" c\n d\n"))
(test-flan-fln--in "fn f() -> ()\n if a\n b\n |c\n"
(indent-region (point-min) (point-max))
(test-flan-fln--is "and leaves lines at valid columns alone"
(buffer-string) "fn f() -> ()\n if a\n b\n c\n"))
(test-flan-fln--in "fn f() -> ()\n if a\n b\n |\n"
(kill-new "if x\n y\n else\n z")
(flan-fln-yank)
(test-flan-fln--is "a statement cut from its first character yanks as one block"
(buffer-string)
"fn f() -> ()\n if a\n b\n if x\n y\n else\n z\n"))
(test-flan-fln--in "fn f() -> ()\n if a\n |\n"
(kill-new " while x\n y\n")
(flan-fln-yank)
(test-flan-fln--is "whole lines yank at point's column"
(buffer-string)
"fn f() -> ()\n if a\n while x\n y\n\n"))
;;; Block editing
(test-flan-fln--in "fn f() -> ()\n if a\n |b()\n c()\n d()\n"
(flan-fln-slurp)
(test-flan-fln--is "slurp pulls the next statement into the block"
(buffer-string) "fn f() -> ()\n if a\n b()\n c()\n d()\n")
(flan-fln-barf)
(test-flan-fln--is "barf pushes the last one out again"
(buffer-string) "fn f() -> ()\n if a\n b()\n c()\n d()\n"))
(test-flan-fln--in "fn f() -> ()\n |a()\n if x\n y\n b()\n"
(flan-fln-move-statement-down)
(test-flan-fln--is "a statement moves down past its sibling's whole block"
(buffer-string) "fn f() -> ()\n if x\n y\n a()\n b()\n")
(test-flan--check "and point moves with it" (looking-at "a()"))
(flan-fln-move-statement-up)
(test-flan-fln--is "and back up"
(buffer-string) "fn f() -> ()\n a()\n if x\n y\n b()\n"))
(test-flan-fln--in "fn f() -> ()\n when(c):\n if x\n |y\n"
(flan-fln-raise-statement)
(test-flan-fln--is "raise replaces the owner with the statement"
(buffer-string) "fn f() -> ()\n when(c):\n y\n"))
(test-flan-fln--in "fn f() -> ()\n |if x\n y\n else\n z\n b()\n"
(flan-fln-kill-statement)
(test-flan-fln--is "kill takes the whole statement's lines"
(buffer-string) "fn f() -> ()\n b()\n")
(test-flan-fln--is "into the kill ring" (current-kill 0)
" if x\n y\n else\n z\n"))
;;; expand-region, where it is installed
(let* ((dirs (append (file-expand-wildcards "~/.config/emacs/elpa/expand-region-[0-9]*")
(file-expand-wildcards "~/.emacs.d/elpa/expand-region-[0-9]*")))
(load-path (append dirs load-path)))
(if (not (require 'expand-region nil t))
(message " skip expand-region (not installed)")
(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "right?\n -1")
(transient-mark-mode 1)
(let ((steps nil))
(dotimes (_ 6)
(er/expand-region 1)
(push (buffer-substring-no-properties (region-beginning) (region-end)) steps))
(setq steps (nreverse steps))
(test-flan-fln--is "term, then statement's clause, then statement, then out"
(mapcar (lambda (s) (car (split-string s "\n"))) steps)
'("right?" "elif not right?" "if not left?" "let side ="
"if left? or right?" "let left? = col > 0"))))))
;;; smartparens, where it is installed
(let* ((dirs (append (file-expand-wildcards "~/.config/emacs/elpa/smartparens-[0-9]*")
(file-expand-wildcards "~/.emacs.d/elpa/smartparens-[0-9]*")
(file-expand-wildcards "~/.config/emacs/elpa/dash-[0-9]*")
(file-expand-wildcards "~/.emacs.d/elpa/dash-[0-9]*")))
(load-path (append dirs load-path)))
(if (not (require 'smartparens nil t))
(message " skip smartparens (not installed)")
;; A setup that puts sexp commands on the top-level keys, as the
;; author's does.
(define-key smartparens-mode-map (kbd "C-M-a") 'sp-backward-down-sexp)
(define-key smartparens-mode-map (kbd "C-M-u") 'sp-backward-up-sexp)
(let ((b (generate-new-buffer "sp.fln")))
(switch-to-buffer b)
(flan-fln-mode)
(test-flan--check "smartparens is on in a .fln buffer" smartparens-mode)
(test-flan--check "and C-M-a and C-M-u stay the mode's"
(and (eq (key-binding (kbd "C-M-a")) 'beginning-of-defun)
(eq (key-binding (kbd "C-M-u")) 'flan-fln-up)))
(execute-kbd-macro "f(")
(test-flan-fln--is "it pairs a bracket" (buffer-string) "f()")
(erase-buffer)
(execute-kbd-macro "'a")
(test-flan-fln--is "and not a quote" (buffer-string) "'a")
(set-buffer-modified-p nil)
(kill-buffer b))
(define-key smartparens-mode-map (kbd "C-M-a") nil)
(define-key smartparens-mode-map (kbd "C-M-u") nil)))
;;; Under Evil
(let* ((dirs (append (file-expand-wildcards "~/.config/emacs/elpa/evil-[0-9]*")
(file-expand-wildcards "~/.emacs.d/elpa/evil-[0-9]*")
(file-expand-wildcards "~/.config/emacs/elpa/goto-chg-*")
(file-expand-wildcards "~/.emacs.d/elpa/goto-chg-*")))
(load-path (append dirs load-path)))
(if (not (require 'evil nil t))
(message " skip the .fln text objects (Evil is not installed)")
(evil-mode 1)
(unwind-protect
(let ((yanked
(lambda (text keys)
(let ((b (generate-new-buffer "objects.fln")))
(switch-to-buffer b)
(insert text)
(flan-fln-mode)
(evil-initialize-state)
(evil-normal-state)
(goto-char (point-min))
(search-forward "|")
(delete-char -1)
(execute-kbd-macro keys)
(prog1 (substring-no-properties (current-kill 0))
(set-buffer-modified-p nil)
(kill-buffer b))))))
(dolist (c `(("yiw" ,(test-flan-fln--at test-flan-fln--settle "settle(")
"settle")
("yie" ,(test-flan-fln--at test-flan-fln--settle "i32(m.x)")
"i32(m.x)")
("yis" ,(test-flan-fln--at test-flan-fln--settle "and c >= 0")
"if r >= 0 and r < rows - 1\n and c >= 0\n grid[r, c] = 1")
("yas" ,(test-flan-fln--at test-flan-fln--settle "and c >= 0")
" if r >= 0 and r < rows - 1\n and c >= 0\n grid[r, c] = 1\n")
("yii" ,(test-flan-fln--at test-flan-fln--settle "if not left")
" 1\n")
("yik" ,(test-flan-fln--at test-flan-fln--settle "if f32(rand())")
" if f32(rand()) < 0.5 then 1 else -1\n")
("yak" ,(test-flan-fln--at test-flan-fln--settle "if f32(rand())")
" else\n if f32(rand()) < 0.5 then 1 else -1\n")
("yik" ,(test-flan-fln--at test-flan-fln--wrapped "Some(_)")
"5")
("yak" ,(test-flan-fln--at test-flan-fln--wrapped "Some(_)")
" Some(_) -> 5\n")
("yid" ,(test-flan-fln--at test-flan-fln--settle "paint-at")
,(substring test-flan-fln--settle
(string-search "fn step" test-flan-fln--settle)))))
(test-flan-fln--is (format "under Evil, %s" (car c))
(funcall yanked (nth 1 c) (car c)) (nth 2 c)))
(let ((deleted
(lambda (keys needle)
(let ((b (generate-new-buffer "delete.fln")))
(switch-to-buffer b)
(insert "fn f(x: i64) -> i64\n if x > 0\n a\n else\n 3\n x\n\nfn g() -> i32 = 1\n")
(flan-fln-mode)
(evil-initialize-state)
(evil-normal-state)
(goto-char (point-min))
(search-forward needle)
(goto-char (match-beginning 0))
(execute-kbd-macro keys)
(prog1 (buffer-string)
(set-buffer-modified-p nil)
(kill-buffer b))))))
(dolist (c '(("dak" "else"
"fn f(x: i64) -> i64\n if x > 0\n a\n x\n\nfn g() -> i32 = 1\n")
("das" "else"
"fn f(x: i64) -> i64\n x\n\nfn g() -> i32 = 1\n")
("dii" "if x"
"fn f(x: i64) -> i64\n if x > 0\n else\n 3\n x\n\nfn g() -> i32 = 1\n")
("dad" "else" "fn g() -> i32 = 1\n")
("dad" "fn g" "fn f(x: i64) -> i64\n if x > 0\n a\n else\n 3\n x\n")))
(test-flan-fln--is (format "under Evil, %s leaves no blank line" (car c))
(funcall deleted (car c) (nth 1 c)) (nth 2 c))))
;; Comments: a block directly on a form is the form's; one a
;; blank line away, or below it, is not.
(let ((deleted
(lambda (keys needle)
(let ((b (generate-new-buffer "comments.fln")))
(switch-to-buffer b)
(insert "; loose\n\n; on f\nfn f() -> ()\n a()\n; after f\n\n"
"; on g\nfn g() -> ()\n ; on b\n b()\n")
(flan-fln-mode)
(evil-initialize-state)
(evil-normal-state)
(goto-char (point-min))
(search-forward needle)
(goto-char (match-beginning 0))
(execute-kbd-macro keys)
(prog1 (buffer-string)
(set-buffer-modified-p nil)
(kill-buffer b))))))
(dolist (c '(("dad" "a()"
"; loose\n\n; after f\n\n; on g\nfn g() -> ()\n ; on b\n b()\n")
("dad" "b()"
"; loose\n\n; on f\nfn f() -> ()\n a()\n; after f\n")
("did" "on g"
"; loose\n\n; on f\nfn f() -> ()\n a()\n; after f\n\n")
("das" "b()"
"; loose\n\n; on f\nfn f() -> ()\n a()\n; after f\n\n; on g\nfn g() -> ()\n")))
(test-flan-fln--is (format "under Evil, %s on %s keeps comments with their forms"
(car c) (nth 1 c))
(funcall deleted (car c) (nth 1 c)) (nth 2 c)))
;; A lone comment belongs to no form: id and ad find nothing.
(dolist (text '("fn a() -> i64\n 1\n\n; lone\n\nfn b() -> i64\n 2\n"
"fn a() -> i64\n 1\n\n; lone\n"))
(dolist (keys '("did" "dad"))
(let ((b (generate-new-buffer "lone.fln")))
(switch-to-buffer b)
(insert text)
(flan-fln-mode)
(evil-initialize-state)
(evil-normal-state)
(goto-char (point-min))
(search-forward "; lone")
(goto-char (match-beginning 0))
(ignore-errors (execute-kbd-macro keys))
(test-flan-fln--is (format "under Evil, %s on a lone comment%s changes nothing"
keys (if (string-suffix-p "lone\n" text) " at the end" ""))
(buffer-string) text)
(set-buffer-modified-p nil)
(kill-buffer b))))
;; A comment deeper than a form, at the end of its block, is
;; that block's, not the next form's.
(dolist (c '(("dad" "fn a" "fn a() -> i64\n 1\n ; end of a\nfn b() -> i64\n 2\n"
"fn b() -> i64\n 2\n")
("dad" "fn b" "fn a() -> i64\n 1\n ; end of a\nfn b() -> i64\n 2\n"
"fn a() -> i64\n 1\n ; end of a\n")
("das" "let y"
"fn a(x: i64) -> i64\n if x > 0\n 1\n ; end of the if\n let y = 2\n y\n"
"fn a(x: i64) -> i64\n if x > 0\n 1\n ; end of the if\n y\n")))
(let ((b (generate-new-buffer "owned.fln")))
(switch-to-buffer b)
(insert (nth 2 c))
(flan-fln-mode)
(evil-initialize-state)
(evil-normal-state)
(goto-char (point-min))
(search-forward (nth 1 c))
(goto-char (match-beginning 0))
(execute-kbd-macro (car c))
(test-flan-fln--is (format "under Evil, %s on %s: a deeper comment stays with the block above"
(car c) (nth 1 c))
(buffer-string) (nth 3 c))
(set-buffer-modified-p nil)
(kill-buffer b))))
(let ((b (generate-new-buffer "keys.fln")))
(switch-to-buffer b)
(insert "fn f() -> i32 = 1\n")
(flan-fln-mode)
(evil-initialize-state)
(test-flan--check "under Evil, C-x C-e is still the mode's"
(eq (key-binding (kbd "C-x C-e")) 'flan-fln-eval-last))
(goto-char (point-min))
(end-of-line)
(backward-char)
(test-flan--check "under Evil, C-x C-e counts the cursor's character"
(= (flan-fln--point-for-last) (line-end-position)))
(kill-buffer b)))
(evil-mode -1))))
;;; test-flan-fln.el ends here

7
emacs/test-flan.el
View File

@ -2492,6 +2492,13 @@ already rely on it — so nothing here is a stand-in for the real thing."
(ignore-errors (delete-file socket6)) (ignore-errors (delete-file socket6))
(ignore-errors (delete-file scratch))) (ignore-errors (delete-file scratch)))
;; ── The .fln keys, against daemons of their own ────────────────────────
(setq test-flan-fln-live-dir (file-name-directory file)
test-flan-fln-live-socket socket)
(load (expand-file-name "test-flan-fln-live.el"
(file-name-directory load-file-name))
nil t)
(if (zerop test-flan--failures) (if (zerop test-flan--failures)
(message "flan.el: all tests passed") (message "flan.el: all tests passed")
(message "\n%d failure(s)" test-flan--failures) (message "\n%d failure(s)" test-flan--failures)

4
lib/ast.ml
View File

@ -222,6 +222,10 @@ and arm = { pat : pattern; body : expr list; aloc : Loc.t }
and pattern = and pattern =
| Pctor of string * string list (* (Some e) (Rect w h) None *) | Pctor of string * string list (* (Some e) (Rect w h) None *)
| Pkw of string (* :north — an enum member *) | Pkw of string (* :north — an enum member *)
(* 5 -2.5 \a "go" — an Int, UInt, Float, Byte or Str expr, compared as
(= t lit). An expr and not a literal type of its own, so the checker
types it against the scrutinee as any literal is typed against its site. *)
| Plit of expr
| Pwild (* _ :else *) | Pwild (* _ :else *)
(* ── Declarations ──────────────────────────────────────────────────── *) (* ── Declarations ──────────────────────────────────────────────────── *)

197
lib/check.ml
View File

@ -3801,6 +3801,11 @@ let box_option ctx loc (t : Types.t) (got : Tast.expr) : Tast.expr =
(Tast.Let ([ (s, got) ], (Tast.Let ([ (s, got) ],
[ mk loc Types.Dyn (Tast.If (is_some, some_dyn, none_dyn)) ])) [ mk loc Types.Dyn (Tast.If (is_some, some_dyn, none_dyn)) ]))
(* [=] over a dyn pair, answering a bool. Shared by the [=] builtin and a
literal [match] over a dyn, which is (= t lit) by definition. *)
let dyn_eq loc u v =
unbox loc Types.Bool (rt loc Types.Dyn "flan_dyn_eq" [ box loc u; box loc v ])
let unbox_option ctx loc (t : Types.t) (got : Tast.expr) : Tast.expr = let unbox_option ctx loc (t : Types.t) (got : Tast.expr) : Tast.expr =
let oty = Types.Option t in let oty = Types.Option t in
match t with match t with
@ -8089,10 +8094,52 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms =
"%s is a union, and nothing in one records which member was written, \ "%s is a union, and nothing in one records which member was written, \
so there is nothing to match on. Read the member you mean with \ so there is nothing to match on. Read the member you mean with \
(.member u), or use a defdata" n (.member u), or use a defdata" n
(* A number, a string or a dyn: the arms are literals, and each is the
test (= t lit) over one temporary — the enum's chain, with [=]'s own
two lowerings for the test, so a match over a dyn means what [=] over
it means. [is_equatable]'s set minus the enums, which are above. *)
| (Types.Int _ | Types.Float _ | Types.String | Types.Dyn) as t -> `Lit t
| other -> | other ->
fail loc "match works on an Option, a data type or an enum, not on %s" fail loc
"match works on an Option, a data type, an enum, a number, a string \
or a dyn, not on %s"
(Types.to_string other) (Types.to_string other)
in in
(* A literal arm, spelled as it was written, for the refusals that name one. *)
let spell (e : Ast.expr) =
match e.Ast.e with
| Ast.Int n -> Int64.to_string n
| Ast.UInt (_, t) -> t
| Ast.Float x when Float.is_integer x && Float.abs x < 1e15 ->
Printf.sprintf "%.1f" x
| Ast.Float x ->
(* The shortest spelling that reads back as the same float. *)
let rec go p =
let t = Printf.sprintf "%.*g" p x in
if p >= 17 || float_of_string t = x then t else go (p + 1)
in
go 1
| Ast.Byte b when b > 32 && b < 127 -> Printf.sprintf "\\%c" (Char.chr b)
| Ast.Byte b -> string_of_int b
| Ast.Str t -> Printf.sprintf "%S" t
| _ -> "this literal"
in
let what_ty t = match t with Types.Dyn -> "a dyn" | t -> Types.to_string t in
(* A literal match that compiles, over the scrutinee's own name where it
has one, for the refusals that need to show the shape. *)
let lit_arms_fix t =
let name =
match scrutinee.Ast.e with Ast.Var n -> n | _ -> "t"
in
Printf.sprintf "(match %s %s)" name
(match t with
| Types.String -> "\"yes\" 1 _ 0"
| Types.Float _ -> "0.5 1 _ 0"
| _ -> "5 1 _ 0")
in
(* The checked literal of each literal arm, by the key [resolve_pat] gave it. *)
let lits : (string, Tast.expr) Hashtbl.t = Hashtbl.create 8 in
let lit_values = ref [] in
(* Which case each arm names, and the type of each name it binds. This is the (* Which case each arm names, and the type of each name it binds. This is the
whole of what differs between the two subjects; everything below it is whole of what differs between the two subjects; everything below it is
shared. *) shared. *)
@ -8124,6 +8171,114 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms =
"this match is over the enum %s, and %s is not one of its members. An \ "this match is over the enum %s, and %s is not one of its members. An \
arm names a member as a keyword: %s" n c arm names a member as a keyword: %s" n c
(String.concat " " (List.map (fun (m, _) -> ":" ^ m) members)) (String.concat " " (List.map (fun (m, _) -> ":" ^ m) members))
| `Lit t, Ast.Plit e ->
let v =
(* [=]'s dyn pair checks its literal at dyn, which boxes it. *)
match trial ctx (fun () -> check ctx ~want:t e) with
| Ok v -> v
| Error _ ->
(* A literal that does not fit is refused, where [=] would widen
the pair and let the arm quietly never match. The literal's
own refusal is not repeated: its fixes are casts, and a cast
is not a pattern. *)
(match t with
| Types.Dyn ->
fail a.Ast.aloc
"this match is over a dyn, which holds a number as an i64 or \
an f64, and %s fits in neither. Change the arm to a value an \
i64 holds, or remove it" (spell e)
| _ -> ());
let tn = Types.to_string t in
let an =
match tn.[0] with
| 'a' | 'e' | 'f' | 'i' | 'o' -> "an " ^ tn
| _ -> "a " ^ tn
in
let why =
match e.Ast.e, t with
| Ast.Str _, _ -> "is a string"
| _, Types.String -> "is a number"
| Ast.Float x, Types.Int _ when not (Float.is_integer x) ->
"is not a whole number"
| Ast.Float _, Types.Int _ -> "is a float"
| _ -> "does not fit in one"
in
fail a.Ast.aloc
"this match is over %s, so each arm has to be %s, and %s %s. \
Change the arm to a value %s holds, or remove it"
tn an (spell e) why an
in
(* The arm's value at the scrutinee's type, and a second arm [=] could
not tell from an earlier one is refused, since it can never be
reached: 97 and \a are one u8, 0.1 and 0.10000000001 are one f32,
and over a dyn 1 and 1.0 are equal. Compared pairwise rather than
hashed, because dyn = between an integer and a float goes through
the float and is not transitive past 2^53. *)
let value =
let f32 x = Int32.float_of_bits (Int32.bits_of_float x) in
let num x =
match t with Types.Float Types.F32 -> `F (f32 x) | _ -> `F x
in
match e.Ast.e, t with
| Ast.Str s, _ -> `S s
| (Ast.Int n | Ast.UInt (n, _)), Types.Float _ -> num (Int64.to_float n)
| Ast.Byte b, Types.Float _ -> num (float_of_int b)
| (Ast.Int n | Ast.UInt (n, _)), _ -> `I n
| Ast.Byte b, _ -> `I (Int64.of_int b)
| Ast.Float x, _ -> num x
| _ -> assert false
in
let same x y =
match x, y with
| `I a, `I b -> Int64.equal a b
| `F a, `F b -> a = b
| `I a, `F b | `F b, `I a -> Int64.to_float a = b
| `S a, `S b -> String.equal a b
| _ -> false
in
(match List.find_opt (fun (w, _) -> same value w) !lit_values with
| Some (_, earlier) when earlier = spell e ->
fail a.Ast.aloc "this match has two %s arms" earlier
| Some (_, earlier) ->
fail a.Ast.aloc
"this match has two %s arms — %s equals it as %s, so this arm is \
never reached. Remove it"
earlier (spell e)
(match t with
| Types.Dyn -> "a dyn"
| t ->
let tn = Types.to_string t in
(match tn.[0] with
| 'a' | 'e' | 'f' | 'i' | 'o' -> "an " ^ tn
| _ -> "a " ^ tn))
| None -> ());
lit_values := (value, spell e) :: !lit_values;
let key = string_of_int (Hashtbl.length lits) in
Hashtbl.replace lits key v;
Some key, []
| `Lit t, Ast.Pkw k ->
fail a.Ast.aloc
":%s is an enum member, and this match is over %s, whose arms are \
literals, as in %s" k (what_ty t) (lit_arms_fix t)
| `Lit t, Ast.Pctor (c, _) ->
fail a.Ast.aloc
"%s names a case, and this match is over %s, whose arms are \
literals, as in %s" c (what_ty t) (lit_arms_fix t)
| `Option _, Ast.Plit e ->
fail a.Ast.aloc
"%s is a literal, and this match is over an Option, whose arms are \
(Some x) and None" (spell e)
| `Enum (n, members), Ast.Plit e ->
fail a.Ast.aloc
"%s is a literal, and this match is over the enum %s, whose arms \
name its members as keywords: %s" (spell e) n
(String.concat " " (List.map (fun (m, _) -> ":" ^ m) members))
| `Data u, Ast.Plit e ->
fail a.Ast.aloc
"%s is a literal, and this match is over the data type %s, whose \
arms name its cases: %s" (spell e) u.Tast.dname
(String.concat ", "
(List.map (fun (v : Tast.variant) -> v.Tast.vname) u.Tast.cases))
| `Option _, Ast.Pkw k -> | `Option _, Ast.Pkw k ->
fail a.Ast.aloc fail a.Ast.aloc
":%s is an enum member, and this match is over an Option, whose arms \ ":%s is an enum member, and this match is over an Option, whose arms \
@ -8184,7 +8339,10 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms =
| Some c -> | Some c ->
if Hashtbl.mem seen c then if Hashtbl.mem seen c then
fail a.Ast.aloc "this match has two %s arms" fail a.Ast.aloc "this match has two %s arms"
(match subject with `Enum _ -> ":" ^ c | _ -> c); (match subject, a.Ast.pat with
| `Enum _, _ -> ":" ^ c
| _, Ast.Plit e -> spell e
| _ -> c);
Hashtbl.add seen c ()); Hashtbl.add seen c ());
(a, ctor, binds)) (a, ctor, binds))
arms arms
@ -8286,7 +8444,19 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms =
List.filter_map List.filter_map
(fun (m, _) -> if Hashtbl.mem seen m then None else Some (":" ^ m)) (fun (m, _) -> if Hashtbl.mem seen m then None else Some (":" ^ m))
members members
| `Lit _ -> []
in in
(* No list of literals covers a number, a string or a dyn, so a literal
match always needs its [_]. Refused here, before the chain below, which
would otherwise run a lone last arm untested as the enum's does. *)
(match subject with
| `Lit t when not !saw_wild ->
Loc.failk "check/non-exhaustive-match" loc
"this match is not exhaustive — its arms are literals, and no list of \
them covers every %s. Add a _ arm for the rest, as in %s"
(match t with Types.Dyn -> "dyn value" | t -> Types.to_string t)
(lit_arms_fix t)
| _ -> ());
if not !saw_wild && missing <> [] then if not !saw_wild && missing <> [] then
(* The data type's declaration, because that is where the case list this match (* The data type's declaration, because that is where the case list this match
failed to cover actually lives, and because adding a case there is what failed to cover actually lives, and because adding a case there is what
@ -8295,7 +8465,7 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms =
~notes:(match subject with ~notes:(match subject with
| `Data u -> declared_note ctx.env u.Tast.dname | `Data u -> declared_note ctx.env u.Tast.dname
| `Enum (n, _) -> declared_note ctx.env n | `Enum (n, _) -> declared_note ctx.env n
| `Option _ -> []) | `Option _ | `Lit _ -> [])
"this match is not exhaustive — %s %s no arm. Add %s, or a _ arm for \ "this match is not exhaustive — %s %s no arm. Add %s, or a _ arm for \
the rest" the rest"
(String.concat ", " missing) (String.concat ", " missing)
@ -8304,7 +8474,7 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms =
let ty = match !want with Some t -> t | None -> Types.Never in let ty = match !want with Some t -> t | None -> Types.Never in
match subject with match subject with
| `Option _ | `Data _ -> mk loc ty (Tast.Match (s, arms)) | `Option _ | `Data _ -> mk loc ty (Tast.Match (s, arms))
| `Enum (_, members) -> | `Enum _ | `Lit _ ->
(* The scrutinee once, into a temporary, and then an [if] per arm in the (* The scrutinee once, into a temporary, and then an [if] per arm in the
order written. A [_] arm ends the chain, and so does the last arm of a order written. A [_] arm ends the chain, and so does the last arm of a
match with none: it is exhaustive by the check above, so the last match with none: it is exhaustive by the check above, so the last
@ -8320,10 +8490,18 @@ and check_match ctx ?(tail = false) ?want loc scrutinee arms =
| ({ Tast.acase = None; _ } as a) :: _ -> body a | ({ Tast.acase = None; _ } as a) :: _ -> body a
| [ a ] -> body a | [ a ] -> body a
| ({ Tast.acase = Some m; _ } as a) :: rest -> | ({ Tast.acase = Some m; _ } as a) :: rest ->
let v = mk loc s.Tast.ty (Tast.Int (List.assoc m members, Types.I32)) in let test =
mk loc ty match subject with
(Tast.If (mk loc Types.Bool (Tast.Prim (Tast.Eq, [ local; v ])), | `Enum (_, members) ->
body a, chain rest)) let v =
mk loc s.Tast.ty (Tast.Int (List.assoc m members, Types.I32))
in
mk loc Types.Bool (Tast.Prim (Tast.Eq, [ local; v ]))
| `Lit Types.Dyn -> dyn_eq loc local (Hashtbl.find lits m)
| _ ->
mk loc Types.Bool (Tast.Prim (Tast.Eq, [ local; Hashtbl.find lits m ]))
in
mk loc ty (Tast.If (test, body a, chain rest))
in in
mk loc ty (Tast.Let ([ (slot, s) ], [ chain arms ])) mk loc ty (Tast.Let ([ (slot, s) ], [ chain arms ]))
@ -9698,7 +9876,8 @@ and named_call ?(qualified = false) ctx ~want loc name args =
and the negation is an [i1] flip the backend folds away. *) and the negation is an [i1] flip the backend folds away. *)
let link u v = let link u v =
let cmp = let cmp =
unbox loc Types.Bool (rt loc Types.Dyn sym ([ u; v ] @ site)) if String.equal sym "flan_dyn_eq" then dyn_eq loc u v
else unbox loc Types.Bool (rt loc Types.Dyn sym ([ u; v ] @ site))
in in
if String.equal name "!=" then if String.equal name "!=" then
mk loc Types.Bool (Tast.Prim (Tast.Not, [ cmp ])) mk loc Types.Bool (Tast.Prim (Tast.Not, [ cmp ]))

3
lib/dev.ml
View File

@ -4599,7 +4599,8 @@ let rec handle t req =
| Some l, None -> Some (l, 1) | Some l, None -> Some (l, 1)
| _ -> None | _ -> None
in in
Source.with_code ~syntax ~at (fun () -> handle_op t req) let indent = Wire.int_field req "indent" in
Source.with_code ?indent ~syntax ~at (fun () -> handle_op t req)
and handle_op t req = and handle_op t req =
match Wire.string_field req "op" with match Wire.string_field req "op" with

23
lib/indent_reader.ml
View File

@ -249,7 +249,7 @@ let point (l : Loc.t) = { l with Loc.line = l.Loc.eline; col = l.Loc.ecol }
(* NEWLINE, INDENT and DEDENT, at bracket depth zero only: inside ( [ { a (* NEWLINE, INDENT and DEDENT, at bracket depth zero only: inside ( [ { a
line break is whitespace. A line continues the one before it when either line break is whitespace. A line continues the one before it when either
side of the break is a spaced binary operator (spec §2 "Continuation"). *) side of the break is a spaced binary operator (spec §2 "Continuation"). *)
let layout ?(snippet = false) ?(base = 1) (toks : token list) : token array = let layout ?(snippet = false) ?(base = 1) ?indent (toks : token list) : token array =
let arr = Array.of_list toks in let arr = Array.of_list toks in
let n = Array.length arr in let n = Array.length arr in
(* A snippet from the editor starts wherever it was written, and its first (* A snippet from the editor starts wherever it was written, and its first
@ -258,6 +258,11 @@ let layout ?(snippet = false) ?(base = 1) (toks : token list) : token array =
let out = ref [] in let out = ref [] in
let add tok loc = out := { tok; loc; sp = true } :: !out in let add tok loc = out := { tok; loc; sp = true } :: !out in
let stack = ref [ base ] in let stack = ref [ base ] in
(* [indent] is the column of the statement a snippet was cut out of, when
the snippet starts after that statement's first word (an elif's
condition, an arm's value). Its first joined line continues as it does
in the file: deeper than the statement, not than the cut. *)
let first_line = ref true in
let depth = ref 0 in let depth = ref 0 in
let binop t = match t.tok with NAME s -> is_binop s | _ -> false in let binop t = match t.tok with NAME s -> is_binop s | _ -> false in
for i = 0 to n - 1 do for i = 0 to n - 1 do
@ -277,11 +282,16 @@ let layout ?(snippet = false) ?(base = 1) (toks : token list) : token array =
&& arr.(i + 1).sp && arr.(i + 1).sp
in in
let continues = (binop p && p.sp) || (binop t && spaced_after) in let continues = (binop p && p.sp) || (binop t && spaced_after) in
let top =
match indent with
| Some c when !first_line && List.length !stack = 1 -> min c (List.hd !stack)
| _ -> List.hd !stack
in
(* A continuation line sits deeper than the statement it continues. (* A continuation line sits deeper than the statement it continues.
One at or left of that statement's column is not read as joining One at or left of that statement's column is not read as joining
it: that would pull a line into a block it was written outside it: that would pull a line into a block it was written outside
of, silently. *) of, silently. *)
if continues && t.loc.Loc.col <= List.hd !stack then if continues && t.loc.Loc.col <= top then
failk "continuation" t.loc failk "continuation" t.loc
"%s" "%s"
(if binop t then (if binop t then
@ -290,15 +300,16 @@ let layout ?(snippet = false) ?(base = 1) (toks : token list) : token array =
line above, but it is not indented past the start of that \ line above, but it is not indented past the start of that \
line (column %d). Indent it further to continue the line, \ line (column %d). Indent it further to continue the line, \
or give %s a value on its left" or give %s a value on its left"
(show t.tok) (List.hd !stack) (show t.tok) (show t.tok) top (show t.tok)
else else
Printf.sprintf Printf.sprintf
"the line above ends with the operator %s, so this line \ "the line above ends with the operator %s, so this line \
continues it, but it is not indented past the start of \ continues it, but it is not indented past the start of \
that line (column %d). Indent it further, or finish the \ that line (column %d). Indent it further, or finish the \
line above" line above"
(show p.tok) (List.hd !stack)); (show p.tok) top);
if not continues then begin if not continues then begin
first_line := false;
let at = point p.loc in let at = point p.loc in
add NEWLINE at; add NEWLINE at;
let col = t.loc.Loc.col in let col = t.loc.Loc.col in
@ -1578,7 +1589,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 ~file src = let read_all ?(line = 1) ?col ?indent ~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
@ -1588,7 +1599,7 @@ let read_all ?(line = 1) ?col ~file src =
(file, Array.of_list (String.split_on_char '\n' (file, Array.of_list (String.split_on_char '\n'
(String.make (line - 1) '\n' ^ String.make (col - 1) ' ' ^ src))); (String.make (line - 1) '\n' ^ String.make (col - 1) ' ' ^ src)));
Fun.protect ~finally:(fun () -> source := saved) (fun () -> Fun.protect ~finally:(fun () -> source := saved) (fun () ->
let toks = layout ~snippet ~base:col (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 let fs = stmts s in
(match (peek s.p).tok with (match (peek s.p).tok with

2
lib/load.ml
View File

@ -274,7 +274,7 @@ let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr =
let bound = let bound =
match a.Ast.pat with match a.Ast.pat with
| Ast.Pctor (_, ns) -> ns @ bound | Ast.Pctor (_, ns) -> ns @ bound
| Ast.Pkw _ | Ast.Pwild -> bound | Ast.Pkw _ | Ast.Plit _ | Ast.Pwild -> bound
in in
{ a with Ast.body = List.map (rename_expr owned alias bound) { a with Ast.body = List.map (rename_expr owned alias bound)
a.Ast.body }) arms) a.Ast.body }) arms)

1
lib/parse.ml
View File

@ -1402,6 +1402,7 @@ and pattern (f : Form.t) : Ast.pattern =
(* An enum member. Which enum is the scrutinee's type, so [Check] resolves (* An enum member. Which enum is the scrutinee's type, so [Check] resolves
it, as it resolves a keyword anywhere an enum is expected. *) it, as it resolves a keyword anywhere an enum is expected. *)
| Kw member -> Ast.Pkw member | Kw member -> Ast.Pkw member
| Int _ | UInt _ | Float _ | Byte _ | Str _ -> Ast.Plit (expr f)
| List ({ v = Sym ctor; _ } :: binds) -> | List ({ v = Sym ctor; _ } :: binds) ->
List.iter no_pattern binds; List.iter no_pattern binds;
Ast.Pctor (ctor, List.map dname binds) Ast.Pctor (ctor, List.map dname binds)

14
lib/source.ml
View File

@ -33,15 +33,21 @@ type syntax = Paren | Indented
let code_syntax = ref Paren let code_syntax = ref Paren
let code_at : (int * int) option ref = ref None let code_at : (int * int) option ref = ref None
(* The column of the statement editor code was cut out of, when the code
starts after that statement's first word: see [Indent_reader.layout]. *)
let code_indent : int option ref = ref None
let syntax_of_field = function let syntax_of_field = function
| Some ("indented" | "fln") -> Indented | Some ("indented" | "fln") -> Indented
| _ -> Paren | _ -> Paren
let with_code ~syntax ~at f = let with_code ?indent ~syntax ~at f =
let s = !code_syntax and a = !code_at in let s = !code_syntax and a = !code_at and i = !code_indent in
code_syntax := syntax; code_syntax := syntax;
code_at := at; code_at := at;
Fun.protect ~finally:(fun () -> code_syntax := s; code_at := a) f code_indent := indent;
Fun.protect
~finally:(fun () -> code_syntax := s; code_at := a; code_indent := i) f
(* The paren reader started at a line and column: [Reader.read_all] always (* The paren reader started at a line and column: [Reader.read_all] always
starts at 1:1. *) starts at 1:1. *)
@ -65,7 +71,7 @@ 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 ~file code with (match Indent_reader.read_all ~line ~col ?indent:!code_indent ~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 =

14
spec-syntax.md
View File

@ -202,9 +202,17 @@ Each item: the proposal, then the reason in one line.
Rect(w, h) -> w * h Rect(w, h) -> w * h
:north -> 0 :north -> 0
_ -> 0 _ -> 0
match code
404 -> "missing"
-1 -> "none"
"ok" -> "fine"
\a -> "a"
_ -> "other"
``` ```
An arm's body can be an indented block, which reads as `(do …)`. **Built** (a An arm's body can be an indented block, which reads as `(do …)`. **Built** (a
one-line block reads as that line). one-line block reads as that line). A number, char or string pattern is the
literal as written, compared as `(= t lit)`.
- **Conditions**, clauses at the header's column: - **Conditions**, clauses at the header's column:
``` ```
@ -357,6 +365,10 @@ Each step lands on its own, with `dune test --root .` green.
`flan--pause-bounds` at `flan.el:2637-2660`) must equal the start `flan--pause-bounds` at `flan.el:2637-2660`) must equal the start
location the reader gave that form. `Ast.mark_pause` matches exactly location the reader gave that form. `Ast.mark_pause` matches exactly
(`ast.ml:491-492`). (`ast.ml:491-492`).
**Built** (`emacs/flan-fln-mode.el`; keys and objects in `emacs/MANUAL.md`,
"Indented files"). A line ending in `=` or `fn(…)` also opens a block for
TAB, and a body is its statement's own block, up to its first clause.
6. **Return-type inference** in `Check`, with the recursion refusal and the 6. **Return-type inference** in `Check`, with the recursion refusal and the
stale-caller cause. This is independent of steps 1-5 once the marker exists. stale-caller cause. This is independent of steps 1-5 once the marker exists.

71
test/programs/match-literal.flan Normal file
View File

@ -0,0 +1,71 @@
;;;; match over numbers, chars, strings and dyn values: each arm is (= t lit)
;;;; over one temporary, and a _ arm is the rest.
(defn small [n i16] string
(match n
5 "five"
-3 "minus three"
_ "other"))
(defn half [x f32] i32
(match x
0.5 1
2 2
_ 0))
(defn letter [c u8] i32
(match c
\a 1
98 2
_ 0))
(defn command [s string] i32
(match s
"go" 1
"stop" 2
"" 3
_ 0))
(defn big [n u64] i32
(match n
18446744073709551615 1
_ 0))
;; Over a dyn the test is dyn =, so 1 matches 1.0 and "go" matches only a
;; string.
(defn kind [d dyn] string
(match d
1 "one"
2.5 "two and a half"
"go" "go"
_ "other"))
(defn calls [] i32
(print "(called) ")
7)
;; recur from inside an arm: the arm is the loop's tail.
(defn count-down [from i32] i32
(loop [n from steps 0]
(match n
0 steps
_ (recur (- n 1) (+ steps 1)))))
(defn main [] i32
(println (small 5))
(println (small -3))
(println (small 4))
(print (half 0.5)) (print (half 2.0)) (print (half 3.0)) (println "")
(print (letter 97)) (print (letter 98)) (print (letter 99)) (println "")
(print (command "go")) (print (command "stop")) (print (command ""))
(print (command "gone")) (println "")
(print (big 18446744073709551615)) (print (big 1)) (println "")
(println (kind 1))
(println (kind 1.0))
(println (kind 2.5))
(println (kind "go"))
(println (kind "1"))
;; The scrutinee is evaluated once, however many arms test it.
(println (match (calls) 1 "a" 2 "b" 7 "seven" _ "c"))
(print (count-down 4)) (println "")
0)

13
test/test_acceptance.ml
View File

@ -432,6 +432,19 @@ let () =
match_enum_out; match_enum_out;
outputs ~dev:true "match over an enum, dev" "programs/match-enum.flan" outputs ~dev:true "match over an enum, dev" "programs/match-enum.flan"
match_enum_out; match_enum_out;
(* A literal match is the same chain with (= t lit) as each test, so the
dyn rows (1 and 1.0 both "one") are dyn ='s answer. *)
let match_lit_out =
"five\nminus three\nother\n120\n120\n1230\n10\none\none\n\
two and a half\ngo\nother\n(called) seven\n4\n"
in
outputs "match over literals" "programs/match-literal.flan" match_lit_out;
outputs ~opt:"-O0" "match over literals, -O0" "programs/match-literal.flan"
match_lit_out;
outputs ~x86:true "match over literals, --x86" "programs/match-literal.flan"
match_lit_out;
outputs ~dev:true "match over literals, dev" "programs/match-literal.flan"
match_lit_out;
(* update, ++ and -- evaluate their place's subexpressions once: the (* update, ++ and -- evaluate their place's subexpressions once: the
counts are the number of calls an index or a key function got. *) counts are the number of calls an index or a key function got. *)
let update_out = "3\n11 20 90\n1 1 3\n16\n2\n7 1\n32\n2 50\n" in let update_out = "3\n11 20 90\n1 1 3\n16\n2\n7 1\n32\n2 50\n" in

83
test/test_flan.ml
View File

@ -2690,7 +2690,7 @@ let () =
accepts "a wildcard arm is exhaustive" accepts "a wildcard arm is exhaustive"
"(defn g [] (Option i32) None) (defn f [] i32 (match (g) (Some v) v _ 0))"; "(defn g [] (Option i32) None) (defn f [] i32 (match (g) (Some v) v _ 0))";
rejects_check "match on a non-Option" rejects_check "match on a non-Option"
"(defn f [x i32] i32 (match x _ 0))" ~needle:"match works on an Option"; "(defn f [x bool] i32 (match x _ 0))" ~needle:"match works on an Option";
(* ── Names, order-independence, entry point ────────────────────── *) (* ── Names, order-independence, entry point ────────────────────── *)
accepts "mutually recursive, no forward declaration" accepts "mutually recursive, no forward declaration"
@ -4582,8 +4582,85 @@ let () =
(k ^ "(defn f [k K] i32 (match k :lo 1 _ \"x\"))") (k ^ "(defn f [k K] i32 (match k :lo 1 _ \"x\"))")
~needle:"expected i32, found string"; ~needle:"expected i32, found string";
rejects_check "match over something that is none of them" rejects_check "match over something that is none of them"
"(defn f [n i32] i32 (match n _ 2))" "(defn f [n bool] i32 (match n _ 2))"
~needle:"match works on an Option, a data type or an enum, not on i32"; ~needle:"match works on an Option, a data type, an enum, a number, a \
string or a dyn, not on bool";
(* ── match over literals ───────────────────────────────────────── *)
(* Each arm is (= t lit) with the literal built at the scrutinee's type, so
a literal that type cannot hold is refused rather than widened into an
arm that never matches. *)
accepts "match over an i16, a literal arm built at i16"
"(defn f [n i16] i32 (match n 5 1 -3 2 _ 0))";
accepts "match over a string" "(defn f [s string] i32 (match s \"go\" 1 _ 0))";
accepts "match over a dyn, arms of several kinds"
"(defn f [d dyn] i32 (match d 1 1 2.5 2 \"go\" 3 \\a 4 _ 0))";
accepts "match over a number, :else for the rest"
"(defn f [n i32] i32 (match n 5 1 :else 0))";
rejects_check "a literal arm the scrutinee cannot hold"
"(defn f [n i8] i32 (match n 300 1 _ 0))"
~needle:"this match is over i8, so each arm has to be an i8, and 300 does \
not fit in one. Change the arm to a value an i8 holds, or remove it";
rejects_check "a float arm over an integer"
"(defn f [n i32] i32 (match n 1.5 1 _ 0))"
~needle:"and 1.5 is not a whole number";
rejects_check "a string arm over a number"
"(defn f [n i32] i32 (match n \"a\" 1 _ 0))"
~needle:"and \"a\" is a string";
rejects_check "a number arm over a string"
"(defn f [s string] i32 (match s 5 1 _ 0))"
~needle:"so each arm has to be a string, and 5 is a number";
rejects_check "a literal match with no _ arm"
"(defn f [n i32] i32 (match n 5 1 6 2))"
~needle:"this match is not exhaustive — its arms are literals, and no list \
of them covers every i32. Add a _ arm for the rest, as in (match \
n 5 1 _ 0)";
rejects_check "a literal match over a dyn with no _ arm"
"(defn f [d dyn] i32 (match d 5 1))"
~needle:"covers every dyn value";
rejects_check "a literal named twice"
"(defn f [n i32] i32 (match n 5 1 5 2 _ 0))"
~needle:"this match has two 5 arms";
rejects_check "a char and a number that are one u8"
"(defn f [c u8] i32 (match c \\a 1 97 2 _ 0))"
~needle:"this match has two \\a arms — 97 equals it as a u8";
rejects_check "1 and 1.0 are one arm over a dyn, as dyn = says"
"(defn f [d dyn] i32 (match d 1 1 1.0 2 _ 0))"
~needle:"this match has two 1 arms — 1.0 equals it as a dyn";
rejects_check "two literals that round to one f32"
"(defn f [x f32] i32 (match x 0.1 1 0.10000000001 2 _ 0))"
~needle:"this match has two 0.1 arms — 0.10000000001 equals it as an f32";
rejects_check "two integers that round to one f32"
"(defn f [x f32] i32 (match x 16777216 1 16777217 2 _ 0))"
~needle:"two 16777216 arms — 16777217 equals it as an f32";
rejects_check "an integer and a float that are one f64"
"(defn f [x f64] i32 \
(match x 4611686018427387904 1 4611686018427387904.0 2 _ 0))"
~needle:"equals it as an f64";
accepts "two f64 literals that differ"
"(defn f [x f64] i32 (match x 0.1 1 0.10000000001 2 _ 0))";
rejects_check "a literal no dyn holds"
"(defn f [x dyn] i32 (match x 18446744073709551615 1 _ 0))"
~needle:"this match is over a dyn, which holds a number as an i64 or an \
f64, and 18446744073709551615 fits in neither. Change the arm to \
a value an i64 holds, or remove it";
rejects_check "a keyword arm among literal arms"
"(defn f [n i32] i32 (match n 5 1 :lo 2 _ 0))"
~needle:":lo is an enum member, and this match is over i32, whose arms are \
literals, as in (match n 5 1 _ 0)";
rejects_check "a case arm among literal arms"
"(defn f [n i32] i32 (match n 5 1 (Some x) 2 _ 0))"
~needle:"Some names a case, and this match is over i32";
rejects_check "a literal arm among keyword arms"
(k ^ "(defn f [k K] i32 (match k :lo 1 5 2 _ 0))")
~needle:"5 is a literal, and this match is over the enum K";
rejects_check "a literal arm over an Option"
"(defn f [o (Option i32)] i32 (match o 5 1 _ 0))"
~needle:"5 is a literal, and this match is over an Option";
rejects_check "a literal match over a byte slice, which = does not compare"
"(defn f [b [u8]] i32 (match b \"a\" 1 _ 0))"
~needle:"not on [u8]";
(* A destructuring pattern in an arm's binds is a name position like any (* A destructuring pattern in an arm's binds is a name position like any
other. *) other. *)
rejects_check "a pattern inside a match arm's binds" rejects_check "a pattern inside a match arm's binds"

18
test/test_syntax.ml
View File

@ -362,6 +362,8 @@ let () =
"(restart-case (f) (continue [] (do)))"; "(restart-case (f) (continue [] (do)))";
reads "match" "match s\n Circle(r) -> r\n _ ->\n a()\n b()" reads "match" "match s\n Circle(r) -> r\n _ ->\n a()\n b()"
"(match s (Circle r) r _ (do (a) (b)))"; "(match s (Circle r) r _ (do (a) (b)))";
reads "match over literals" "match n\n 5 -> a\n -2.5 -> b\n \"go\" -> c\n \\a -> d\n _ -> e"
"(match n 5 a -2.5 b \"go\" c \\a d _ e)";
reads "handler-bind moves the clauses" "handler-bind\n f()\non E(c)\n g(c)" reads "handler-bind moves the clauses" "handler-bind\n f()\non E(c)\n g(c)"
"(handler-bind [(E [c] (g c))] (f))"; "(handler-bind [(E [c] (g c))] (f))";
reads "quote block" reads "quote block"
@ -493,6 +495,22 @@ let () =
| [ _; _ ] -> () | [ _; _ ] -> ()
| _ -> fail "a snippet with leading spaces" | _ -> fail "a snippet with leading spaces"
| exception e -> fail "a snippet with leading spaces: %s" (diag_text e)); | exception e -> fail "a snippet with leading spaces: %s" (diag_text e));
(* A condition cut out from after [elif ] at column 3: its wrapped line at
column 8 is deeper than the elif, which is what the file says, though not
deeper than the cut. [:indent] says where the statement starts; every
location stays the buffer's own. *)
Source.with_code ~indent:3 ~syntax:Source.Indented ~at:(Some (10, 8)) (fun () ->
(match Source.read_code ~expr:true ~file:"<buf>" "x == 0 or\n x == 1" with
| [ f ] -> span_is "a wrapped condition, cut mid-line" f (10, 8, 11, 14)
| _ -> fail "a wrapped condition read as more than one form"
| exception e -> fail "a wrapped condition: %s" (diag_text e));
match Source.read_code ~expr:true ~file:"<buf>" "x == 0 or\n x == 1" with
| _ -> fail "a continuation left of its statement was read"
| exception Loc.Error _ -> ());
Source.with_code ~syntax:Source.Indented ~at:(Some (10, 8)) (fun () ->
match Source.read_code ~expr:true ~file:"<buf>" "x == 0 or\n x == 1" with
| _ -> fail "without :indent, a wrapped line is measured from the cut"
| exception Loc.Error _ -> ());
Source.with_code ~syntax:Source.Paren ~at:(Some (7, 3)) (fun () -> Source.with_code ~syntax:Source.Paren ~at:(Some (7, 3)) (fun () ->
match Source.read_code ~file:"<buf>" "(f 1)" with match Source.read_code ~file:"<buf>" "(f 1)" with
| [ f ] -> span_is "a paren snippet" f (7, 3, 7, 8) | [ f ] -> span_is "a paren snippet" f (7, 3, 7, 8)

7
web/index.html
View File

@ -1096,8 +1096,11 @@ as <code>first-even</code> does above.</p>
<h3>Option, <code>match</code> and <code>some</code></h3> <h3>Option, <code>match</code> and <code>some</code></h3>
<p><code>(Option T)</code> is how absence is spelled: a lookup miss, an empty <p><code>(Option T)</code> is how absence is spelled: a lookup miss, an empty
collection, the end of a stream. <code>match</code> works on an <code>Option</code> and collection, the end of a stream. <code>match</code> works on an <code>Option</code>, a
on a <code>defdata</code>, and on nothing else. <code>some</code> unwraps <code>defdata</code> and an enum, whose arms name cases; and on a number, a string or a
<code>dyn</code>, whose arms are literals &mdash; <code>(match n 0 "zero" -1 "none" _ "some")</code>
&mdash; each compared with <code>=</code>, with a <code>_</code> arm required for the rest.
<code>some</code> unwraps
<code>Some</code> and early-returns <code>None</code> from the enclosing function.</p> <code>Some</code> and early-returns <code>None</code> from the enclosing function.</p>
<pre><code>(defconst nums [4 i32] [4 8 15 16]) <pre><code>(defconst nums [4 i32] [4 8 15 16])