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

Merge master

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-25 21:11:31 +07:00
commit 4fa11f6360
35 changed files with 5280 additions and 306 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
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
@ -637,6 +646,10 @@ of !=.
* Checker * Checker
** WAIT A _ body that returns an fn literal
Refused today; allowing it when the literal writes its parameter types is the
proposal. Postponed 2026-09-25 while .fln takes priority.
** DONE The ownership flow analysis is repealed ** DONE The ownership flow analysis is repealed
CLOSED: [2026-09-18] CLOSED: [2026-09-18]
Static use-after-move and double-free checking is gone; types, allocators and the Static use-after-move and double-free checking is gone; types, allocators and the
@ -736,15 +749,10 @@ depth it gave up at. The bare depth number is a backstop that also prints the
chain. Before any of it, the compiler hung rather than failed, which wedges =C-c chain. Before any of it, the compiler hung rather than failed, which wedges =C-c
C-c= with nothing to show. C-c= with nothing to show.
** NEXT Generic types ** DONE Generic types
Decided 2026-09-25: the freeze is lifted for this; build both type and length parameters. CLOSED: [2026-09-25]
=(defstruct Pair [a $t b $t])= cannot be spelled, and neither can a length A struct's parameters are its fields' $-names in first-written order, a length by position; there is no
parameter. =Types.Named= is a bare string with no room for parameters; giving it explicit parameter vector. Each application is an ordinary struct under a key, so no backend sees a parameter.
some changes the type, the layout calculator, both backends, the renderer and the
DWARF path. Same price for one as for both. Decided and unblocked, deliberately
not started — it is a language feature under a freeze, and it was stopped once
already for that reason. The motivating case is Odin's =Small_Array=: a
fixed-capacity array with a count and no allocation.
** WAIT A value predicate over a length parameter ** WAIT A value predicate over a length parameter
Decided 2026-09-25: waits until a program wants one. Decided 2026-09-25: waits until a program wants one.
@ -753,12 +761,6 @@ clause here admits nothing but type predicates. Whether it should take value
predicates over a length parameter deserves answering deliberately rather than predicates over a length parameter deserves answering deliberately rather than
falling out of the implementation. falling out of the implementation.
** TODO "In instantiation of" notes
A refusal inside a copy points at the generic's source with no note naming the
call site that asked for that type. The data is there — =instantiation_origin=
exists and the session already uses it — and wiring it into every failure under an
instantiation is a lane of its own.
** DONE A program is one compilation, so a generic's body is always visible ** DONE A program is one compilation, so a generic's body is always visible
CLOSED: [2026-09-25] CLOSED: [2026-09-25]
Odin's and Zig's model: packages are never compiled separately. The cost is build Odin's and Zig's model: packages are never compiled separately. The cost is build
@ -982,15 +984,6 @@ ignore order, writable access has to alias the real storage. Flexible field orde
waits for classes deliberately, because a class owns its layout and a =Vector2= waits for classes deliberately, because a class owns its layout and a =Vector2=
should not pay for identity and metadata. Not implemented. should not pay for identity and metadata. Not implemented.
** TODO An error in a called generic's body is reported twice
=(defn g [x $t] u64 (nosuch x))= called once from =main= prints "unknown
function nosuch" twice at the same place and counts 2 errors — once from the
abstract pass and once from the instantiation.
** TODO A type variable is printed without its $
=Types.to_string= prints =Var t= as =t=, so a refusal reads "selection-sort
expects [t] here, found [3 i32]" where the source wrote =[$t]=.
** DONE Two refusals suggested something that does not compile ** DONE Two refusals suggested something that does not compile
CLOSED: [2026-09-25] CLOSED: [2026-09-25]
=vec-new= and =map-new= with no type no longer say "or give the binding a type"; =vec-new= and =map-new= with no type no longer say "or give the binding a type";
@ -1448,6 +1441,11 @@ out the first element typing the rest.
* Dev loop * Dev loop
** WAIT A _ caller whose type follows a redefined callee
Its signature changes in the session but its body is not recompiled, so every call
stops on StaleCall naming a type nobody wrote. Proposal: recompile such callers.
Postponed 2026-09-25 while .fln takes priority.
** TODO A prelude function shadowed live is reached by the prelude's own calls ** TODO A prelude function shadowed live is reached by the prelude's own calls
A defn of a prelude function's name sent to a running =flan dev= installs into the A defn of a prelude function's name sent to a running =flan dev= installs into the
host's cell for that name, so the prelude's calls compiled into the host follow it; host's cell for that name, so the prelude's calls compiled into the host follow it;

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

@ -2034,6 +2034,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)

7
lib/ast.ml
View File

@ -24,6 +24,9 @@ and texpr_kind =
them identically — the difference is a fact about the value, and it is them identically — the difference is a fact about the value, and it is
[Check.resolve] that turns it into one. *) [Check.resolve] that turns it into one. *)
| Tfn of bool * texpr list * texpr | Tfn of bool * texpr list * texpr
(* An integer written as a generic struct's argument, the 8 in
(Small 8 i32). Parsed only there; it is not a type anywhere else. *)
| Tlen of int64
(* An array length is an integer or a compile-time constant's name. *) (* An array length is an integer or a compile-time constant's name. *)
and len = and len =
@ -219,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 ──────────────────────────────────────────────────── *)

1413
lib/check.ml
View File

File diff suppressed because it is too large Load Diff

1
lib/cimport.ml
View File

@ -407,6 +407,7 @@ let rec ty_source (t : Ast.texpr) =
| Ast.Tname n -> n | Ast.Tname n -> n
| Ast.Tapp (n, args) -> | Ast.Tapp (n, args) ->
Printf.sprintf "(%s %s)" n (String.concat " " (List.map ty_source args)) Printf.sprintf "(%s %s)" n (String.concat " " (List.map ty_source args))
| Ast.Tlen n -> Int64.to_string n
| Ast.Tslice (c, e) -> | Ast.Tslice (c, e) ->
Printf.sprintf "[%s%s]" (if c then "const " else "") (ty_source e) Printf.sprintf "[%s%s]" (if c then "const " else "") (ty_source e)
| Ast.Tarray (Ast.Lint n, e) -> Printf.sprintf "[%Ld %s]" n (ty_source e) | Ast.Tarray (Ast.Lint n, e) -> Printf.sprintf "[%Ld %s]" n (ty_source e)

44
lib/dev.ml
View File

@ -704,14 +704,12 @@ let host_loc t name =
that was written finds nothing in the program, and these are how it gets that was written finds nothing in the program, and these are how it gets
from that name to what the program does hold. *) from that name to what the program does hold. *)
(* Its signature as written, [$] and all — [Types.to_string] prints a variable (* Its signature as written, [$] and all. *)
bare, and [[t]] is not how anyone wrote it. *)
let generic_signature t name = let generic_signature t name =
match Hashtbl.find_opt t.session.Session.env.Check.gsigs name with match Hashtbl.find_opt t.session.Session.env.Check.gsigs name with
| None -> None | None -> None
| Some (vars, params, ret) -> | Some (_, params, ret) ->
let dollar = List.map (fun v -> (v, Types.Var ("$" ^ v))) vars in let show ty = Types.to_string ty in
let show ty = Types.to_string (Check.subst_ty dollar ty) in
Some Some
(Printf.sprintf "%s [%s] %s" name (Printf.sprintf "%s [%s] %s" name
(String.concat " " (List.map show params)) (show ret)) (String.concat " " (List.map show params)) (show ret))
@ -1914,8 +1912,27 @@ let defs t =
~loc:(Loc.to_string loc) ()) ~loc:(Loc.to_string loc) ())
classes classes
in in
(* A generic struct is listed by its template, as [(Pair $t)]; its copies
are struct names only the compiler wrote. *)
let structs =
Hashtbl.fold
(fun name _ acc ->
if Hashtbl.mem env.Check.copies name then acc
else entry ~name ~kind:"struct" ~sign:name ~loc:"" () :: acc)
env.Check.structs []
@ Hashtbl.fold
(fun name (g : Check.gstruct) acc ->
entry ~name ~kind:"struct"
~sign:
(Printf.sprintf "(%s %s)" name
(String.concat " "
(List.map (fun (p, _) -> "$" ^ p) g.Check.gparams)))
~loc:"" ()
:: acc)
env.Check.gstructs []
in
List.sort compare List.sort compare
(of_table "struct" env.Check.structs (structs
@ datas @ classes @ datas @ classes
@ of_table "union" env.Check.unions @ of_table "union" env.Check.unions
@ of_table "enum" env.Check.enums @ of_table "enum" env.Check.enums
@ -1996,13 +2013,19 @@ let defs t =
text about the type and never touches the program. *) text about the type and never touches the program. *)
let layout t ~ty = let layout t ~ty =
let structs = t.session.Session.program.Tast.structs in let structs = t.session.Session.program.Tast.structs in
(* A generic struct's copy answers to the spelling a printed value's head
gives it, [Pair i32], and to its type's, [(Pair i32)], as well as to its
key. *)
let names (s : Tast.structure) =
[ s.Tast.sname; Types.struct_head s.Tast.sname;
Types.to_string (Types.Named s.Tast.sname) ]
in
match match
List.find_opt (fun (s : Tast.structure) -> String.equal s.Tast.sname ty) List.find_opt (fun (s : Tast.structure) -> List.mem ty (names s)) structs
structs
with with
| Some s -> | Some s ->
ok ok
[ ":type " ^ Wire.quote s.Tast.sname; [ ":type " ^ Wire.quote (Types.to_string (Types.Named s.Tast.sname));
":fields " ":fields "
^ Wire.list ^ Wire.list
(List.map (List.map
@ -4545,7 +4568,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

7
lib/emit.ml
View File

@ -370,7 +370,7 @@ let rec ll (t : Types.t) =
integer spelling costs no casts and keeps the emitter honest about not integer spelling costs no casts and keeps the emitter honest about not
knowing whether the bits are a pointer. *) knowing whether the bits are a pointer. *)
| Types.Dyn -> "i64" | Types.Dyn -> "i64"
| Types.Var _ -> | Types.Var _ | Types.Len _ | Types.LArray _ ->
(* The checker rejects it by name — nothing reaches here. *) (* The checker rejects it by name — nothing reaches here. *)
internal "no layout for %s" (Types.to_string t) internal "no layout for %s" (Types.to_string t)
@ -647,7 +647,8 @@ let rec lay m (t : Types.t) : int * int =
| Some u -> union_lay m u | Some u -> union_lay m u
| None -> internal "no layout for struct %s" n) | None -> internal "no layout for struct %s" n)
| Types.Dyn -> 8, 8 | Types.Dyn -> 8, 8
| Types.Var _ -> internal "no layout for %s" (Types.to_string t) | Types.Var _ | Types.Len _ | Types.LArray _ ->
internal "no layout for %s" (Types.to_string t)
(* Size, alignment, and the offset of every member. *) (* Size, alignment, and the offset of every member. *)
and lay_fields m tys = and lay_fields m tys =
@ -1210,7 +1211,7 @@ let rec dty m d (t : Types.t) : int =
reading: it prints, and the person reading it can hand it to the reading: it prints, and the person reading it can hand it to the
runtime's own printer. *) runtime's own printer. *)
| Types.Dyn -> basic "dyn" 64 "DW_ATE_unsigned" | Types.Dyn -> basic "dyn" 64 "DW_ATE_unsigned"
| Types.Var _ -> | Types.Var _ | Types.Len _ | Types.LArray _ ->
internal "no debug type for %s" (Types.to_string t) internal "no debug type for %s" (Types.to_string t)
in in
Hashtbl.replace d.dtys key n; Hashtbl.replace d.dtys key n;

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/js.ml
View File

@ -249,6 +249,8 @@ let rec refuse_ty loc (t : Types.t) =
host's own, and that work has not been done" host's own, and that work has not been done"
| Types.Var n -> | Types.Var n ->
at loc "a type variable (%s) reached the backend, which cannot happen" n at loc "a type variable (%s) reached the backend, which cannot happen" n
| Types.Len _ | Types.LArray _ ->
at loc "a length variable reached the backend, which cannot happen"
(* Aggregates in the sense that matters here: the types whose assignment (* Aggregates in the sense that matters here: the types whose assignment
copies in Flan and would alias in JS. A slice is deliberately not one — copies in Flan and would alias in JS. A slice is deliberately not one —

10
lib/load.ml
View File

@ -213,8 +213,11 @@ let rec rename_texpr owned alias (t : Ast.texpr) : Ast.texpr =
Ast.Tarray (rename_len owned alias l, rename_texpr owned alias e) Ast.Tarray (rename_len owned alias l, rename_texpr owned alias e)
| Ast.Tmap (k, v) -> | Ast.Tmap (k, v) ->
Ast.Tmap (rename_texpr owned alias k, rename_texpr owned alias v) Ast.Tmap (rename_texpr owned alias k, rename_texpr owned alias v)
(* The head too, when it is a generic struct the package declares. *)
| Ast.Tapp (n, args) -> | Ast.Tapp (n, args) ->
let n = if List.mem n owned then qualify alias n else n in
Ast.Tapp (n, List.map (rename_texpr owned alias) args) Ast.Tapp (n, List.map (rename_texpr owned alias) args)
| Ast.Tlen _ as k -> k
| Ast.Tfn (env, ps, r) -> | Ast.Tfn (env, ps, r) ->
Ast.Tfn (env, List.map (rename_texpr owned alias) ps, Ast.Tfn (env, List.map (rename_texpr owned alias) ps,
rename_texpr owned alias r) rename_texpr owned alias r)
@ -271,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)
@ -800,8 +803,11 @@ let rec texpr_uses acc (t : Ast.texpr) =
(match l with Ast.Lname n -> acc := (n, t.Ast.tloc) :: !acc | Ast.Lint _ -> ()); (match l with Ast.Lname n -> acc := (n, t.Ast.tloc) :: !acc | Ast.Lint _ -> ());
texpr_uses acc e texpr_uses acc e
| Ast.Tmap (k, v) -> texpr_uses acc k; texpr_uses acc v | Ast.Tmap (k, v) -> texpr_uses acc k; texpr_uses acc v
| Ast.Tapp (_, args) -> List.iter (texpr_uses acc) args | Ast.Tapp (n, args) ->
acc := (n, t.Ast.tloc) :: !acc;
List.iter (texpr_uses acc) args
| Ast.Tfn (_, ps, r) -> List.iter (texpr_uses acc) ps; texpr_uses acc r | Ast.Tfn (_, ps, r) -> List.iter (texpr_uses acc) ps; texpr_uses acc r
| Ast.Tlen _ -> ()
let rec expr_uses acc (e : Ast.expr) = let rec expr_uses acc (e : Ast.expr) =
let go = expr_uses acc in let go = expr_uses acc in

51
lib/parse.ml
View File

@ -99,6 +99,16 @@ let no_pattern (f : Form.t) =
(* ── Type expressions ──────────────────────────────────────────────── *) (* ── Type expressions ──────────────────────────────────────────────── *)
(* A type constructor's spelling: its last segment starts with a capital. *)
let capitalised_name name =
let base =
match String.rindex_opt name '/' with
| Some i -> String.sub name (i + 1) (String.length name - i - 1)
| None -> name
in
base <> "" && Char.uppercase_ascii base.[0] = base.[0]
&& Char.lowercase_ascii base.[0] <> base.[0]
let rec texpr (f : Form.t) : Ast.texpr = let rec texpr (f : Form.t) : Ast.texpr =
let mk t = { Ast.t; tloc = f.loc } in let mk t = { Ast.t; tloc = f.loc } in
match f.v with match f.v with
@ -161,8 +171,44 @@ let rec texpr (f : Form.t) : Ast.texpr =
| [ { v = Vec params; _ }; ret ] -> | [ { v = Vec params; _ }; ret ] ->
mk (Ast.Tfn (env, List.map texpr params, texpr ret)) mk (Ast.Tfn (env, List.map texpr params, texpr ret))
| _ -> fail f "a function type is (%s [T ...] R)" which) | _ -> fail f "a function type is (%s [T ...] R)" which)
| List ({ v = Sym name; _ } :: args) when args <> [] -> | List ({ v = Sym name; _ } :: args)
mk (Ast.Tapp (name, List.map texpr args)) when args <> [] || capitalised_name name ->
(* An integer argument is a generic struct's length, and a type
constructor is capitalised. A lowercase head is a body form in the
return slot — (+ x 1) — and its integer is the type parser's reason to
give up, which is the refusal that slot is built on. *)
let capitalised = capitalised_name name in
(* Integer arithmetic over literals is a length too — [(Small (+ 4 4)
i32)] — folded here, since nothing later reads it as a value. *)
let rec fold (a : Form.t) =
match a.v with
| Int n -> Some n
| List ({ v = Sym (("+" | "-" | "*") as op); _ } :: (_ :: _ as xs)) ->
let vs = List.map fold xs in
if List.for_all Option.is_some vs then
let vs = List.map Option.get vs in
match op, vs with
| "-", [ x ] -> Some (Int64.neg x)
| "+", v :: rest -> Some (List.fold_left Int64.add v rest)
| "-", v :: rest -> Some (List.fold_left Int64.sub v rest)
| "*", v :: rest -> Some (List.fold_left Int64.mul v rest)
| _ -> None
else None
| _ -> None
in
let arg (a : Form.t) =
match a.v, fold a with
| _, Some n when capitalised -> { Ast.t = Ast.Tlen n; tloc = a.loc }
| List _, None when capitalised ->
(try texpr a with
| Loc.Error _ ->
fail a
"%s is not a type or a length. An argument here is a type, or a \
length: an integer, a constant's name or a length variable"
(Form.to_string a))
| _ -> texpr a
in
mk (Ast.Tapp (name, List.map arg args))
| _ -> fail f "expected a type, found %s" (Form.to_string f) | _ -> fail f "expected a type, found %s" (Form.to_string f)
and len (f : Form.t) : Ast.len = and len (f : Form.t) : Ast.len =
@ -1356,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)

8
lib/render.ml
View File

@ -103,6 +103,12 @@ let print_refusal _loc t =
Printf.sprintf "no printer for %s — print the values you want out of it" Printf.sprintf "no printer for %s — print the values you want out of it"
(Types.to_string t) (Types.to_string t)
(* The head a struct value prints under: its name, or for a generic struct's
copy the template and its arguments, [Pair i32], so the value reads
[(Pair i32 {.a 1 .b 2})] the way its type is written. Every renderer of a
struct value goes through this, so they all print the same text. *)
let head n = Types.struct_head n
let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr list = let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr list =
let render c depth e = render ~refuse c depth e in let render c depth e = render ~refuse c depth e in
let loc = e.Tast.loc in let loc = e.Tast.loc in
@ -333,7 +339,7 @@ let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr lis
@ render c (depth + 1) v) @ render c (depth + 1) v)
shown) shown)
in in
[ do_ ((lit ("(" ^ n ^ " {") :: parts) [ do_ ((lit ("(" ^ head n ^ " {") :: parts)
@ (if List.length fields > max_span then [ lit " ..." ] else []) @ (if List.length fields > max_span then [ lit " ..." ] else [])
@ [ lit "})" ]) ]) @ [ lit "})" ]) ])
(* A fixed array's length is in its type, so it unrolls — capped, because (* A fixed array's length is in its type, so it unrolls — capped, because

40
lib/session.ml
View File

@ -597,7 +597,7 @@ let compatible ~loc (old_ : Tast.program) (new_ : Tast.program) =
if not same then if not same then
fail loc fail loc
"%s changes layout. Restart to change it." "%s changes layout. Restart to change it."
s.Tast.sname (Types.to_string (Types.Named s.Tast.sname))
| None -> ()) | None -> ())
new_.Tast.structs new_.Tast.structs
@ -1596,7 +1596,7 @@ let render_locals ?(origin = "<locals>") t ~frame ~(fn : Tast.fn) ~bound
let loc = fn.Tast.floc in let loc = fn.Tast.floc in
let extra = ref [] and nslots = ref 0 in let extra = ref [] and nslots = ref 0 in
let c = let c =
{ Render.structs = t.program.Tast.structs; { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas; datas = t.program.Tast.datas;
unions = t.program.Tast.unions; unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -1708,7 +1708,7 @@ let render_condition t ~(st : Tast.structure) : change * (string * string) list
let loc = Loc.unknown in let loc = Loc.unknown in
let extra = ref [] and nslots = ref 0 in let extra = ref [] and nslots = ref 0 in
let c = let c =
{ Render.structs = t.program.Tast.structs; { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas; datas = t.program.Tast.datas;
unions = t.program.Tast.unions; unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -1969,7 +1969,7 @@ let render_slot ?(origin = "<inspect>") t ~frame ~(fn : Tast.fn) ~slot ~path
| Some name -> | Some name ->
let extra = ref [] and nslots = ref 0 in let extra = ref [] and nslots = ref 0 in
let c = let c =
{ Render.structs = t.program.Tast.structs; { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas; datas = t.program.Tast.datas;
unions = t.program.Tast.unions; unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -2286,7 +2286,7 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
in in
let extra = ref [] and nslots = ref (Array.length base) in let extra = ref [] and nslots = ref (Array.length base) in
let c = let c =
{ Render.structs = t.program.Tast.structs; { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas; datas = t.program.Tast.datas;
unions = t.program.Tast.unions; unions = t.program.Tast.unions;
enums = enums =
@ -2323,11 +2323,15 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
Array.append bnames Array.append bnames
(Array.make (List.length !extra) None) } (Array.make (List.length !extra) None) }
in in
(* A struct copy the values named first, laid out in this
module and kept, as [eval_expr] keeps one. *)
let copies = Check.fresh_copies t.env t.program.Tast.structs in
let program = let program =
{ t.program with { t.program with
Tast.fns = Tast.fns =
t.program.Tast.fns @ fresh @ claim_lifted t lmark tname t.program.Tast.fns @ fresh @ claim_lifted t lmark tname
@ [ thunk ]; @ [ thunk ];
structs = t.program.Tast.structs @ copies;
externs = t.program.Tast.externs @ externs } externs = t.program.Tast.externs @ externs }
in in
let ir = let ir =
@ -2340,7 +2344,9 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
[eval_expr] says why, and the caller takes the same [held] [eval_expr] says why, and the caller takes the same [held]
around this that it takes around one. *) around this that it takes around one. *)
t.program <- t.program <-
{ t.program with Tast.fns = t.program.Tast.fns @ fresh }; { t.program with
Tast.fns = t.program.Tast.fns @ fresh;
structs = t.program.Tast.structs @ copies };
Ok Ok
({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] },
where, Types.to_string shown.Tast.ty)))) where, Types.to_string shown.Tast.ty))))
@ -2412,7 +2418,7 @@ let arm_restart ?(origin = "<restart>") t ~index ~(params : Types.t list)
in in
let extra = ref [] and nslots = ref (Array.length base) in let extra = ref [] and nslots = ref (Array.length base) in
let c = let c =
{ Render.structs = t.program.Tast.structs; { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas; datas = t.program.Tast.datas;
unions = t.program.Tast.unions; unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -2453,17 +2459,22 @@ let arm_restart ?(origin = "<restart>") t ~index ~(params : Types.t list)
slots = Array.append base (Array.of_list (List.rev !extra)); slots = Array.append base (Array.of_list (List.rev !extra));
snames = Array.append bnames (Array.make (List.length !extra) None) } snames = Array.append bnames (Array.make (List.length !extra) None) }
in in
let copies = Check.fresh_copies t.env t.program.Tast.structs in
let program = let program =
{ t.program with { t.program with
Tast.fns = Tast.fns =
t.program.Tast.fns @ fresh @ claim_lifted t lmark tname @ [ thunk ]; t.program.Tast.fns @ fresh @ claim_lifted t lmark tname @ [ thunk ];
structs = t.program.Tast.structs @ copies;
externs = t.program.Tast.externs @ externs } externs = t.program.Tast.externs @ externs }
in in
let ir = let ir =
redefinition t ~call:tname program redefinition t ~call:tname program
~fns:(List.map (fun (f : Tast.fn) -> f.Tast.name) fresh @ [ tname ]) ~fns:(List.map (fun (f : Tast.fn) -> f.Tast.name) fresh @ [ tname ])
in in
t.program <- { t.program with Tast.fns = t.program.Tast.fns @ fresh }; t.program <-
{ t.program with
Tast.fns = t.program.Tast.fns @ fresh;
structs = t.program.Tast.structs @ copies };
Ok Ok
({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] },
List.map Types.to_string params) List.map Types.to_string params)
@ -2496,7 +2507,7 @@ let render_globals ?(origin = "<globals>") t ~(globals : Tast.global list)
let loc = Loc.unknown in let loc = Loc.unknown in
let extra = ref [] and nslots = ref 0 in let extra = ref [] and nslots = ref 0 in
let c = let c =
{ Render.structs = t.program.Tast.structs; { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas; datas = t.program.Tast.datas;
unions = t.program.Tast.unions; unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -2682,7 +2693,7 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) ?frame t src : change =
appended past [base] and collected here to size the frame below. *) appended past [base] and collected here to size the frame below. *)
let extra = ref [] and nslots = ref (Array.length base) in let extra = ref [] and nslots = ref (Array.length base) in
let c = let c =
{ Render.structs = t.program.Tast.structs; { Render.structs = t.program.Tast.structs @ Check.fresh_copies t.env t.program.Tast.structs;
datas = t.program.Tast.datas; datas = t.program.Tast.datas;
unions = t.program.Tast.unions; unions = t.program.Tast.unions;
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
@ -2728,10 +2739,12 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) ?frame t src : change =
let placed = let placed =
List.filter (fun (f : Tast.fn) -> List.mem f.Tast.name own) placed List.filter (fun (f : Tast.fn) -> List.mem f.Tast.name own) placed
in in
let copies = Check.fresh_copies t.env t.program.Tast.structs in
let program = let program =
{ t.program with { t.program with
Tast.fns = t.program.Tast.fns @ fresh @ placed; Tast.fns = t.program.Tast.fns @ fresh @ placed;
structs = t.program.Tast.structs @ Check.env_structs t.env lifted; structs =
t.program.Tast.structs @ copies @ Check.env_structs t.env lifted;
externs = t.program.Tast.externs @ externs } externs = t.program.Tast.externs @ externs }
in in
let ir = let ir =
@ -2757,7 +2770,10 @@ let eval_expr ?(origin = "<eval>") ?(pause = false) ?frame t src : change =
caller closes that half by taking a [held] before this and restoring it caller closes that half by taking a [held] before this and restoring it
when either fails — a copy the session holds and no module defines is a when either fails — a copy the session holds and no module defines is a
null cell exactly as a stranded declaration is. *) null cell exactly as a stranded declaration is. *)
t.program <- { t.program with Tast.fns = t.program.Tast.fns @ fresh }; t.program <-
{ t.program with
Tast.fns = t.program.Tast.fns @ fresh;
structs = t.program.Tast.structs @ copies };
{ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] } { ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }
(* ── What a macro call expands to ──────────────────────────────────── *) (* ── What a macro call expands to ──────────────────────────────────── *)

119
lib/shim.ml
View File

@ -177,6 +177,106 @@ let prim_cty = function
| "bool" -> Some "bool" | "bool" -> Some "bool"
| _ -> None | _ -> None
(* ── Generic structs ──────────────────────────────────────────────────
A defstruct whose fields introduce [$t] is a template, and C only ever sees
one of its copies: the fields with the arguments written in, laid out the
way [Check] lays the same copy out. The copy is registered here under its
written spelling, [(G u8)], which [ctype_name] turns into a C name. *)
let sigil n = n <> "" && n.[0] = '$'
let bare n = if sigil n then String.sub n 1 (String.length n - 1) else n
(* A template's parameters, in the order its fields first introduce them, and
whether each is a length — [Check]'s reading, repeated over the AST
because this runs before [Check] does. *)
let rec template_params ?(fuel = 16) env n =
match Hashtbl.find_opt env.structs n with
| None -> []
| Some fs ->
let acc = ref [] in
let add m is_len =
if sigil m && not (List.mem_assoc (bare m) !acc) then
acc := (bare m, is_len) :: !acc
in
let rec walk (t : Ast.texpr) =
match t.Ast.t with
| Ast.Tname m -> add m false
| Ast.Tslice (_, e) -> walk e
| Ast.Tarray (Ast.Lname m, e) -> add m true; walk e
| Ast.Tarray (_, e) -> walk e
| Ast.Tmap (k, v) -> walk k; walk v
| Ast.Tapp (h, args) ->
let kinds =
if fuel = 0 || String.equal h n then []
else List.map snd (template_params ~fuel:(fuel - 1) env h)
in
if List.length kinds = List.length args then
List.iter2
(fun is_len (a : Ast.texpr) ->
match a.Ast.t with
| Ast.Tname m when is_len -> add m true
| _ -> walk a)
kinds args
else List.iter walk args
| Ast.Tfn (_, ps, r) -> List.iter walk ps; walk r
| Ast.Tlen _ -> ()
in
List.iter (fun (f : Ast.field) -> walk f.Ast.fty) fs;
List.rev !acc
let rec source (t : Ast.texpr) =
match t.Ast.t with
| Ast.Tname n -> n
| Ast.Tlen n -> Int64.to_string n
| Ast.Tapp (n, args) ->
Printf.sprintf "(%s %s)" n (String.concat " " (List.map source args))
| Ast.Tslice (c, e) -> Printf.sprintf "[%s%s]" (if c then "const " else "") (source e)
| Ast.Tarray (Ast.Lint n, e) -> Printf.sprintf "[%Ld %s]" n (source e)
| Ast.Tarray (Ast.Lname n, e) -> Printf.sprintf "[%s %s]" n (source e)
| Ast.Tmap (k, v) -> Printf.sprintf "(Map %s %s)" (source k) (source v)
| Ast.Tfn (env, ps, r) ->
Printf.sprintf "(%s [%s] %s)" (if env then "Fn" else "CFn")
(String.concat " " (List.map source ps)) (source r)
(* The copy of template [n] at [args], registered and named. *)
let copy env ~loc n (args : Ast.texpr list) =
let ps = template_params env n in
if List.length ps <> List.length args then
fail loc "%s takes %d argument%s, and this gives %d" n (List.length ps)
(if List.length ps = 1 then "" else "s") (List.length args);
let key = source { Ast.t = Ast.Tapp (n, args); tloc = loc } in
if not (Hashtbl.mem env.structs key) then begin
let sub = List.combine (List.map fst ps) args in
let rec go (t : Ast.texpr) =
let k =
match t.Ast.t with
| Ast.Tname m when List.mem_assoc (bare m) sub ->
(List.assoc (bare m) sub).Ast.t
| Ast.Tname _ | Ast.Tlen _ -> t.Ast.t
| Ast.Tslice (c, e) -> Ast.Tslice (c, go e)
| Ast.Tarray (Ast.Lname m, e) when List.mem_assoc (bare m) sub ->
let l =
match (List.assoc (bare m) sub).Ast.t with
| Ast.Tlen k -> Ast.Lint k
| Ast.Tname c -> Ast.Lname c
| _ -> fail loc "%s's $%s is a length" n (bare m)
in
Ast.Tarray (l, go e)
| Ast.Tarray (l, e) -> Ast.Tarray (l, go e)
| Ast.Tmap (k, v) -> Ast.Tmap (go k, go v)
| Ast.Tapp (h, a) -> Ast.Tapp (h, List.map go a)
| Ast.Tfn (b, ps, r) -> Ast.Tfn (b, List.map go ps, go r)
in
{ t with Ast.t = k }
in
Hashtbl.replace env.structs key
(List.map (fun (f : Ast.field) -> { f with Ast.fty = go f.Ast.fty })
(Hashtbl.find env.structs n))
end;
key
let is_template env n = template_params env n <> []
(* [needed] collects the structs whose typedefs this signature pulls in, in the (* [needed] collects the structs whose typedefs this signature pulls in, in the
order they were first met. Order is the program's and never a hash fold's: order they were first met. Order is the program's and never a hash fold's:
the object cache keys on the generated text, so a reordering would be a the object cache keys on the generated text, so a reordering would be a
@ -184,6 +284,14 @@ let prim_cty = function
let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string = let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string =
let t = unalias env t in let t = unalias env t in
match t.Ast.t with match t.Ast.t with
| Ast.Tname n when Hashtbl.mem env.structs n && is_template env n ->
fail loc "%s is %s, a generic struct, which is a type only at its \
arguments — write them, as in (%s %s)" what n n
(String.concat " "
(List.map (fun (_, l) -> if l then "8" else "i32")
(template_params env n)))
| Ast.Tapp (n, args) when Hashtbl.mem env.structs n && is_template env n ->
cty env ~needed ~loc ~what { t with Ast.t = Ast.Tname (copy env ~loc n args) }
| Ast.Tname n -> | Ast.Tname n ->
(match prim_cty n with (match prim_cty n with
| Some c -> c | Some c -> c
@ -256,6 +364,7 @@ let rec cty env ~needed ~loc ~what (t : Ast.texpr) : string =
fail loc "%s is a function type, and a C callback is not implemented" what fail loc "%s is a function type, and a C callback is not implemented" what
| Ast.Tapp (n, _) -> | Ast.Tapp (n, _) ->
fail loc "%s is %s, which is not a type this shim generator knows" what n fail loc "%s is %s, which is not a type this shim generator knows" what n
| Ast.Tlen n -> fail loc "%s is %Ld, which is not a type" what n
(* ── What one parameter does at the boundary ────────────────────────── *) (* ── What one parameter does at the boundary ────────────────────────── *)
@ -268,6 +377,14 @@ let classify env ~needed ~loc ~what (t : Ast.texpr) =
let t' = unalias env t in let t' = unalias env t in
match t'.Ast.t with match t'.Ast.t with
| Ast.Tname "string" -> (Pstr, "const char *") | Ast.Tname "string" -> (Pstr, "const char *")
(* A copy crosses behind a pointer only: by value, the Flan half this
generator writes would have to spell the copy's type, and it builds its
wrapper from struct names. *)
| Ast.Tapp (n, _) when Hashtbl.mem env.structs n && is_template env n ->
fail loc
"%s is %s, a generic struct's copy, which crosses to C behind a pointer \
only — declare (Ptr %s) and let the C side read it"
what (source t') (source t')
| Ast.Tname n when Hashtbl.mem env.structs n -> | Ast.Tname n when Hashtbl.mem env.structs n ->
ignore (cty env ~needed ~loc ~what t'); ignore (cty env ~needed ~loc ~what t');
(Pstruct n, ctype_name n) (Pstruct n, ctype_name n)
@ -545,6 +662,8 @@ let typedefs env needed =
(fun (f : Ast.field) -> (fun (f : Ast.field) ->
match (unalias env f.Ast.fty).Ast.t with match (unalias env f.Ast.fty).Ast.t with
| Ast.Tname m when Hashtbl.mem env.structs m -> define m | Ast.Tname m when Hashtbl.mem env.structs m -> define m
| Ast.Tapp (m, args) when Hashtbl.mem env.structs m && is_template env m ->
define (copy env ~loc:f.Ast.floc m args)
| _ -> ()) | _ -> ())
fs; fs;
Printf.bprintf b "struct %s_s { /* %s */\n" (ctype_name n) n; Printf.bprintf b "struct %s_s { /* %s */\n" (ctype_name n) n;

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 =

37
lib/types.ml
View File

@ -106,6 +106,15 @@ type t =
| Fn of t list * t (* (Fn [T ...] R) *) | Fn of t list * t (* (Fn [T ...] R) *)
| CFn of t list * t (* (CFn [T ...] R) *) | CFn of t list * t (* (CFn [T ...] R) *)
| Var of string (* a type variable — milestone 5 *) | Var of string (* a type variable — milestone 5 *)
(* The two halves of a length parameter, and neither is the type of a value.
[Len] is a length standing where a generic struct's argument goes — the 8
in (Small 8 i32) — and what a length variable is bound to. [LArray] is a
fixed array whose length is a variable, [[$n $t]], and exists only in a
generic signature, as the pattern a call site binds [n] from. A generic
body is checked with its lengths at [Check.abstract_len], so neither ever
reaches a backend. *)
| Len of int64
| LArray of string * t
(* [dyn]: one machine word whose contents the runtime knows and this module (* [dyn]: one machine word whose contents the runtime knows and this module
does not. It is a written type — [(defonce x dyn 5)] boxes the 5 — and it does not. It is a written type — [(defonce x dyn 5)] boxes the 5 — and it
is also what an unannotated [defn] parameter means, which is why it is a is also what an unannotated [defn] parameter means, which is why it is a
@ -206,8 +215,29 @@ let rec equal a b =
&& List.for_all2 equal ps ps' && List.for_all2 equal ps ps'
&& equal r r' && equal r r'
| Var x, Var y -> String.equal x y | Var x, Var y -> String.equal x y
| Len x, Len y -> Int64.equal x y
| LArray (n, x), LArray (m, y) -> String.equal n m && equal x y
| _ -> false | _ -> false
(* How a generic struct's copy is spelled to a reader. The copy is an
ordinary struct under a symbol-safe key — [Small-8-i32] — and this is the
key's written form, [(Small 8 i32)], filled in as each copy is made. Global
rather than on a checker's env because every message that prints a type
comes through here with no env in hand. The key determines the spelling,
so an entry left from an earlier program in the same process is wrong only
for a struct that program's successor declares under a copy's key by hand,
and then only in how a message spells it. *)
let display : (string, string) Hashtbl.t = Hashtbl.create 16
(* A struct's name as a printed value's head: its own name, or for a generic
struct's copy the template and its arguments, [Pair i32] — so a value
prints as [(Pair i32 {.a 1 .b 2})], the way its type is written. *)
let struct_head n =
match Hashtbl.find_opt display n with
| Some d when String.length d >= 2 && d.[0] = '(' ->
String.sub d 1 (String.length d - 2)
| _ -> n
let rec to_string = function let rec to_string = function
| Int k -> ikind_name k | Int k -> ikind_name k
| Float k -> fkind_name k | Float k -> fkind_name k
@ -215,7 +245,8 @@ let rec to_string = function
| String -> "string" | String -> "string"
| Unit -> "()" | Unit -> "()"
| Never -> "Never" | Never -> "Never"
| Named n | Enum n -> n | Named n -> (match Hashtbl.find_opt display n with Some d -> d | None -> n)
| Enum n -> n
| Slice (Mut, t) -> "[" ^ to_string t ^ "]" | Slice (Mut, t) -> "[" ^ to_string t ^ "]"
| Slice (Const, t) -> "[const " ^ to_string t ^ "]" | Slice (Const, t) -> "[const " ^ to_string t ^ "]"
| Array (n, t) -> Printf.sprintf "[%Ld %s]" n (to_string t) | Array (n, t) -> Printf.sprintf "[%Ld %s]" n (to_string t)
@ -231,7 +262,9 @@ let rec to_string = function
| CFn (ps, r) -> | CFn (ps, r) ->
Printf.sprintf "(CFn [%s] %s)" Printf.sprintf "(CFn [%s] %s)"
(String.concat " " (List.map to_string ps)) (to_string r) (String.concat " " (List.map to_string ps)) (to_string r)
| Var n -> n | Var n -> "$" ^ n
| Len n -> Int64.to_string n
| LArray (n, t) -> Printf.sprintf "[$%s %s]" n (to_string t)
| Dyn -> "dyn" | Dyn -> "dyn"
let is_numeric = function Int _ | Float _ -> true | _ -> false let is_numeric = function Int _ | Float _ -> true | _ -> false

1
lib/x86.ml
View File

@ -533,6 +533,7 @@ let is_agg (t : Types.t) =
the arithmetic. *) the arithmetic. *)
| Types.Dyn -> false | Types.Dyn -> false
| Types.Var v -> unsupported "type variable %s" v | Types.Var v -> unsupported "type variable %s" v
| Types.Len _ | Types.LArray _ -> unsupported "length variable"
let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false let is_void (t : Types.t) = match t with Types.Unit | Types.Never -> true | _ -> false
let is_float (t : Types.t) = match t with Types.Float _ -> true | _ -> false let is_float (t : Types.t) = match t with Types.Float _ -> true | _ -> false

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.

109
test/programs/generic-struct.flan Normal file
View File

@ -0,0 +1,109 @@
;;;; Generic structs, end to end: type parameters and length parameters.
;;;;
;;;; A defstruct whose fields introduce $t is a template, and each set of
;;;; arguments it is given is a copy — an ordinary struct. A parameter is a
;;;; length when it stands in an array's length slot, and a type anywhere else;
;;;; the arguments are written in the order the fields first introduce them.
;;;;
;;;; Small is Odin's Small_Array: a fixed-capacity array with a count, and no
;;;; allocation anywhere.
(defstruct Small [items [$n $t] count i32])
;; A generic function over a generic struct binds both of its parameters from
;; the argument, and reads the length back as a value.
(defn append! [s (Ptr (Small $n $t)) x $t] bool
(if (< (.count s) n)
(do (set (at (.items s) (.count s)) x)
(set (.count s) (+ (.count s) 1))
true)
false))
;; One generic over the struct calling another at its own variables.
(defn append-all! [s (Ptr (Small $n $t)) xs [$t]] ()
(dotimes [i (length xs)]
(append! s (at xs i))))
(defn pop! [s (Ptr (Small $n $t))] (Option $t)
(if (= (.count s) 0)
None
(do (set (.count s) (- (.count s) 1))
(Some (at (.items s) (.count s))))))
(defn capacity [s (Ptr (Small $n $t))] i32 n)
(defn total [s (Ptr (Small $n $t))] $t {:where (numeric? $t)}
(let [acc (the $t 0)]
(dotimes [i (.count s)]
(set acc (+ acc (at (.items s) i))))
acc))
;; A type parameter alone, built positionally with the type read off the
;; fields, and returned under a variable.
(defstruct Pair [a $t b $t])
(defn swapped [p (Pair $t)] (Pair $t) (Pair (.b p) (.a p)))
;; A copy that names itself through a pointer, and a literal field that
;; takes its width from the one beside it.
(defstruct Node [v $t next (Option (Ptr (Node $t)))])
(defn sum-list [n (Ptr (Node i64))] i64
(loop [at n acc (the i64 0)]
(let [acc (+ acc (.v at))]
(match (.next at)
(Some p) (recur p acc)
None acc))))
;; A template naming another at its own parameters.
(defstruct Twice [x (Small $m $u) y (Small $m $u)])
;; A copy as a map key, and a named function over one handed where a
;; function value is wanted.
(defn pair-sum [p (Pair i32)] i32 (+ (.a p) (.b p)))
(defn apply-to [f (Fn [(Pair i32)] i32) p (Pair i32)] i32 (f p))
;; A length variable straight on an array parameter.
(defn len-of [a [$k $e]] i32 k)
(defconst cap 3)
(defn main [] i32
(let [s (the (Small 4 i32) (zeroed))
f (the (Small cap f64) (zeroed))]
(append! (addr s) 10)
(append! (addr s) 20)
(append! (addr s) 30)
(println (total (addr s)) (.count s) (capacity (addr s)))
(append! (addr f) 1.5)
(append! (addr f) 2.5)
(append! (addr f) 3.5)
(println (append! (addr f) 4.5) (total (addr f)) (capacity (addr f)))
(println (pop! (addr f)) (pop! (addr f)) (.count f))
(let [p (Pair 1 2)
q (swapped p)
r (swapped (Pair {.a 1.5 .b 2.5}))]
(println (.a q) (.b q) (.a r) (.b r))
(println q (Pair 1 2.5)))
(let [c (the (Node i64) {.v 3})
b (Node 2 (Some (addr c)))
a (Node 1 (Some (addr b)))]
(println (sum-list (addr a))))
(let [w (the (Twice 2 u8) (zeroed))]
(append! (addr (.y w)) 7)
(println (.count (.x w)) (.count (.y w)) (capacity (addr (.x w)))))
(println (len-of [1 2 3]) (len-of [1.5 2.5]))
(let [v (vec-new (Pair i32))]
(push v (Pair 5 6))
(println (.b (at v 0)))
(free v))
(let [t (the (Small 5 i64) (zeroed))
xs (the [3 i64] [1 2 3])]
(append-all! (addr t) (slice xs))
(println (total (addr t)) (.count t)))
(let [m (map-new (Pair i32) i32)]
(put m (Pair 1 2) 12)
(put m (Pair 3 4) 34)
(println (get m (Pair 3 4)) (get m (Pair 2 1)) (apply-to pair-sum (Pair 7 8)))
(free m))
0))

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)

62
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
@ -3531,6 +3544,19 @@ let () =
outputs "generics" "programs/generics.flan" generics_out; outputs "generics" "programs/generics.flan" generics_out;
outputs ~opt:"-O0" "generics, -O0" "programs/generics.flan" generics_out; outputs ~opt:"-O0" "generics, -O0" "programs/generics.flan" generics_out;
(* Generic structs — see the program's header. The third line is two pops
printed in one call, which is also the pin for a printed call being
evaluated once: the walk reads an option's tag and then its payload,
and each read used to make the call again. *)
let generic_struct_out =
"60 3 4\nfalse 7.5 3\n(some 3.5) (some 2.5) 1\n2 1 2.5 1.5\n\
(Pair i32 {.a 2 .b 1}) (Pair f64 {.a 1 .b 2.5})\n6\n\
0 1 2\n3 2\n6\n6 3\n(some 34) none 15\n"
in
outputs "generic structs" "programs/generic-struct.flan" generic_struct_out;
outputs ~x86:true "generic structs, --x86" "programs/generic-struct.flan"
generic_struct_out;
(* integer?, end to end — see the program's own header. The first eight (* integer?, end to end — see the program's own header. The first eight
lines are the collapsed abs at six widths and both signed minimums lines are the collapsed abs at six widths and both signed minimums
(which answer themselves; the negation wraps). The [0 0] after them is (which answer themselves; the negation wraps). The [0 0] after them is
@ -3673,7 +3699,7 @@ let () =
chain of instantiations and not a depth it gave up at. *) chain of instantiations and not a depth it gave up at. *)
refuses "an unconstrained operator in a generic body" refuses "an unconstrained operator in a generic body"
"programs/generic-reject.flan" "programs/generic-reject.flan"
"nothing declares t numeric?"; "nothing declares $t numeric?";
refuses "an unconstrained operator names the way out" refuses "an unconstrained operator names the way out"
"programs/generic-reject.flan" "{:where (numeric? $t)}"; "programs/generic-reject.flan" "{:where (numeric? $t)}";
refuses "a runaway instantiation" "programs/generic-runaway.flan" refuses "a runaway instantiation" "programs/generic-runaway.flan"
@ -4287,6 +4313,36 @@ level "1"
end end
in in
let v2 = "(defstruct Vector2 [x f32 y f32])\n" in let v2 = "(defstruct Vector2 [x f32 y f32])\n" in
(* A generic struct's copy crosses behind a pointer, as a typedef of its
own with the arguments written in, and one held by value inside a
struct is defined before that struct. clang reads the text, so the
typedef is C and not only a spelling. *)
let gsrc =
"(defstruct G [x $t count i32])\n\
(defstruct O [v i32 inner (G u8)])\n\
(declare-c c-g [s (Ptr (G u8))] i32 \"c_g\")\n\
(declare-c c-o [o (Ptr O)] i32 \"c_o\")\n"
in
shim_case "declare-c: a generic struct's copy crosses behind a pointer" gsrc
[ "/* (G u8) */\n uint8_t x;\n int32_t count;\n"; "inner;\n" ];
(match shim_of gsrc with
| c ->
let file = Filename.temp_file "flan-shim-generic" ".c" in
let oc = open_out file in
output_string oc c;
close_out oc;
if Sys.command (Printf.sprintf "clang -fsyntax-only %s" (Filename.quote file)) <> 0
then begin
incr failures;
print_endline "FAIL declare-c: a generic struct's copy is C clang accepts"
end;
Sys.remove file
| exception Loc.Error _ -> ());
shim_refuses "declare-c: a generic struct's copy by value"
"(defstruct G [x $t])\n(declare-c c-v [s (G u8)] i32 \"c_v\")"
"crosses to C behind a pointer only";
let img = let img =
"(defstruct Image [data (Ptr u8) width i32 height i32])\n" "(defstruct Image [data (Ptr u8) width i32 height i32])\n"
in in
@ -4793,10 +4849,10 @@ level "1"
the easier of the two to leave open. *) the easier of the two to leave open. *)
refuses "a nested function type does not widen" refuses "a nested function type does not widen"
"programs/fn-generic-nested.flan" "programs/fn-generic-nested.flan"
"hof expects (Fn [(Fn [t] t)] i32) here"; "hof expects (Fn [(Fn [$t] $t)] i32) here";
refuses "and neither does one in return position" refuses "and neither does one in return position"
"programs/fn-generic-nested-return.flan" "programs/fn-generic-nested-return.flan"
"call-twice expects (Fn [] (Fn [] t)) here"; "call-twice expects (Fn [] (Fn [] $t)) here";
outputs ~dev:true "an fn capturing by value, dev" "programs/fn-capture.flan" outputs ~dev:true "an fn capturing by value, dev" "programs/fn-capture.flan"
fn_capture_out; fn_capture_out;

22
test/test_dev.ml
View File

@ -802,6 +802,28 @@ let () =
| Some { Form.v = Form.Sym "t"; _ } -> () | Some { Form.v = Form.Sym "t"; _ } -> ()
| _ -> fail "an expression against the park reported the program live"); | _ -> fail "an expression against the park reported the program live");
(* A generic struct's copy prints the way its type is written, with the
arguments after the template's name, and [layout] answers to that
spelling. *)
let r =
request c
"(:op \"eval\" :code \"(defstruct GPair [a $t b $t])\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then
fail "a generic struct at the daemon: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
let r =
request c
"(:op \"eval-expr\" :code \"(GPair 1 2)\" :file \"/tmp/buf.flan\")"
in
if Wire.string_field r "value" <> Some "(GPair i32 {.a 1 .b 2})" then
fail "a generic struct's copy printed as %s"
(Option.value ~default:(status r) (Wire.string_field r "value"));
let r = request c "(:op \"layout\" :type \"GPair i32\")" in
if Wire.string_field r "type" <> Some "(GPair i32)" then
fail "layout of a copy by its printed head: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
(* And the half that needs the process rather than only the compiler. (* And the half that needs the process rather than only the compiler.
[extra] is a global this session introduced and the first run left at [extra] is a global this session introduced and the first run left at
105 — the third reload's [step] does not touch it — so this is the 105 — the third reload's [step] does not touch it — so this is the

318
test/test_flan.ml
View File

@ -1417,7 +1417,7 @@ let () =
accepts "all-distinct over a type variable" accepts "all-distinct over a type variable"
"(defn three [a $t b $t c $t] bool {:where (equal? $t)} (!= a b c))"; "(defn three [a $t b $t c $t] bool {:where (equal? $t)} (!= a b c))";
rejects_check "a chain still wants the right predicate" rejects_check "a chain still wants the right predicate"
~needle:"nothing declares t ordered?" ~needle:"nothing declares $t ordered?"
"(defn between [a $t b $t c $t] bool {:where (equal? $t)} (< a b c))"; "(defn between [a $t b $t c $t] bool {:where (equal? $t)} (< a b c))";
(* One operand and none. Both would have to be [true] whatever they were (* One operand and none. Both would have to be [true] whatever they were
handed, which is a typo carrying a value. *) handed, which is a typo carrying a value. *)
@ -1470,10 +1470,10 @@ let () =
can actually be written there; the parameter-vector suggestion survives can actually be written there; the parameter-vector suggestion survives
where it works, which the return-type pin further down exercises. *) where it works, which the return-type pin further down exercises. *)
rejects_check "a real type variable at a field" "(defstruct Holder [x elem])" rejects_check "a real type variable at a field" "(defstruct Holder [x elem])"
~needle:"a field is built at one type for every value"; ~needle:"in a defstruct's fields that makes the struct generic over it";
rejects_check "and the field message offers what a field can hold" rejects_check "and the field message offers what a field can hold"
"(defstruct Holder [x elem])" "(defstruct Holder [x elem])"
~needle:"Write a concrete type here, or dyn to hold any value"; ~needle:"Write $elem, a concrete type, or dyn to hold any value";
rejects_check "an unknown concrete type" "(defn f [x Widget] ())" rejects_check "an unknown concrete type" "(defn f [x Widget] ())"
~needle:"unknown type Widget"; ~needle:"unknown type Widget";
@ -2693,7 +2693,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"
@ -2876,13 +2876,11 @@ let () =
(* [(Pair i32)] in a defonce falls down the value fork now that the third (* [(Pair i32)] in a defonce falls down the value fork now that the third
element takes either reading, and the generics answer the type fork gave element takes either reading, and the generics answer the type fork gave
it has to be reachable from here too. *) it has to be reachable from here too. *)
(* A capitalised head with arguments is a *type* given type arguments, and (* A capitalised head with arguments is a *type* given type arguments; with
that is the half of generics that is not built — Types.Named is a bare no such struct declared, the sentence says how one is. *)
string with no room for parameters. The sentence says which half, since
generic functions are here and pointing at them is the useful part. *)
rejects_check "a capitalised call with arguments is a generic type" rejects_check "a capitalised call with arguments is a generic type"
"(defonce x (Pair i32)) (defn f [] i32 0)" "(defonce x (Pair i32)) (defn f [] i32 0)"
~needle:"is a generic type, which is not there yet"; ~needle:"no struct or generic struct Pair is declared";
accepts "and the generic function it points at is" accepts "and the generic function it points at is"
"(defn pair-fst [a $t b $u] $t (do b a))\n\ "(defn pair-fst [a $t b $u] $t (do b a))\n\
(defn main [] () (println (pair-fst 1 true)))"; (defn main [] () (println (pair-fst 1 true)))";
@ -4662,8 +4660,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"
@ -6265,6 +6340,110 @@ let () =
check "and they are in source order" check "and they are in source order"
(List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds = [ 1; 2; 3 ])); (List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds = [ 1; 2; 3 ]));
(* A generic whose abstract pass was refused is not checked again at each
copy: the refusal is one error, however many types call it, and the
caller's own later refusal is still found. *)
(match
Check.program_all
(Parse.program_all
(read "(defn g [x $t] u64 (nosuch x))\n\
(defn main [] i32 (g 3) (g true) nope 0)\n"))
with
| _ -> check "a refused generic body is refused" false
| exception Loc.Errors ds ->
check "a refused generic body is one error, and its caller's is another"
(List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds = [ 1; 2 ]));
(* A refusal inside a copy names the call that asked for it, and each copy
between: the chain walks back to the line the programmer wrote. *)
(match
checked
"(defn show [v $t] () (println v)) \
(defn outer [v $t] () (show v)) \
(defn main [] i32 (outer main) 0)"
with
| _ -> check "a copy with no printer is refused" false
| exception Loc.Error d ->
let notes = List.map (fun (n : Loc.note) -> n.Loc.nmsg) d.Loc.notes in
check "a refusal in a copy names both instantiations"
(contains d.Loc.dmsg "no printer for"
&& notes
= [ "show is instantiated at $t = (CFn [] i32) here";
"outer is instantiated at $t = (CFn [] i32) here" ]));
(* A refusal made while collecting declarations — a generic struct that
holds itself, one that grows without end, a where clause over a length —
is one error among the rest of the file's, not the end of the check. *)
let all_lines src =
match Check.program_all (Parse.program_all (read src)) with
| _ -> []
| exception Loc.Errors ds ->
List.map (fun (d : Loc.diag) -> d.Loc.dloc.Loc.line) ds
in
check "a self-containing generic struct is one error of several"
(all_lines
"(defstruct Loop [next (Loop $t)])\n\
(defn g [] i32 (let [p (the (Loop i32) (zeroed))] nope1))\n\
(defn h [] i32 nope2)\n"
= [ 1; 2; 3 ]);
check "a generic struct that grows without end is one error of several"
(all_lines
"(defstruct Grow [next (Ptr (Grow [$t]))])\n\
(defn g [] i32 (let [p (the (Grow i32) (zeroed))] nope1))\n\
(defn h [] i32 nope2)\n"
= [ 1; 2; 3 ]);
check "a where clause over a length is one error of several"
(all_lines
"(defn f [a [$n i32]] i32 {:where (numeric? $n)} nope1)\n\
(defn h [] i32 nope2)\n"
= [ 1; 1; 2 ]);
(* A literal that does not fit what a typed field decided names that field. *)
(match
checked
"(defstruct Pair [a $t b $t]) \
(defn main [] i32 (let [p (Pair (the i32 1) 2.5)] 0))"
with
| _ -> check "a float literal where a typed field decided i32" false
| exception Loc.Error d ->
check "the refusal names the field that decided the variable"
(contains d.Loc.dmsg "Pair's .b is $t, which is i32 here"
&& List.exists
(fun (n : Loc.note) ->
contains n.Loc.nmsg ".a is i32 here, which decides $t")
d.Loc.notes));
(* A copy that cannot be built at a closure's type: the zeroed value in the
body is refused there, and the call that asked is named. *)
(match
checked
"(defn blank [x $t] $t (let [z (the $t (zeroed))] z)) \
(defn use-it [f (Fn [i32] i32)] i32 (blank f) 0)"
with
| _ -> check "a zeroed closure in a copy is refused" false
| exception Loc.Error d ->
check "a copy at a closure type names the call that asked"
(List.exists
(fun (n : Loc.note) ->
contains n.Loc.nmsg "blank is instantiated at $t = (Fn [i32] i32) here")
d.Loc.notes));
(* A prelude generic's body is nobody's source at the call: the refusal is
at the call, and the prelude's line is a note. *)
(match
checked
"(defn keep [g (Vec u8)] bool true) \
(defn use-it [xs [(Vec u8)]] i32 (length (filter xs keep)))"
with
| _ -> check "a prelude copy that cannot be built is refused" false
| exception Loc.Error d ->
check "a prelude copy's refusal is at the user's call"
(d.Loc.dloc.Loc.file <> Prelude.file
&& contains d.Loc.dmsg "filter cannot be made at $t = (Vec u8)"
&& not (contains d.Loc.dmsg "clone")
&& List.exists
(fun (n : Loc.note) -> n.Loc.nloc.Loc.file = Prelude.file)
d.Loc.notes));
(* The parser resynchronises on a top-level form, so two bad declarations are (* The parser resynchronises on a top-level form, so two bad declarations are
two errors rather than one. *) two errors rather than one. *)
(match Parse.program_all (read "(defn a)\n(defn b)\n") with (match Parse.program_all (read "(defn a)\n(defn b)\n") with
@ -6323,7 +6502,7 @@ let () =
accepts "numeric? admits +" accepts "numeric? admits +"
"(defn add [a $t b $t] $t {:where (numeric? $t)} (+ a b))"; "(defn add [a $t b $t] $t {:where (numeric? $t)} (+ a b))";
rejects_check "equal? does not admit <" rejects_check "equal? does not admit <"
~needle:"nothing declares t ordered?" ~needle:"nothing declares $t ordered?"
"(defn less [a $t b $t] bool {:where (equal? $t)} (< a b))"; "(defn less [a $t b $t] bool {:where (equal? $t)} (< a b))";
(* The entailments, which are the reason a signature is one predicate long (* The entailments, which are the reason a signature is one predicate long
rather than two. Every type the language orders is a number or an enum, rather than two. Every type the language orders is a number or an enum,
@ -6351,10 +6530,10 @@ let () =
accepts "integer? admits the shifts" accepts "integer? admits the shifts"
"(defn dbl [x $t] $t {:where (integer? $t)} (<< x 1))"; "(defn dbl [x $t] $t {:where (integer? $t)} (<< x 1))";
rejects_check "numeric? does not admit bit-and" rejects_check "numeric? does not admit bit-and"
~needle:"nothing declares t integer?" ~needle:"nothing declares $t integer?"
"(defn low? [x $t] bool {:where (numeric? $t)} (= (bit-and x 1) 1))"; "(defn low? [x $t] bool {:where (numeric? $t)} (= (bit-and x 1) 1))";
rejects_check "nor the shifts" rejects_check "nor the shifts"
~needle:"nothing declares t integer?" ~needle:"nothing declares $t integer?"
"(defn dbl [x $t] $t {:where (numeric? $t)} (<< x 1))"; "(defn dbl [x $t] $t {:where (numeric? $t)} (<< x 1))";
(* An integer?-bounded caller satisfies a numeric?-bounded callee: the (* An integer?-bounded caller satisfies a numeric?-bounded callee: the
entailment carries across generic calls exactly as ordered?-over-equal? entailment carries across generic calls exactly as ordered?-over-equal?
@ -6957,19 +7136,118 @@ let () =
bound, because inside a signature that introduces one the mistake is bound, because inside a signature that introduces one the mistake is
nearly always the second spelling of the first. *) nearly always the second spelling of the first. *)
rejects_check "vec-new over a sigil that names no variable in scope" rejects_check "vec-new over a sigil that names no variable in scope"
~needle:"this signature introduces t, so write t here" ~needle:"this signature introduces $t, so write $t here"
"(defn f [x $t] i32 (do x (let [v (vec-new $u)] (free v) 0)))"; "(defn f [x $t] i32 (do x (let [v (vec-new $u)] (free v) 0)))";
rejects_check "and a cast over one tells the same story" rejects_check "and a cast over one tells the same story"
~needle:"this signature introduces t, so write t here" ~needle:"this signature introduces $t, so write $t here"
"(defn f [x i32 d $t] $t {:where (numeric? $t)} (do d ($u x)))"; "(defn f [x i32 d $t] $t {:where (numeric? $t)} (do d ($u x)))";
rejects_check "two variables in scope are both named" rejects_check "two variables in scope are both named"
~needle:"introduces t and u, so write one of those" ~needle:"introduces $t and $u, so write one of those"
"(defn f [a $t b $u] i32 (do a b (let [v (vec-new $w)] (free v) 0)))"; "(defn f [a $t b $u] i32 (do a b (let [v (vec-new $w)] (free v) 0)))";
(* Where no variable is in scope there is none to name, and the answer is (* Where no variable is in scope there is none to name, and the answer is
the rule: a sigil binds, and only a defn signature is a binding site. *) the rule: a sigil binds, and only a defn signature is a binding site. *)
rejects_check "a sigil in a struct field, where nothing can bind one" rejects_check "a sigil in a data case's field, where nothing can bind one"
~needle:"only a defn signature can" ~needle:"only a defn signature or a defstruct's fields can"
"(defstruct S [v $t])"; "(defdata D [(C [v $t])])";
(* ── Generic structs: what is refused, and where ─────────────────── *)
rejects_check "a generic struct given the wrong number of arguments"
~needle:"Pair takes 1 argument, (Pair $t), and this gives 2"
"(defstruct Pair [a $t b $t]) (defn f [p (Pair i32 i64)] i32 0)";
rejects_check "a generic struct named with no arguments"
~needle:"Pair is generic, and a type only once it is given its arguments"
"(defstruct Pair [a $t b $t]) (defn f [p Pair] i32 0)";
rejects_check "a type where a length argument goes"
~needle:"Small's $n is a length"
"(defstruct Small [items [$n $t] count i32]) \
(defn f [p (Small i32 4)] i32 0)";
rejects_check "a length where a type argument goes"
~needle:"Small's $t is a type, and 4 is a length"
"(defstruct Small [items [$n $t] count i32]) \
(defn f [p (Small 4 4)] i32 0)";
rejects_check "a negative length argument"
~needle:"-1 is negative"
"(defstruct Small [items [$n $t] count i32]) \
(defn f [p (Small -1 i32)] i32 0)";
rejects_check "one variable as both a length and a type"
~needle:"$t stands for a length in one place here and a type in another"
"(defstruct Bad [x $t y [$t i32]])";
rejects_check "a length variable where a type goes"
~needle:"n is a length, not a type"
"(defn f [a [$n i32]] i32 (let [x (the n 0)] 0))";
rejects_check "a where clause over a length variable"
~needle:"$n is a length, and a where clause takes type predicates only"
"(defn f [a [$n i32]] i32 {:where (numeric? $n)} 0)";
rejects_check "a generic struct that contains itself by value"
~needle:"(Loop $t) contains itself by value"
"(defstruct Loop [next (Loop $t)])";
rejects_check "a generic struct that asks for bigger copies of itself"
~needle:"Grow names a copy of itself at a type built around its own"
"(defstruct Grow [next (Ptr (Grow [$t]))]) (defn f [p (Grow i32)] i32 0)";
rejects_check "a copy whose key is already a struct's name"
~needle:"Pair at these arguments is called Pair-i32, and Pair-i32 is \
already defined"
"(defstruct Pair [a $t b $t]) (defstruct Pair-i32 [x i32]) \
(defn f [p (Pair i32)] i32 0)";
rejects_check "a generic struct literal whose fields decide nothing"
~needle:"Pair's $t is not decided by the fields given here"
"(defstruct Pair [a $t b $t]) (defn f [] i32 (let [p (Pair {})] 0))";
rejects_check "two fields that disagree about the variable"
~needle:"(Pair $t)'s .b is i32 here, and this is f64"
"(defstruct Pair [a $t b $t]) \
(defn f [] i32 (let [p (Pair (the i32 1) (the f64 2.5))] 0))";
accepts "a literal field takes its width from a typed one beside it"
"(defstruct Pair [a $t b $t]) \
(defn f [] f64 (let [p (Pair 1 (the f64 2.5))] (.a p)))";
rejects_check "a generic struct as a condition"
~needle:"Pair is generic, and a condition struct is not"
"(defstruct Pair :parent Error [a $t])";
rejects_check "an operator a generic body's struct field does not support"
~needle:"+ over the type variable $t"
"(defstruct Pair [a $t b $t]) (defn f [p (Pair $t)] $t (+ (.a p) (.b p)))";
accepts "the same body with the predicate declared"
"(defstruct Pair [a $t b $t]) \
(defn f [p (Pair $t)] $t {:where (numeric? $t)} (+ (.a p) (.b p))) \
(defn main [] i32 (f (Pair 1 2)))";
accepts "a copy wanted where it is built takes its type from there"
"(defstruct Pair [a $t b $t]) (defn f [] (Pair i64) (Pair 1 2))";
(* A copy whose field is refused names each use that asked for it. *)
(match
checked
"(defstruct Box [f $t]) (defstruct Outer [b (Box $w)]) \
(defn go [g (Fn [i32] i32)] i32 \
(.x (the (Outer (Fn [i32] i32)) (zeroed))) 0)"
with
| _ -> check "a copy with a zeroed function field is refused" false
| exception Loc.Error d ->
let notes = List.map (fun (n : Loc.note) -> n.Loc.nmsg) d.Loc.notes in
check "a refused copy names each use that made it"
(List.mem "(Box (Fn [i32] i32)) is made here" notes
&& List.mem "(Outer (Fn [i32] i32)) is made here" notes));
rejects_check "a bare generic struct in ordinary code suggests real arguments"
~needle:"write (Pair i32)"
"(defstruct Pair [a $t b $t]) (defn main [] i32 (let [p (the Pair (zeroed))] 0))";
rejects_check "a generic struct applied to nothing"
~needle:"Pair takes 1 argument, (Pair $t), and this gives 0"
"(defstruct Pair [a $t b $t]) \
(defn main [] i32 (let [p (the (Pair) (zeroed))] 0))";
rejects_check "a length argument that is not one"
~needle:"(+ n 1) is not a type or a length"
"(defstruct Small [items [$n $t] count i32]) \
(defn main [] i32 (let [n 3 p (the (Small (+ n 1) i32) (zeroed))] 0))";
accepts "a length argument of literal arithmetic is folded"
"(defstruct Small [items [$n $t] count i32]) \
(defn main [] i32 (let [p (the (Small (+ 1 2) i32) (zeroed))] \
(length (.items p))))";
accepts "two literal fields meet at the wider type"
"(defstruct Pair [a $t b $t]) \
(defn f [] f64 (let [p (Pair 1 2.5)] (+ (.a p) (.b p))))";
rejects_check "a callee's predicate names the caller's variable with its $"
~needle:"passes the type variable $t, which nothing here declares ordered?"
"(defn f [s [$t]] () (sort s))";
accepts "a defonce of a generic struct's copy"
"(defstruct Pair [a $t b $t]) (defonce g (Pair i32)) \
(defn main [] i32 (.a g))";
(* ── The builtin table against the arms it describes ────────────── (* ── The builtin table against the arms it describes ──────────────
[Check.builtins] is what the editor's C-c C-v and M-. read for a name no [Check.builtins] is what the editor's C-c C-v and M-. read for a name no

70
test/test_session.ml
View File

@ -367,6 +367,76 @@ let () =
| exception Loc.Error { Loc.dmsg = m; _ } -> | exception Loc.Error { Loc.dmsg = m; _ } ->
fail "the session was poisoned by a bad expression: %s" m); fail "the session was poisoned by a bad expression: %s" m);
(* A generic struct's copy first named by an expression typed at the
session: the module built for it has to lay the copy out, and the
session keeps it, as it keeps a generic function's copy. *)
(let gt, _ = Session.create ~file:"programs/reload.flan" () in
(match Session.eval gt "(defstruct Pair [a $t b $t])" with
| _ -> ()
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a generic struct was refused at the session: %s" m);
match Session.eval_expr gt "(println (.b (Pair 7 8)))" with
| e ->
if not (has e.Session.ir "%\"Pair-i32\" = type") then
fail "the expression's module did not carry the struct copy";
if not
(List.exists
(fun (s : Tast.structure) -> String.equal s.Tast.sname "Pair-i32")
gt.Session.program.Tast.structs)
then fail "the session did not keep the struct copy an expression made"
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "an expression building a generic struct was refused: %s" m);
(* And the same for the other two modules the break loop builds out of
typed-in values: a store into a frame slot, and a restart's arguments.
A copy first named in one of them is laid out there and kept. *)
(let keeps t what =
List.exists
(fun (s : Tast.structure) -> String.equal s.Tast.sname what)
t.Session.program.Tast.structs
in
let lays_out (c : Session.change) what =
has c.Session.ir ("%\"" ^ what ^ "\" = type")
in
let st, _ = Session.create ~file:"programs/reload.flan" () in
(match Session.eval st "(defstruct Pair [a $t b $t])" with
| _ -> ()
| exception Loc.Error { Loc.dmsg = m; _ } -> fail "Pair: %s" m);
(match Session.eval st "(defn holder [] i64 (let [x (the i64 0)] x))" with
| _ -> ()
| exception Loc.Error { Loc.dmsg = m; _ } -> fail "holder: %s" m);
let fn =
List.find (fun (f : Tast.fn) -> f.Tast.name = "holder")
st.Session.program.Tast.fns
in
let slot =
let r = ref (-1) in
Array.iteri (fun i n -> if n = Some "x" then r := i) fn.Tast.snames;
!r
in
(match
Session.write_slot st ~frame:0 ~fn ~slot ~path:[]
~edits:[ ([], "(.a (Pair (the i64 5) 6))") ]
with
| Ok (c, _, _) ->
if not (lays_out c "Pair-i64") then
fail "a store's module did not carry the struct copy its value made";
if not (keeps st "Pair-i64") then
fail "the session did not keep the struct copy a store made"
| Error why -> fail "a store building a generic struct was refused: %s" why
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a store building a generic struct was refused: %s" m);
match
Session.arm_restart st ~index:0 ~params:[ Types.Int Types.U16 ]
~codes:[ "(.b (Pair (the u16 5) 6))" ]
with
| Ok (c, _) ->
if not (lays_out c "Pair-u16") then
fail "a restart's module did not carry the struct copy its argument made"
| Error why -> fail "a restart building a generic struct was refused: %s" why
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a restart building a generic struct was refused: %s" m);
(* The other half of "a refusal costs nothing", and the half that used to be (* The other half of "a refusal costs nothing", and the half that used to be
missing: a form can check and *then* fail, in the build or at the agent, missing: a form can check and *then* fail, in the build or at the agent,
and the session that already accepted it has no way to hear about it and the session that already accepted it has no way to hear about it

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])