diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index be05ee23..a44a8dce 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -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-` / `M-` | same | move the statement past its neighbour | +| `M-` / `M-` | 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 | Key | Does | @@ -1267,6 +1315,7 @@ fix is to delete `-dev` from it. | File | What it is | |---|---| | `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-repl.el` | the `*flan-repl*` buffer | | `flan-watch.el` | watched values: the program pushes, this paints them in a buffer and inline | diff --git a/emacs/flan-dape.el b/emacs/flan-dape.el index 4ba767be..9f55a19a 100644 --- a/emacs/flan-dape.el +++ b/emacs/flan-dape.el @@ -89,14 +89,14 @@ does and does not buy." :type '(repeat string)) (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 from a *compilation* buffer or a dired still has an answer." (or (and buffer-file-name - (string-suffix-p ".flan" buffer-file-name) + (string-match-p "\\.fla?n\\'" buffer-file-name) buffer-file-name) - (car (directory-files default-directory t "\\.flan\\'")) - (user-error "No .flan file here to debug"))) + (car (directory-files default-directory t "\\.fla?n\\'")) + (user-error "No .flan or .fln file here to debug"))) (defun flan-dape--binary (source) "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 ;; evaluated config, so `flan-debug' below must not hand it the raw entry. (defconst flan-dape-config - '(modes (flan-mode) + '(modes (flan-base-mode) ensure dape-ensure-command command-cwd dape-command-cwd compile (flan-dape--compile-command (flan-dape--source)) @@ -178,7 +178,7 @@ common case is one command rather than a config prompt." ;; thing entirely. ;;;###autoload (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 ;; diff --git a/emacs/flan-fln-mode.el b/emacs/flan-fln-mode.el new file mode 100644 index 00000000..dfd90147 --- /dev/null +++ b/emacs/flan-fln-mode.el @@ -0,0 +1,1715 @@ +;;; flan-fln-mode.el --- Major mode for indented Flan (.fln) -*- lexical-binding: t; -*- + +;; Author: Joseph Ferano +;; Version: 0.1.0 +;; Package-Requires: ((emacs "29.1")) +;; Keywords: languages, tools + +;; The mode for the indented syntax (spec-syntax.md). It shares everything +;; that talks to the running program with `flan-mode' through their parent, +;; `flan-base-mode', and owns the one thing that differs: what a piece of the +;; text is. +;; +;; Nothing here parses Flan. Every object is found from lines, columns and +;; the syntax table: a statement is a line and the lines under it, a term is a +;; run with no space outside brackets. The reader decides what the text +;; means; this only decides which text to send, and sends it unchanged with +;; the line and column it starts at. +;; +;; The objects, smallest first: +;; +;; term a run with no space in it outside brackets: `x', `f(a, b)', +;; `grid[r, c]', `camera.target.x'. +;; group a bracket pair and what is inside it. +;; statement a line, the deeper lines under it, the lines inside brackets it +;; leaves open, the lines an operator continues, and the +;; `else'/`elif'/`on'/`restart' clauses at its own column. Blank +;; and comment lines inside never end it; trailing ones are not +;; part of it. +;; body a statement's own block: the deeper lines under its first line, +;; up to its first clause. +;; clause one `else'/`elif'/`on'/`restart' line and its block. +;; top-level a column-0 statement start and everything to the next one. + +;;; Code: + +(require 'flan-mode) +(require 'thingatpt) +(require 'seq) + +;; The client, which every command that sends code needs and which this file +;; must not load merely to edit one. +(declare-function flan--eval "flan" (code what &optional start end pause step)) +(declare-function flan--eval-expression "flan" (start end arg)) +(declare-function flan--text "flan" (start end)) +(declare-function flan--text-at "flan" (start end)) +(declare-function flan--report "flan" (reply what &optional at)) +(declare-function flan--request "flan" (form)) +(defvar flan--declaration-heads) +(defvar flan--defun-heads) +;; Set buffer-locally when the packages are there; declared so the setq-local +;; below does not make a stray global. +(defvar er/try-expand-list) +(defvar evil-shift-width) +(defvar evil-state) +(declare-function smartparens-mode "smartparens" (&optional arg)) +(declare-function sp-local-pair "smartparens" (modes open close &rest args)) +(declare-function evil-define-key* "evil-core" (state keymap key def &rest bindings)) +(declare-function evil-range "evil-common" (beg end &optional type &rest properties)) + +(defcustom flan-fln-indent-offset 2 + "Columns one block level adds in a .fln file." + :type 'integer + :group 'flan) + +(defcustom flan-fln-smartparens t + "Turn on plain `smartparens-mode' in .fln buffers, when it is installed. +Plain rather than strict: strict mode keeps s-expressions balanced, and a +.fln file's blocks are not s-expressions, so it would refuse edits that are +fine here. Brackets and strings are still paired." + :type 'boolean + :group 'flan) + +;;; Words + +;; The spaced binary operators of lib/indent_reader.ml (`binops'). A line +;; that starts with one, or follows a line that ends with one, continues the +;; line above. +(defconst flan-fln--binops + '("or" "and" "==" "!=" "<" "<=" ">" ">=" "<<" ">>" "+" "-" "*" "/" "%")) + +(defconst flan-fln--binop-re (regexp-opt flan-fln--binops)) + +(defconst flan-fln--clause-words '("else" "elif" "on" "restart") + "Words that start a clause of the statement above, at its column.") + +(defconst flan-fln--clause-re + "\\(else\\|elif\\|on\\|restart\\)\\(?:[ \t]\\|$\\)") + +(defconst flan-fln--clause-headers + '(("else" "if" "elif") ("elif" "if" "elif") + ("on" "handler-case" "handler-bind" "on") + ("restart" "restart-case" "restart")) + "For each clause word, the words of the lines it may sit under.") + +;; `header_follow' in lib/indent_reader.ml: the words a statement starts with. +(defconst flan-fln--header-words + '("fn" "fn-" "def" "once" "const" "struct" "union" "data" "enum" "import" + "if" "elif" "else" "while" "until" "for" "match" "let" "return" "break" + "continue" "defer" "handler-case" "handler-bind" "restart-case" "on" + "restart" "quote")) + +;; The headers whose block follows on the lines under them. `defer' and +;; `quote' open one only when nothing follows them on the line; `fn' does not +;; when it is the one-line `fn f(x) = e'; `if' does not when it is the one-line +;; `if c then a else b'. +(defconst flan-fln--opener-words + '("fn" "fn-" "struct" "union" "data" "enum" "if" "elif" "else" "while" + "until" "for" "match" "defer" "handler-case" "handler-bind" + "restart-case" "on" "restart" "quote")) + +(defconst flan-fln--declaration-words + '(("fn" . "defn") ("fn-" . "defn-") ("def" . "def") ("once" . "defonce") + ("const" . "defconst") ("struct" . "defstruct") ("data" . "defdata") + ("enum" . "defenum") ("union" . "defunion") ("import" . "import")) + "Each declaration header word, and the paren head it reads as.") + +;;; Syntax + +(defvar flan-fln-mode-syntax-table + (let ((table (make-syntax-table))) + ;; Name characters: a name is anything up to a delimiter (`is_delimiter' + ;; in lib/reader.ml), so `key-pressed?', `dyn->f64' and `rl/draw-fps' are + ;; one symbol each. + (dolist (c '(?- ?_ ?? ?! ?/ ?. ?$ ?& ?* ?+ ?< ?> ?= ?% ?@ ?# ?^ ?| ?~)) + (modify-syntax-entry c "_" table)) + ;; Not `:', which ends `x: T' and `comment:': a name glued to it would + ;; otherwise read as `x:', a name nothing defines. A `:key' keyword is + ;; drawn by its own font-lock rule instead. + (modify-syntax-entry ?: "." table) + (modify-syntax-entry ?\; "<" table) + (modify-syntax-entry ?\n ">" table) + (modify-syntax-entry ?\" "\"" table) + ;; `\c' is a character literal, `\(' included: escaping it keeps the + ;; paren out of the bracket count. + (modify-syntax-entry ?\\ "\\" table) + (modify-syntax-entry ?' "'" table) + ;; A comma separates, so it is not part of any term. + (modify-syntax-entry ?, "." table) + (modify-syntax-entry ?\( "()" table) + (modify-syntax-entry ?\) ")(" table) + (modify-syntax-entry ?\[ "(]" table) + (modify-syntax-entry ?\] ")[" table) + (modify-syntax-entry ?{ "(}" table) + (modify-syntax-entry ?} "){" table) + table) + "Syntax table for `flan-fln-mode'.") + +;;; Lines + +;; Every object is built from these. A position argument names the line it +;; is on; each answers for that line and leaves point alone. + +(defun flan-fln--bol (pos) + (save-excursion (goto-char pos) (line-beginning-position))) + +(defun flan-fln--indent-at (pos) + (save-excursion (goto-char pos) (current-indentation))) + +(defun flan-fln--first-char (pos) + "Where the text of POS's line starts." + (save-excursion (goto-char pos) (back-to-indentation) (point))) + +(defun flan-fln--in-open-p (pos) + "Non-nil if POS's line starts inside a bracket or a string." + (let ((s (save-excursion (syntax-ppss (flan-fln--bol pos))))) + (or (> (car s) 0) (nth 3 s)))) + +(defun flan-fln--blank-p (pos) + "Non-nil if POS's line holds no code: it is blank, or only a comment." + (save-excursion + (goto-char (flan-fln--bol pos)) + (and (not (nth 3 (syntax-ppss (point)))) + (progn (skip-chars-forward " \t") + (or (eolp) (eq (char-after) ?\;)))))) + +(defun flan-fln--code-end (pos) + "Where the code on POS's line ends: before a trailing comment and spaces." + (save-excursion + (goto-char pos) + (let* ((bol (line-beginning-position)) + (eol (line-end-position)) + (s (syntax-ppss eol))) + (goto-char (if (and (nth 4 s) (>= (nth 8 s) bol)) (nth 8 s) eol)) + (skip-chars-backward " \t" bol) + (point)))) + +(defun flan-fln--ends-in-op-p (pos) + "Non-nil if POS's line ends in a spaced binary operator." + (save-excursion + (let ((end (flan-fln--code-end pos))) + (goto-char end) + (and (not (nth 3 (syntax-ppss end))) + (looking-back (concat "\\(?:^\\|[ \t]\\)" flan-fln--binop-re) + (line-beginning-position)))))) + +(defun flan-fln--starts-with-op-p (pos) + "Non-nil if POS's line starts with a spaced binary operator." + (save-excursion + (goto-char pos) + (back-to-indentation) + (looking-at (concat flan-fln--binop-re "\\(?:[ \t]\\|$\\)")))) + +(defun flan-fln--prev-code (pos) + "The start of the nearest code line above POS's line, or nil." + (save-excursion + (goto-char pos) + (let (hit) + (while (and (not hit) (zerop (forward-line -1))) + (unless (flan-fln--blank-p (point)) (setq hit (point)))) + hit))) + +(defun flan-fln--next-code (pos) + "The start of the nearest code line below POS's line, or nil." + (save-excursion + (goto-char pos) + (let (hit) + (while (and (not hit) (zerop (forward-line 1)) (not (eobp))) + (unless (flan-fln--blank-p (point)) (setq hit (point)))) + ;; The last line of a buffer with no final newline: `forward-line' + ;; reports it could not move a whole line, but it did reach it. + (when (and (not hit) (eobp) (not (bolp)) + (> (line-beginning-position) (flan-fln--bol pos)) + (not (flan-fln--blank-p (point)))) + (setq hit (line-beginning-position))) + hit))) + +(defun flan-fln--continuation-p (pos) + "Non-nil if POS's line continues the line above it. +Inside a bracket or a string, after a line that ends in a spaced operator, or +starting with one: the reader's three ways a line break is not a new line." + (or (flan-fln--in-open-p pos) + (flan-fln--starts-with-op-p pos) + (let ((p (flan-fln--prev-code pos))) + (and p (flan-fln--ends-in-op-p p))))) + +(defun flan-fln--clause-line-p (pos) + "Non-nil if POS's line starts a clause: else, elif, on or restart. +A word, and only when a space or the end of the line follows it." + (and (not (flan-fln--continuation-p pos)) + (save-excursion + (goto-char pos) + (back-to-indentation) + (looking-at flan-fln--clause-re)))) + +(defun flan-fln--logical-start (pos) + "The first line of the line POS is on, after continuation lines are joined." + (let ((bol (flan-fln--bol pos)) p) + (while (and (flan-fln--continuation-p bol) + (setq p (flan-fln--prev-code bol))) + (setq bol p)) + bol)) + +(defun flan-fln--logical-end (pos) + "The last line of the joined line whose first line is POS's." + (let ((bol (flan-fln--bol pos)) n) + (while (and (setq n (flan-fln--next-code bol)) + (flan-fln--continuation-p n)) + (setq bol n)) + bol)) + +;;; Statements + +(defun flan-fln--statement-last (start &optional no-clauses) + "The last code line of the statement whose first line is START. +With NO-CLAUSES, stop before the first clause at START's column: the first +line's own block only." + (let* ((indent (flan-fln--indent-at start)) + (last (flan-fln--logical-end start)) + (next (flan-fln--next-code last))) + (while (and next + (or (> (flan-fln--indent-at next) indent) + (flan-fln--continuation-p next) + (and (not no-clauses) + (= (flan-fln--indent-at next) indent) + (flan-fln--clause-line-p next)))) + (setq last (flan-fln--logical-end next) + next (flan-fln--next-code last))) + last)) + +(defun flan-fln--span (start last) + "(BEG . END) from the text of START's line to the code end of LAST's." + (cons (flan-fln--first-char start) (flan-fln--code-end last))) + +(defun flan-fln--statement-bounds (start) + "Bounds of the statement whose first line is START." + (flan-fln--span start (flan-fln--statement-last start))) + +(defun flan-fln--clause-header (start) + "The header line the clause at START belongs to, or START if it is not one." + (if (not (flan-fln--clause-line-p start)) + start + (let ((ind (flan-fln--indent-at start)) (p start) hit) + (while (and (not hit) (setq p (flan-fln--prev-code p))) + (setq p (flan-fln--logical-start p)) + (let ((i (flan-fln--indent-at p))) + (cond ((< i ind) (setq hit start)) + ((and (= i ind) (not (flan-fln--clause-line-p p))) + (setq hit p))))) + (or hit start)))) + +(defun flan-fln--code-line-at (pos) + "POS's line if it holds code, else the code line above, else the one below." + (let ((bol (flan-fln--bol pos))) + (if (flan-fln--blank-p bol) + (or (flan-fln--prev-code bol) (flan-fln--next-code bol)) + bol))) + +(defun flan-fln--line-statement (pos) + "The first line of the statement POS's line starts or continues. +A clause line answers for itself." + (let ((l (flan-fln--code-line-at pos))) + (and l (flan-fln--logical-start l)))) + +(defun flan-fln--statement-start-at (pos) + "The first line of the statement at POS; a clause gives its header's." + (let ((l (flan-fln--line-statement pos))) + (and l (flan-fln--clause-header l)))) + +(defun flan-fln--parent (start) + "The nearest line above START that is shallower: its block's owner, or nil. +A clause line owns its own block, so it can be the answer." + (let ((ind (flan-fln--indent-at start)) (p start) hit) + (when (> ind 0) + (while (and (not hit) (setq p (flan-fln--prev-code p))) + (setq p (flan-fln--logical-start p)) + (when (< (flan-fln--indent-at p) ind) (setq hit p)))) + hit)) + +(defun flan-fln--body-bounds (start) + "Bounds of the block under START's first line, or nil when it has none." + (let* ((head-last (flan-fln--logical-end start)) + (first (flan-fln--next-code head-last))) + (when (and first (> (flan-fln--indent-at first) (flan-fln--indent-at start))) + (flan-fln--span first (flan-fln--statement-last start t))))) + +(defun flan-fln--clause-at (pos) + "The clause line whose clause holds POS, the innermost one, or nil. +A match arm is a clause too: its pattern line and its value or block." + (let* ((line (flan-fln--line-statement pos)) + (p line) + (limit (and line (1+ (flan-fln--indent-at line)))) + hit) + (while (and p (not hit)) + (let ((i (flan-fln--indent-at p))) + (when (< i limit) + (if (or (flan-fln--clause-line-p p) (flan-fln--arm p)) + (setq hit p) + (setq limit i))) + (setq p (and (> limit 0) + (let ((q (flan-fln--prev-code p))) + (and q (flan-fln--logical-start q))))))) + hit)) + +(defun flan-fln--clause-bounds (start) + (flan-fln--span start (flan-fln--statement-last start t))) + +;;; Top-level forms + +(defun flan-fln--toplevel-start-p (pos) + "Non-nil if POS's line starts a top-level form. +Column 0 and code, and not a clause, an operator continuation, or a line +inside a bracket or a string -- spec-syntax.md §4.5, tightened." + (and (not (flan-fln--blank-p pos)) + (zerop (flan-fln--indent-at pos)) + (not (flan-fln--continuation-p pos)) + (not (flan-fln--clause-line-p pos)))) + +(defun flan-fln--toplevel-start (pos) + "The first line of the top-level form at or before POS, else the next one." + (save-excursion + (goto-char (flan-fln--bol pos)) + (let (hit) + (while (and (not hit) + (progn (when (flan-fln--toplevel-start-p (point)) + (setq hit (point))) + (not hit)) + (zerop (forward-line -1)))) + (unless hit + (goto-char (flan-fln--bol pos)) + (while (and (not hit) (zerop (forward-line 1)) (not (eobp))) + (when (flan-fln--toplevel-start-p (point)) (setq hit (point))))) + hit))) + +(defun flan-fln--toplevel-last (start) + "The last code line of the top-level form starting at START." + (save-excursion + (goto-char start) + (let ((last start)) + (while (and (zerop (forward-line 1)) (not (eobp)) + (not (flan-fln--toplevel-start-p (point)))) + (unless (flan-fln--blank-p (point)) (setq last (point)))) + ;; A last line with no newline after it. + (when (and (eobp) (not (bolp)) + (not (flan-fln--toplevel-start-p (line-beginning-position))) + (not (flan-fln--blank-p (point)))) + (setq last (line-beginning-position))) + last))) + +(defun flan-fln--toplevel-bounds (pos) + "Bounds of the top-level form at POS, or nil in a buffer with none." + (let ((s (flan-fln--toplevel-start pos))) + (and s (flan-fln--span s (flan-fln--toplevel-last s))))) + +(defun flan-fln--beginning-of-defun (&optional arg) + "Move to the start of the ARGth top-level form back; forward when negative. +For `beginning-of-defun-function'." + (setq arg (or arg 1)) + (let ((found t)) + (if (> arg 0) + (dotimes (_ arg) + (let ((here (point)) hit) + (beginning-of-line) + (when (and (< (point) here) (flan-fln--toplevel-start-p (point))) + (setq hit t)) + (while (and (not hit) (zerop (forward-line -1))) + (when (flan-fln--toplevel-start-p (point)) (setq hit t))) + (unless hit (setq found nil)))) + (dotimes (_ (- arg)) + (let (hit) + (while (and (not hit) (zerop (forward-line 1)) (not (eobp))) + (when (flan-fln--toplevel-start-p (point)) (setq hit t))) + (unless hit (setq found nil))))) + found)) + +(defun flan-fln--end-of-defun () + "From the start of a top-level form, move to its end. +For `end-of-defun-function'." + (goto-char (cdr (flan-fln--span (point) (flan-fln--toplevel-last (point)))))) + +;;; Terms and groups + +(defun flan-fln--term-forward (pos) + (save-excursion + (goto-char pos) + (let (done) + (while (and (not done) (not (eobp))) + (let ((c (char-after)) + (syn (syntax-class (syntax-after (point))))) + (cond ((memq c '(?\s ?\t ?\n ?, ?\;)) (setq done t)) + ((eq c ?\\) (forward-char (min 2 (- (point-max) (point))))) + ((memq syn '(4 7)) + (condition-case nil (forward-sexp 1) + (scan-error (setq done t)))) + ((eq syn 5) (setq done t)) + (t (forward-char 1))))) + (point)))) + +(defun flan-fln--term-back (pos) + (save-excursion + (goto-char pos) + (let (done) + (while (and (not done) (not (bobp))) + (let ((c (char-before)) + (syn (syntax-class (syntax-after (1- (point)))))) + (cond ((and (> (1- (point)) (point-min)) + (eq (char-before (1- (point))) ?\\)) + (backward-char 2)) + ((memq c '(?\s ?\t ?\n ?,)) (setq done t)) + ((eq syn 4) (setq done t)) + ((memq syn '(5 7)) + (condition-case nil (backward-sexp 1) + (scan-error (setq done t)))) + (t (backward-char 1))))) + (point)))) + +(defun flan-fln--trim-colon (beg end) + "END, less the trailing colon of `x:' or `f(x):' when BEG..END has one." + (if (and (> end (1+ beg)) (eq (char-before end) ?:) + (not (eq (char-after beg) ?:))) + (1- end) + end)) + +(defun flan-fln--term-bounds (pos) + "Bounds of the term at POS: a run with no space in it outside brackets." + (let ((s (save-excursion (syntax-ppss pos)))) + (unless (nth 4 s) + (let* ((pos (if (nth 3 s) (nth 8 s) pos)) + (beg (flan-fln--term-back pos)) + (end (flan-fln--trim-colon beg (flan-fln--term-forward pos)))) + (and (< beg end) (cons beg end)))))) + +(defun flan-fln--term-before (pos) + "Bounds of the term that ends at POS, spaces before POS skipped, or nil. +A comment is skipped too: nothing in one is a term." + (save-excursion + (goto-char pos) + (let ((s (syntax-ppss pos))) + (when (nth 4 s) (goto-char (nth 8 s)))) + (skip-chars-backward " \t,") + (let* ((end (point)) + (beg (flan-fln--term-back end)) + (end (flan-fln--trim-colon beg end))) + (and (< beg end) (cons beg end))))) + +(defun flan-fln--group-bounds (pos) + "Bounds of the innermost bracket pair around POS, or nil." + (let ((open (nth 1 (save-excursion (syntax-ppss pos))))) + (and open (cons open (ignore-errors (scan-lists open 1 0)))))) + +(defun flan-fln--group-form-start (open) + "Where the reader starts the form the bracket at OPEN belongs to. +A bracket glued to what is before it is a call, an index or a struct literal, +and the form starts where that term does (`f' of `f(x)', not the paren). A +free `(' groups one value and the form is that value. A free `[' or `{' is +the form." + (let ((before (char-before open))) + (cond + ((and before (not (memq before '(?\s ?\t ?\n ?, ?\( ?\[ ?\{)))) + (let ((b (flan-fln--term-back open))) + ;; `-f(x)' reads as the negation of the call, and the call starts at f. + (if (and (eq (char-after b) ?-) + (string-match-p "[a-zA-Z$_*]" (string (char-after (1+ b))))) + (1+ b) + b))) + ((eq (char-after open) ?\() + (save-excursion + (goto-char (1+ open)) + (skip-chars-forward " \t\n") + (if (eq (char-after) ?\)) open (point)))) + (t open)))) + +;;; Declarations + +(defun flan-fln--declaration-head-at (pos &optional heads) + "The paren head of the declaration written at POS, or nil. +The .fln twin of `flan--declaration-head-at': POS must be at column 0 and not +in a string or comment, and the header word -- `fn', `def', `struct', ... -- +or the fallback call's name, `defmethod(', must read as one of HEADS, +`flan--declaration-heads' by default." + (save-excursion + (let ((state (syntax-ppss pos))) + (goto-char pos) + (and (zerop (current-column)) + (zerop (car state)) + (not (nth 8 state)) + (let ((head + (cond + ((looking-at (concat (regexp-opt (mapcar #'car flan-fln--declaration-words) t) + "[ \t]")) + (cdr (assoc (match-string-no-properties 1) + flan-fln--declaration-words))) + ((looking-at "\\([^][ \t\n(){},;\":]+\\)(") + (match-string-no-properties 1))))) + (and head (member head (or heads flan--declaration-heads)) head)))))) + +;;; Sending + +(defun flan-fln--client () + (require 'flan)) + +(defun flan-fln--cut-indent (beg) + "The byte column of the statement BEG was cut out of, when BEG is mid-line. +A condition or an arm's value starts after `elif ' or `-> ', and a line that +continues it is indented past the statement's start, perhaps not past the +cut. The reader is told where the statement starts (`:indent'), so it +reads the text as the file has it, and every location it reports is still +the buffer's own." + (save-excursion + (goto-char beg) + (when (> (current-column) (current-indentation)) + (back-to-indentation) + (1+ (- (position-bytes (point)) + (position-bytes (line-beginning-position))))))) + +(defun flan-fln--eval-expression (beg end arg) + "Evaluate BEG..END as an expression, as `flan--eval-expression' does, and +with `:indent' when BEG is mid-line." + (flan--report + (flan--request + (let ((at (flan--text-at beg end)) + (indent (flan-fln--cut-indent beg))) + (append (list :op "eval-expr" :code (car at) + :file (or buffer-file-name "")) + (cdr at) + (when indent (list :indent indent)) + (when arg (list :pause t))))) + "expression" + end)) + +(defun flan-fln--send (beg end arg heads) + "Send BEG..END: installed when it is a declaration at column 0, else run. +HEADS says which heads count as declarations. ARG is a prefix: on a +declaration it marks the whole form (stop on entry), on an expression it is +the stop-here flag." + (let ((head (flan-fln--declaration-head-at beg heads))) + (if head + (flan--eval (flan--text beg end) head beg end (and arg (cons beg end))) + (prog1 (flan-fln--eval-expression beg end arg) + (pulse-momentary-highlight-region beg end))))) + +(defun flan-fln--pause-bounds (b arg) + "The form to mark inside the top-level form B for prefix ARG, or nil. +One `C-u': the innermost bracket group around point -- the form it belongs +to, from where the reader starts it -- else the statement on point's line. +Two: B itself, which stops on entry." + (cond + ((null arg) nil) + ((and (consp arg) (> (prefix-numeric-value arg) 4)) b) + (t (or (flan-fln--pause-target (point) b) b)))) + +(defun flan-fln--pause-target (pos b) + "The form to stop at for point at POS inside the top-level form B. +Its start is where the reader starts that form, which is all the daemon +matches on: a match arm's value or block, not its pattern, which is no +form; an elif's condition and an else's, on's or restart's block, which are +forms, where the clause line itself is not." + (let* ((l (flan-fln--line-statement pos)) + (arm (and l (flan-fln--arm l))) + (g (flan-fln--group-bounds pos))) + (cond + ((and arm (< pos (plist-get arm :arrow))) (plist-get arm :value)) + ((and g (cdr g) (> (car g) (car b))) + (cons (flan-fln--group-form-start (car g)) (cdr g))) + (arm (plist-get arm :value)) + ((and l (flan-fln--clause-line-p l)) (flan-fln--clause-target l)) + (t (let ((s (flan-fln--statement-start-at pos))) + (and s (flan-fln--statement-bounds s))))))) + +(defun flan-fln--clause-target (l) + "What a clause line L stops at: an elif's condition, else its block." + (save-excursion + (goto-char (flan-fln--first-char l)) + (if (looking-at "elif[ \t]+") + (cons (match-end 0) (flan-fln--code-end (flan-fln--logical-end l))) + (flan-fln--body-bounds l)))) + +(defun flan-fln--condition (l) + "Bounds of the condition on the if, elif, while or until line L, or nil. +A loop's label, `while :outer c', is not part of it." + (save-excursion + (goto-char (flan-fln--first-char l)) + (when (looking-at "\\(?:if\\|elif\\|while\\|until\\)[ \t]+\\(?::[^ \t]+[ \t]+\\)?") + (let ((beg (match-end 0)) + (end (flan-fln--code-end (flan-fln--logical-end l)))) + (and (< beg end) (cons beg end)))))) + +(defun flan-fln--arm (l) + "The match arm whose joined line starts at L, or nil. +A plist: :arrow, where its ` -> ' starts; :value, the bounds of what follows +the arrow on the line, or of the block under it; :binds, non-nil when the +pattern names something, so the value cannot be evaluated alone." + (let ((parent (flan-fln--parent l))) + (when (and parent + (string-match-p "\\(?:\\`\\|[ \t]=[ \t]+\\)match\\(?:[ \t]\\|\\'\\)" + (buffer-substring-no-properties + (flan-fln--first-char parent) + (flan-fln--code-end parent)))) + (save-excursion + (let* ((start (flan-fln--first-char l)) + (last (flan-fln--code-end (flan-fln--logical-end l))) + (depth (car (syntax-ppss start))) + arrow) + (goto-char start) + (while (and (not arrow) + (re-search-forward "[ \t]\\(->\\)\\(?:[ \t]\\|$\\)" last t)) + (let ((ps (save-excursion (syntax-ppss (match-beginning 1))))) + (when (and (= (car ps) depth) (not (nth 8 ps))) + (setq arrow (match-beginning 1))))) + (when arrow + (let* ((pat (string-trim (buffer-substring-no-properties start arrow))) + (vbeg (save-excursion (goto-char (+ arrow 2)) + (skip-chars-forward " \t") (point))) + (value (if (< vbeg last) (cons vbeg last) + (flan-fln--body-bounds l)))) + (and value + (list :arrow arrow :value value + :binds (flan-fln--uses-any-p + (flan-fln--pattern-names pat) + (buffer-substring-no-properties + (car value) (cdr value)))))))))))) + +(defun flan-fln--names-in (text &optional skip-heads) + "Every name in TEXT, as the syntax table reads names, and each dotted part +of one: `p.x' gives `p.x', `p' and `x'. With SKIP-HEADS, not a name glued to +a `(' -- a pattern's constructor, which binds nothing." + (with-temp-buffer + (set-syntax-table flan-fln-mode-syntax-table) + (insert text) + (goto-char (point-min)) + (let (names) + (while (re-search-forward "\\(?:\\sw\\|\\s_\\)+" nil t) + (let ((n (match-string-no-properties 0))) + ;; A `-' glued to a letter, `$', `_' or `*' is negation, not part + ;; of the name (`is_neg_char' in lib/indent_reader.ml): `-n' is n. + (when (string-match "\\`-[a-zA-Z$_*]" n) + (setq n (substring n 1))) + (unless (and skip-heads (eq (char-after) ?\()) + (push n names) + (dolist (part (split-string n "\\." t)) + (push part names))))) + (delete-dups names)))) + +(defun flan-fln--pattern-names (pat) + "The names pattern PAT may bind: every name in it but a constructor head. +Numbers are not names. Generous otherwise -- a keyword or a constant counts +too -- because a name +wrongly counted only sends the whole match, and one missed sends a value +that reads a global of the same name and shows a wrong answer." + (seq-remove (lambda (n) (string-match-p "\\`[-+]?[0-9]" n)) + (flan-fln--names-in pat t))) + +(defun flan-fln--uses-any-p (names text) + "Non-nil if TEXT has any of NAMES as a name, or as part of a dotted one." + (seq-some (lambda (n) (member n names)) (flan-fln--names-in text))) + +(defun flan-fln--arm-to-send (l arm) + "What evaluating the match arm at L sends: its value, or, when its pattern +binds a name the value uses, the whole match." + (if (plist-get arm :binds) + (flan-fln--statement-bounds + (flan-fln--statement-start-at (flan-fln--parent l))) + (plist-get arm :value))) + +;;;###autoload +(defun flan-fln-eval-defun (&optional arg) + "Evaluate the top-level form at point in the running program. +A declaration is installed and anything else is evaluated, as `C-c C-c' does +in a .flan file. With one \\[universal-argument] on a declaration, also stop +at the innermost bracket group around point, or else at the statement on +point's line, when it next runs; with two, on entry." + (interactive "P") + (flan-fln--client) + (let ((b (flan-fln--toplevel-bounds (point)))) + (unless b (user-error "flan: no top-level form at point to evaluate")) + (let ((head (flan-fln--declaration-head-at (car b) flan--defun-heads))) + (if head + (flan--eval (flan--text (car b) (cdr b)) head (car b) (cdr b) + (flan-fln--pause-bounds b arg)) + (prog1 (flan--eval-expression (car b) (cdr b) arg) + (pulse-momentary-highlight-region (car b) (cdr b))))))) + +;;;###autoload +(defun flan-fln-step-defun () + "Install the top-level form at point so a call stops before each form. +`flan-step-defun' for a .fln buffer: the same stepper, over this syntax's +top-level form." + (interactive) + (flan-fln--client) + (let* ((b (flan-fln--toplevel-bounds (point))) + (head (and b (flan-fln--declaration-head-at (car b) flan--defun-heads)))) + (unless head (user-error "flan: no fn at point to step through")) + (flan--eval (flan--text (car b) (cdr b)) "form" (car b) (cdr b) nil t))) + +(defun flan-fln--point-for-last () + "Point, or under Evil's normal state the position after the cursor's char. +The cursor sits *on* the last character of a line, never after it." + (if (and (bound-and-true-p evil-local-mode) + (memq evil-state '(normal motion)) + (not (eolp))) + (1+ (point)) + (point))) + +(defun flan-fln--statement-ending-at (pos) + "Bounds of the innermost statement whose last line is POS's, or nil." + (let ((l (flan-fln--line-statement pos))) + (when (and l (not (flan-fln--blank-p pos)) (not (flan-fln--clause-line-p l)) + (= (flan-fln--statement-last l) (flan-fln--bol pos))) + (flan-fln--statement-bounds l)))) + +;;;###autoload +(defun flan-fln-eval-last (&optional arg) + "Evaluate the statement that ends at point, or the term before point. +At the end of a line, the innermost statement whose last line it is; a +declaration at column 0 is installed. Anywhere else, the term that ends +before point. With ARG, stop there instead, as \\[flan-eval-last-sexp] does." + (interactive "P") + (flan-fln--client) + (let* ((end (flan-fln--point-for-last)) + ;; A line the next one continues -- an operator at either side of + ;; the break, or a bracket left open -- ends where the whole joined + ;; line does, not at its last word. + (end (if (and (>= end (flan-fln--code-end end)) + (not (flan-fln--blank-p end)) + (let ((n (flan-fln--next-code end))) + (and n (flan-fln--continuation-p n)))) + (flan-fln--code-end + (flan-fln--logical-end (flan-fln--logical-start end))) + end)) + (at-end (and (>= end (flan-fln--code-end end)) + (not (flan-fln--blank-p end)))) + (l (and at-end (flan-fln--line-statement end))) + ;; Point ends the line L starts, joined lines included. + (l-end (and l (= (flan-fln--bol end) (flan-fln--logical-end l)))) + (arm (and l-end (flan-fln--arm l))) + (st (and at-end (not arm) (flan-fln--statement-ending-at end))) + (opens (and l-end (not st) (not arm) + (or (flan-fln--clause-line-p l) + (/= (flan-fln--statement-last l) + (flan-fln--logical-end l)))))) + (cond + (arm (let ((b (flan-fln--arm-to-send l arm))) + (flan-fln--send (car b) (cdr b) arg flan--declaration-heads))) + (st (flan-fln--send (car st) (cdr st) arg flan--declaration-heads)) + ;; The end of a line that opens a block: its last word is not what was + ;; meant. A condition is a value of its own; anything else is sent + ;; with its block, a clause with the statement it belongs to. + ((and opens (flan-fln--condition l)) + (let ((c (flan-fln--condition l))) + (flan-fln--eval-expression (car c) (cdr c) arg))) + (opens + (let ((b (flan-fln--statement-bounds (flan-fln--clause-header l)))) + (flan-fln--send (car b) (cdr b) arg flan--declaration-heads))) + (t + (let ((tb (flan-fln--term-before end))) + (unless tb (user-error "flan: no form before point to evaluate")) + (flan--eval-expression (car tb) (cdr tb) arg)))))) + +(defun flan-fln--snap-lines (beg end) + "BEG..END widened to whole lines, less leading blank lines and trailing space." + (let ((first (flan-fln--bol beg)) + (last (flan-fln--bol (if (and (> end beg) + (save-excursion (goto-char end) (bolp))) + (1- end) + end)))) + (when (flan-fln--blank-p first) (setq first (flan-fln--next-code first))) + (when (and first (<= first last)) + (cons (flan-fln--first-char first) + (save-excursion (goto-char last) (end-of-line) + (skip-chars-backward " \t\n" first) (point)))))) + +(defun flan-fln--bare-let-p (start) + "Non-nil if START's statement is a `let' with no block of its own." + (and (save-excursion (goto-char (flan-fln--first-char start)) + (looking-at "let[ \t]")) + (= (flan-fln--statement-last start) (flan-fln--logical-end start)))) + +(defun flan-fln--block-rest (start) + "START's statement and every statement after it in the same block." + (let* ((ind (flan-fln--indent-at start)) + (last (flan-fln--statement-last start)) + (next (flan-fln--next-code last))) + (while (and next (= (flan-fln--indent-at next) ind) + (not (flan-fln--clause-line-p next))) + (setq last (flan-fln--statement-last next) + next (flan-fln--next-code last))) + (flan-fln--span start last))) + +(defun flan-fln--statement-to-send (pos) + "The statement at POS as sent by `C-c C-e': with its body and clauses, and +for a bare `let x = v', with the rest of its block, which is its scope." + (let* ((l (flan-fln--line-statement pos)) + (arm (and l (flan-fln--arm l))) + (s (flan-fln--statement-start-at pos))) + (cond (arm (flan-fln--arm-to-send l arm)) + ((null s) nil) + ((flan-fln--bare-let-p s) (flan-fln--block-rest s)) + (t (flan-fln--statement-bounds s))))) + +;;;###autoload +(defun flan-fln-eval-statement (&optional arg) + "Evaluate the statement at point, with its body and clauses. +With an active region, the lines it touches instead. On a bare `let x = v', +the `let' and the rest of its block, which is what it is in scope for; the +span sent is flashed so the extent is visible. A declaration at column 0 is +installed. ARG is as for \\[flan-fln-eval-last]." + (interactive "P") + (flan-fln--client) + (let ((b (if (use-region-p) + (flan-fln--snap-lines (region-beginning) (region-end)) + (flan-fln--statement-to-send (point))))) + (unless b (user-error "flan: no statement at point to evaluate")) + (when (use-region-p) (deactivate-mark)) + (flan-fln--send (car b) (cdr b) arg flan--defun-heads))) + +;;;###autoload +(defun flan-fln-eval-statement-and-next () + "Evaluate the statement at point, then move to the statement after it." + (interactive) + (flan-fln--client) + (let ((b (flan-fln--statement-to-send (point)))) + (unless b (user-error "flan: no statement at point to evaluate")) + (prog1 (flan-fln--send (car b) (cdr b) nil flan--defun-heads) + (let ((n (flan-fln--next-code (cdr b)))) + (goto-char (if n (flan-fln--first-char n) (cdr b))))))) + +;;; Motion + +(defun flan-fln-backward-statement (&optional n) + "Move to the start of the statement at point, or to the one before it. +Before it at the same level, else out to the line that owns this block." + (interactive "^p") + (dotimes (_ (or n 1)) + (let* ((l (flan-fln--line-statement (point))) + (here (and l (flan-fln--first-char l)))) + (cond + ((null l)) + ((> (point) here) (goto-char here)) + (t + (let ((ind (flan-fln--indent-at l)) (p l) hit) + (while (and (not hit) (setq p (flan-fln--prev-code p))) + (setq p (flan-fln--logical-start p)) + (when (<= (flan-fln--indent-at p) ind) + (setq hit (if (= (flan-fln--indent-at p) ind) + (flan-fln--clause-header p) + p)))) + (when hit (goto-char (flan-fln--first-char hit))))))))) + +(defun flan-fln-forward-statement (&optional n) + "Move to the end of the statement at point, or of the one after it." + (interactive "^p") + (dotimes (_ (or n 1)) + (let* ((s (flan-fln--statement-start-at (point))) + (e (and s (cdr (flan-fln--statement-bounds s))))) + (cond + ((null s)) + ((< (point) e) (goto-char e)) + (t (let ((nx (flan-fln--next-code (flan-fln--statement-last s)))) + (when nx + (goto-char (cdr (flan-fln--statement-bounds + (flan-fln--clause-header + (flan-fln--logical-start nx)))))))))))) + +(defun flan-fln-next-statement (&optional n) + "Move to the start of the statement after the one at point." + (interactive "^p") + (dotimes (_ (or n 1)) + (let* ((s (flan-fln--statement-start-at (point))) + (nx (and s (flan-fln--next-code (flan-fln--statement-last s))))) + (when nx (goto-char (flan-fln--first-char nx)))))) + +(defun flan-fln-up (&optional n) + "Move up to the bracket around point, or to the line that owns its block." + (interactive "^p") + (dotimes (_ (or n 1)) + (let ((open (nth 1 (syntax-ppss)))) + (if open + (goto-char open) + (let* ((l (flan-fln--line-statement (point))) + (p (and l (flan-fln--parent l)))) + (if p (goto-char (flan-fln--first-char p)) + (user-error "flan: at top level"))))))) + +;;; Marking, for expand-region and anything else that marks + +(defun flan-fln--region () + (if (use-region-p) (cons (region-beginning) (region-end)) (cons (point) (point)))) + +(defun flan-fln--larger-p (b r) + "Non-nil if bounds B contain region R and are larger than it." + (and b (cdr b) (<= (car b) (car r)) (>= (cdr b) (cdr r)) + (> (- (cdr b) (car b)) (- (cdr r) (car r))))) + +(defun flan-fln--mark (b) + (when b + (goto-char (car b)) + (push-mark (cdr b) t t) + (activate-mark) + b)) + +(defun flan-fln-mark-term () + "Mark the term at point, or the one around the marked text." + (interactive) + (let* ((r (flan-fln--region)) + (b (flan-fln--term-bounds (car r)))) + ;; Out through the brackets until the term holds the region. + (while (and b (not (flan-fln--larger-p b r))) + (let ((g (flan-fln--group-bounds (car b)))) + (setq b (and g (flan-fln--term-bounds (car g)))))) + (flan-fln--mark b))) + +(defun flan-fln-mark-group () + "Mark the bracket group around point, or around the marked text." + (interactive) + (let* ((r (flan-fln--region)) + (b (flan-fln--group-bounds (car r)))) + (while (and b (not (flan-fln--larger-p b r))) + (setq b (flan-fln--group-bounds (car b)))) + (flan-fln--mark b))) + +(defun flan-fln--statement-around (r) + "The innermost statement that holds region R and is larger than it." + (let* ((s (flan-fln--statement-start-at (car r))) + (b (and s (flan-fln--statement-bounds s)))) + (while (and s (not (flan-fln--larger-p b r))) + ;; A clause's statement is its header's. + (let ((h (flan-fln--clause-header s))) + (setq s (if (/= h s) h (flan-fln--parent s))) + (setq b (and s (flan-fln--statement-bounds s))))) + b)) + +(defun flan-fln-mark-statement () + "Mark the statement at point, or the one around the marked text." + (interactive) + (flan-fln--mark (flan-fln--statement-around (flan-fln--region)))) + +(defun flan-fln-mark-clause () + "Mark the clause at point, or the one around the marked text." + (interactive) + (let* ((r (flan-fln--region)) + (c (flan-fln--clause-at (car r))) + (b (and c (flan-fln--clause-bounds c)))) + (while (and c (not (flan-fln--larger-p b r))) + (setq c (let ((p (flan-fln--parent c))) (and p (flan-fln--clause-at p)))) + (setq b (and c (flan-fln--clause-bounds c)))) + (flan-fln--mark b))) + +(defun flan-fln-mark-toplevel () + "Mark the top-level form at point." + (interactive) + (flan-fln--mark (flan-fln--toplevel-bounds (car (flan-fln--region))))) + +;; thing-at-point, so `(bounds-of-thing-at-point 'flan-fln-statement)' and +;; everything built on it knows the objects. +(put 'flan-fln-term 'bounds-of-thing-at-point + (lambda () (flan-fln--term-bounds (point)))) +(put 'flan-fln-group 'bounds-of-thing-at-point + (lambda () (flan-fln--group-bounds (point)))) +(put 'flan-fln-statement 'bounds-of-thing-at-point + (lambda () (let ((s (flan-fln--statement-start-at (point)))) + (and s (flan-fln--statement-bounds s))))) +(put 'flan-fln-body 'bounds-of-thing-at-point + (lambda () (let ((s (flan-fln--statement-start-at (point)))) + (and s (flan-fln--body-bounds s))))) +(put 'flan-fln-clause 'bounds-of-thing-at-point + (lambda () (let ((c (flan-fln--clause-at (point)))) + (and c (flan-fln--clause-bounds c))))) +(put 'flan-fln-toplevel 'bounds-of-thing-at-point + (lambda () (flan-fln--toplevel-bounds (point)))) + +;;; Indentation + +;; TAB offers the columns of the blocks open above the line, plus one level +;; deeper after a line that opens a block. The first TAB takes the deepest, +;; each repeated TAB steps out one. A block's column is the program's +;; meaning, so nothing here ever moves a line on its own: `indent-region' +;; shifts rigidly and only when the first line is at no valid column, and a +;; yank moves its lines together. + +(defun flan-fln--opener-p (start last) + "Non-nil if the joined line START..LAST opens a block on the lines under it." + (or (save-excursion + (goto-char start) + (back-to-indentation) + (and (looking-at (concat (regexp-opt flan-fln--opener-words t) + "\\([ \t]\\|$\\)")) + (let ((w (match-string-no-properties 1)) + (alone (string= (match-string-no-properties 2) "")) + (end (flan-fln--code-end last))) + (cond + ((member w '("defer" "quote")) alone) + ((member w '("fn" "fn-")) + (not (re-search-forward "[ \t]=[ \t]" end t))) + ((member w '("if" "elif")) + (not (re-search-forward "[ \t]then[ \t]" end t))) + (t t))))) + (save-excursion + (goto-char (flan-fln--code-end last)) + (let ((bol (line-beginning-position))) + (or (looking-back ":" bol) + (looking-back "[ \t]->" bol) + ;; `let x =' and `def colors =' with the value as a block, + ;; which the author's list leaves out and the reader reads. + (looking-back "[ \t]=" bol) + ;; `let f = fn(x)' with its body under it. + (looking-back "\\_ min 0) (flan-fln--prev-code p)))) + (unless (eql min 0) (push (cons 0 nil) out)) + (nreverse out))) + +(defun flan-fln--levels (pos) + "Columns TAB offers POS's line outside brackets, deepest first." + (let* ((prev (flan-fln--prev-code pos)) + (stack (mapcar #'car (flan-fln--stack pos)))) + (if (and prev (flan-fln--opener-p (flan-fln--logical-start prev) prev)) + (cons (+ (flan-fln--indent-at (flan-fln--logical-start prev)) + flan-fln-indent-offset) + stack) + stack))) + +(defun flan-fln--clause-columns (word pos) + "Columns of the lines above POS a clause WORD may sit under, deepest first." + (let ((heads (cdr (assoc word flan-fln--clause-headers)))) + (delq nil + (mapcar (lambda (e) + (and (cdr e) + (save-excursion + (goto-char (flan-fln--first-char (cdr e))) + (and (looking-at (concat (regexp-opt heads) + "\\(?:[ \t]\\|$\\)")) + (car e))))) + (flan-fln--stack pos))))) + +(defun flan-fln--bracket-column (open) + "The column a line inside the bracket at OPEN goes to. +Under the first element when one follows the bracket on its line, one level +in from that line when none does -- the paren mode's rule for data and +calls alike. A line that starts with the closing bracket goes to the +opening line's column." + (save-excursion + (let ((closing (save-excursion (back-to-indentation) (looking-at "\\s)")))) + (goto-char open) + (if closing + (current-indentation) + (forward-char 1) + (skip-chars-forward " \t") + (if (or (eolp) (eq (char-after) ?\;)) + (+ (current-indentation) flan-fln-indent-offset) + (current-column)))))) + +(defun flan-fln--indent-candidates (pos) + "Columns TAB offers POS's line, deepest first; nil to leave it alone." + (save-excursion + (goto-char (flan-fln--bol pos)) + (let ((s (syntax-ppss (point)))) + (cond + ((nth 3 s) nil) + ((> (car s) 0) (list (flan-fln--bracket-column (nth 1 s)))) + (t + (let ((prev (flan-fln--prev-code (point)))) + (cond + ((null prev) (list 0)) + ((save-excursion (back-to-indentation) (looking-at flan-fln--clause-re)) + (or (flan-fln--clause-columns (match-string-no-properties 1) (point)) + (flan-fln--levels (point)))) + ((or (flan-fln--starts-with-op-p (point)) + (flan-fln--ends-in-op-p prev)) + (list (+ (flan-fln--indent-at (flan-fln--logical-start prev)) + flan-fln-indent-offset))) + (t (flan-fln--levels (point)))))))))) + +(defun flan-fln-indent-line () + "Indent the line to a block column. +A line with text at a valid column stays there: its column is its meaning, +and a TAB pressed to see where it goes must not change it. An empty line +goes to the deepest column. Each repeated TAB then steps out one." + (let* ((cands (flan-fln--indent-candidates (point))) + (cur (current-indentation)) + (target + (cond ((null cands) nil) + ((and (eq this-command 'indent-for-tab-command) + (eq last-command 'indent-for-tab-command) + (memq cur cands)) + (or (cadr (memq cur cands)) (car cands))) + ((and (memq cur cands) + (not (save-excursion (beginning-of-line) + (looking-at-p "[ \t]*$")))) + cur) + (t (car cands))))) + (if (null target) + 'noindent + (let ((from-end (and (> (current-column) cur) (- (point-max) (point))))) + (indent-line-to target) + (when from-end (goto-char (- (point-max) from-end))))))) + +(defun flan-fln-indent-region (start end) + "Shift START..END rigidly so its first line sits at a block column. +Never re-indents a line against the others: the columns are the program." + (save-excursion + (goto-char start) + (beginning-of-line) + (while (and (< (point) end) (flan-fln--blank-p (point)) + (zerop (forward-line 1)))) + (when (< (point) end) + (let ((cands (flan-fln--indent-candidates (point))) + (cur (current-indentation))) + (when (and cands (not (memq cur cands))) + (indent-rigidly (point) end (- (car cands) cur))))))) + +(defun flan-fln-dedent-or-delete (arg) + "In a line's indentation, drop it one block level; else delete a character." + (interactive "*p") + (if (and (= arg 1) (not (use-region-p)) + (> (current-column) 0) + (= (current-column) (current-indentation)) + (not (flan-fln--in-open-p (point)))) + (let ((cur (current-indentation))) + (indent-line-to (or (seq-find (lambda (c) (< c cur)) + (flan-fln--levels (point))) + 0))) + (let ((cmd (or (command-remapping 'delete-backward-char) + #'delete-backward-char))) + (setq this-command cmd) + (call-interactively cmd)))) + +(defun flan-fln--electric-clause () + "Snap an else, elif, on or restart line to its header as it is typed. +Run when the word is finished by a space or a newline." + (when (memq last-command-event '(?\s ?\n ?\r)) + (save-excursion + (let ((nl (not (eq last-command-event ?\s)))) + (when nl (forward-line -1)) + (let ((text (buffer-substring-no-properties + (line-beginning-position) + (if nl (line-end-position) (point))))) + (when (and (string-match "\\`[ \t]*\\(else\\|elif\\|on\\|restart\\)[ \t]*\\'" + text) + (not (flan-fln--in-open-p (point)))) + (let ((cols (flan-fln--clause-columns (match-string 1 text) (point)))) + (when (and cols (not (memq (current-indentation) cols))) + (indent-line-to (car cols)))))))) + ;; The new line was indented from the old one before it moved. + (when (memq last-command-event '(?\n ?\r)) + (let ((c (car (flan-fln--indent-candidates (point))))) + (when (and c (= (current-column) (current-indentation))) + (indent-line-to c)))))) + +(defun flan-fln-shift-right (start end &optional n) + "Shift the lines of the region, or the line, right by N block levels." + (interactive (if (use-region-p) + (list (region-beginning) (region-end) (prefix-numeric-value current-prefix-arg)) + (list (line-beginning-position) (line-end-position) + (prefix-numeric-value current-prefix-arg)))) + (let ((deactivate-mark nil)) + (indent-rigidly (flan-fln--bol start) end (* (or n 1) flan-fln-indent-offset)))) + +(defun flan-fln-shift-left (start end &optional n) + "Shift the lines of the region, or the line, left by N block levels." + (interactive (if (use-region-p) + (list (region-beginning) (region-end) (prefix-numeric-value current-prefix-arg)) + (list (line-beginning-position) (line-end-position) + (prefix-numeric-value current-prefix-arg)))) + (let ((deactivate-mark nil)) + (indent-rigidly (flan-fln--bol start) end (- (* (or n 1) flan-fln-indent-offset))))) + +(defun flan-fln--yank-base (start end first-ws) + "The column the yanked text between START and END was written at. +FIRST-WS is the width of its first line's own indentation, when it kept one." + (if (> first-ws 0) + first-ws + ;; The first line was cut from its first character: read the column off + ;; the lines under it. A clause sits at the statement's column; failing + ;; one, the shallowest line is a body, one level in. + (let (min clause) + (save-excursion + (goto-char start) + (while (and (zerop (forward-line 1)) (< (point) end)) + (unless (flan-fln--blank-p (point)) + (let ((i (current-indentation))) + (when (or (null min) (< i min)) (setq min i clause nil)) + (when (and (= i min) + (save-excursion (back-to-indentation) + (looking-at flan-fln--clause-re))) + (setq clause t)))))) + (cond ((null min) 0) + (clause min) + (t (max 0 (- min flan-fln-indent-offset))))))) + +(defun flan-fln-yank (&optional arg) + "Yank, then move the lines after the first with it, rigidly. +The first line lands at point; every other line keeps its place relative to +it, so a block pasted at another depth stays one block." + (interactive "*P") + (let* ((col (current-column)) + (at-indent (<= col (current-indentation)))) + (setq this-command 'yank) + (yank arg) + (let ((end (copy-marker (max (point) (mark t)))) + (start (min (point) (mark t)))) + (save-excursion + (goto-char start) + (when (< (line-end-position) end) + (let* ((ws (save-excursion (skip-chars-forward " \t") (- (point) start))) + (base (flan-fln--yank-base start end ws))) + (when (and at-indent (> ws 0)) + (delete-region start (+ start ws))) + (forward-line 1) + (when (< (point) end) + (indent-rigidly (point) end (- col base)))))) + (set-marker end nil)))) + +;;; Block editing + +(defun flan-fln--ensure-final-newline () + (save-excursion + (goto-char (point-max)) + (unless (bolp) (insert "\n")))) + +(defun flan-fln--lines (start last) + "(BEG . END) of the whole lines START through LAST, final newline included." + (cons start (save-excursion (goto-char last) (line-beginning-position 2)))) + +(defun flan-fln--statement-lines (s) + (flan-fln--lines s (flan-fln--statement-last s))) + +(defun flan-fln-kill-statement () + "Kill the statement at point, whole lines, body and clauses included." + (interactive) + (flan-fln--ensure-final-newline) + (let ((s (flan-fln--statement-start-at (point)))) + (unless s (user-error "flan: no statement at point")) + (let ((l (flan-fln--statement-lines s))) + (kill-region (car l) (cdr l))))) + +(defun flan-fln--sibling (s dir) + "The statement next to S at its level: before it when DIR is -1, else after." + (let ((ind (flan-fln--indent-at s))) + (if (< dir 0) + (let ((p (flan-fln--prev-code s)) hit) + (while (and p (not hit)) + (setq p (flan-fln--logical-start p)) + (let ((i (flan-fln--indent-at p))) + (cond ((< i ind) (setq p nil)) + ((= i ind) (setq hit (flan-fln--clause-header p))) + (t (setq p (flan-fln--prev-code p)))))) + hit) + (let ((n (flan-fln--next-code (flan-fln--statement-last s)))) + (and n (= (flan-fln--indent-at n) ind) + (not (flan-fln--clause-line-p n)) + n))))) + +(defun flan-fln--swap (a b) + "Swap the whole-line statements A and B, A above B; keep point in its own." + (let* ((la (flan-fln--statement-lines a)) + (lb (flan-fln--statement-lines b)) + (ta (buffer-substring (car la) (cdr la))) + (gap (buffer-substring (cdr la) (car lb))) + (tb (buffer-substring (car lb) (cdr lb))) + (in-b (>= (point) (car lb))) + (off (- (point) (if in-b (car lb) (car la))))) + (goto-char (car la)) + (delete-region (car la) (cdr lb)) + (insert tb gap ta) + (goto-char (+ (car la) off (if in-b 0 (+ (length tb) (length gap))))))) + +(defun flan-fln-move-statement-up () + "Swap the statement at point with the one before it at its level." + (interactive) + (flan-fln--ensure-final-newline) + (let* ((s (flan-fln--statement-start-at (point))) + (p (and s (flan-fln--sibling s -1)))) + (unless p (user-error "flan: no statement above this one at its level")) + (flan-fln--swap p s))) + +(defun flan-fln-move-statement-down () + "Swap the statement at point with the one after it at its level." + (interactive) + (flan-fln--ensure-final-newline) + (let* ((s (flan-fln--statement-start-at (point))) + (n (and s (flan-fln--sibling s 1)))) + (unless n (user-error "flan: no statement below this one at its level")) + (flan-fln--swap s n))) + +(defun flan-fln--owner (pos) + "The line that owns the block POS is in or opens: a header with a body." + (let ((s (flan-fln--statement-start-at pos))) + (cond ((null s) nil) + ((flan-fln--body-bounds (flan-fln--line-statement pos)) + (flan-fln--line-statement pos)) + (t (flan-fln--parent (flan-fln--line-statement pos)))))) + +(defun flan-fln--shift-lines (l delta) + (indent-rigidly (car l) (cdr l) delta)) + +(defun flan-fln-slurp () + "Pull the statement after this block into it, as its last statement." + (interactive) + (flan-fln--ensure-final-newline) + (let* ((o (or (flan-fln--owner (point)) (user-error "flan: no block here"))) + (last (flan-fln--statement-last o t)) + (n (flan-fln--next-code last)) + (body (flan-fln--body-bounds o))) + (unless (and n (= (flan-fln--indent-at n) (flan-fln--indent-at o)) + (not (flan-fln--clause-line-p n))) + (user-error "flan: no statement after this block to pull in")) + (save-excursion + (flan-fln--shift-lines (flan-fln--statement-lines n) + (- (flan-fln--indent-at (car body)) + (flan-fln--indent-at o)))))) + +(defun flan-fln-barf () + "Push this block's last statement out, to follow the block." + (interactive) + (flan-fln--ensure-final-newline) + (let* ((o (or (flan-fln--owner (point)) (user-error "flan: no block here"))) + (body (flan-fln--body-bounds o)) + (ind (flan-fln--indent-at (car body))) + (last (flan-fln--statement-last o t)) + (after (flan-fln--next-code last)) + (child (flan-fln--bol (car body))) c) + (when (and after (= (flan-fln--indent-at after) (flan-fln--indent-at o)) + (flan-fln--clause-line-p after)) + (user-error "flan: a clause follows this block; its last statement cannot leave it")) + (while (setq c (flan-fln--sibling child 1)) (setq child c)) + (when (= (flan-fln--bol child) (flan-fln--bol (car body))) + (user-error "flan: this block has one statement; pushing it out would empty it")) + (save-excursion + (flan-fln--shift-lines (flan-fln--statement-lines child) + (- (flan-fln--indent-at o) ind))))) + +(defun flan-fln-raise-statement () + "Replace the statement that owns this block with the statement at point." + (interactive) + (flan-fln--ensure-final-newline) + (let* ((s (or (flan-fln--statement-start-at (point)) + (user-error "flan: no statement at point"))) + (o (or (flan-fln--parent s) (user-error "flan: at top level"))) + (h (flan-fln--clause-header o)) + (ls (flan-fln--statement-lines s)) + (lh (flan-fln--statement-lines h)) + (text (buffer-substring (car ls) (cdr ls))) + (delta (- (flan-fln--indent-at h) (flan-fln--indent-at s)))) + (goto-char (car lh)) + (delete-region (car lh) (cdr lh)) + (let ((beg (point))) + (insert text) + (indent-rigidly beg (point) delta) + (goto-char beg) + (back-to-indentation)))) + +;;; Font lock + +(defconst flan-fln--name-re "\\([^][ \t\n(){},;\":]+\\)" + "A declared name: a run up to a bracket, a space, or the colon of `x: T'.") + +(defvar flan-fln-font-lock-keywords + `(;; The header words, at the start of a line and followed by a space or the + ;; end of it: `if(c, a)' is the fallback call and is not a header. + (,(concat "^[ \t]*" (regexp-opt flan-fln--header-words t) "\\(?:[ \t]\\|$\\)") + 1 font-lock-keyword-face) + (,(concat "^\\(fn-?\\)[ \t]+" flan-fln--name-re) + 2 font-lock-function-name-face) + (,(concat "^\\(?:struct\\|data\\|union\\|enum\\)[ \t]+" flan-fln--name-re) + 1 font-lock-type-face) + (,(concat "^\\(?:def\\|once\\|const\\)[ \t]+" flan-fln--name-re) + 1 font-lock-variable-name-face) + ;; The words inside a line: `for i in range(n)', `if c then a else b', a + ;; `where' constraint. + ("[ \t]\\(then\\|else\\|in\\|where\\)[ \t]" 1 font-lock-keyword-face) + ;; The operator words. + ("\\_<\\(and\\|or\\|not\\)\\_>" 1 font-lock-keyword-face) + (,(concat "\\_<" (regexp-opt flan--constants t) "\\_>") + 1 font-lock-constant-face) + ;; A keyword. `x:' is a name with a colon glued on, not one. + ("\\(?:^\\|[][ \t(){},]\\)\\(:[^][ \t\n(){},;\":]+\\)" 1 font-lock-constant-face) + ;; A type: after the `: ' of an annotation and after `-> '. + ("[^ \t\n:]:[ \t]+\\([$a-zA-Z][^][ \t\n(){},;\"=]*\\)" 1 font-lock-type-face) + ("[ \t]->[ \t]+\\([$a-zA-Z][^][ \t\n(){},;\"=]*\\)" 1 font-lock-type-face) + ;; The package half of a qualified name, as `flan-mode' draws it. + ("\\_<\\([a-zA-Z][a-zA-Z0-9!?*+=<>._-]*/\\)" 1 font-lock-type-face) + ("\\_<\\(?:[iu]\\(?:8\\|16\\|32\\|64\\)\\|f\\(?:32\\|64\\)\\|bool\\|string\\|dyn\\|Never\\|Allocator\\|Ptr\\|Option\\|Vec\\|Map\\|C?Fn\\)\\_>" + . font-lock-type-face) + ("\\_<\\$[^][ \t\n(){},;\":]*" . font-lock-type-face) + ;; A character literal, `\c' or `\space'. + ("\\\\\\(?:space\\|newline\\|tab\\|return\\|[^ \t\n]\\)" . font-lock-string-face) + ("\\_<-?[0-9][0-9a-fA-FxX_.]*\\_>" . 'font-lock-number-face)) + "Font lock for `flan-fln-mode'.") + +(defvar flan-fln-imenu-generic-expression + `(("Functions" ,(concat "^fn-?[ \t]+" flan-fln--name-re) 1) + ("Macros" ,(concat "^defmacro(" flan-fln--name-re) 1) + ("Types" ,(concat "^\\(?:struct\\|data\\|union\\|enum\\)[ \t]+" flan-fln--name-re) 1) + ("Variables" ,(concat "^\\(?:def\\|once\\|const\\)[ \t]+" flan-fln--name-re) 1)) + "Imenu index for `flan-fln-mode'.") + +(defun flan-fln-current-defun-name () + "The name the top-level form at point declares, or nil." + (let ((s (flan-fln--toplevel-start (point)))) + (when s + (save-excursion + (goto-char s) + (and (looking-at (concat "\\(?:fn-?\\|def\\|once\\|const\\|struct\\|data\\|union\\|enum\\)[ \t]+" + flan-fln--name-re)) + (match-string-no-properties 1)))))) + +;;; The mode + +(defvar flan-fln-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map flan-base-mode-map) + (define-key map (kbd "C-c C-c") #'flan-fln-eval-defun) + (define-key map (kbd "C-M-x") #'flan-fln-eval-defun) + (define-key map (kbd "C-x C-e") #'flan-fln-eval-last) + (define-key map (kbd "C-c C-e") #'flan-fln-eval-statement) + (define-key map (kbd "C-c C-n") #'flan-fln-eval-statement-and-next) + (define-key map (kbd "C-c C-s") #'flan-fln-step-defun) + ;; The sentence keys, because a statement is this syntax's sentence. + ;; M-e shadows a global binding of the same key, as any mode's M-e would. + (define-key map (kbd "M-a") #'flan-fln-backward-statement) + (define-key map (kbd "M-e") #'flan-fln-forward-statement) + (define-key map (kbd "M-k") #'flan-fln-kill-statement) + (define-key map (kbd "C-M-u") #'flan-fln-up) + (define-key map (kbd "M-") #'flan-fln-move-statement-up) + (define-key map (kbd "M-") #'flan-fln-move-statement-down) + (define-key map (kbd "M-") #'flan-fln-slurp) + (define-key map (kbd "M-") #'flan-fln-barf) + (define-key map (kbd "M-r") #'flan-fln-raise-statement) + (define-key map (kbd "C-c <") #'flan-fln-shift-left) + (define-key map (kbd "C-c >") #'flan-fln-shift-right) + (define-key map (kbd "DEL") #'flan-fln-dedent-or-delete) + (define-key map [remap yank] #'flan-fln-yank) + map) + "Keymap for `flan-fln-mode'.") + +;;;###autoload +(define-derived-mode flan-fln-mode flan-base-mode "Fln" + "Major mode for Flan in the indented syntax, a .fln file. + +\\{flan-fln-mode-map}" + :syntax-table flan-fln-mode-syntax-table + (setq-local font-lock-defaults '(flan-fln-font-lock-keywords)) + (setq-local indent-line-function #'flan-fln-indent-line) + (setq-local indent-region-function #'flan-fln-indent-region) + ;; Never re-indent the line RET leaves: its column is its meaning. + (setq-local electric-indent-inhibit t) + (add-hook 'post-self-insert-hook #'flan-fln--electric-clause -50 t) + (setq-local beginning-of-defun-function #'flan-fln--beginning-of-defun) + (setq-local end-of-defun-function #'flan-fln--end-of-defun) + ;; Left nil on purpose: C-M-f and C-M-b stay bracket and term motion, and + ;; everything built on sexps keeps meaning brackets. + (setq-local forward-sexp-function nil) + (setq-local parse-sexp-ignore-comments t) + (setq-local comment-use-syntax t) + (setq-local imenu-generic-expression flan-fln-imenu-generic-expression) + (setq-local er/try-expand-list + '(flan-fln-mark-term flan-fln-mark-group flan-fln-mark-statement + flan-fln-mark-clause flan-fln-mark-toplevel)) + (setq-local evil-shift-width flan-fln-indent-offset) + (add-hook 'which-func-functions #'flan-fln-current-defun-name nil t) + (when (and flan-fln-smartparens (require 'smartparens nil t)) + (smartparens-mode 1)) + (flan-fln--smartparens-keys)) + +(defvar smartparens-mode-map) + +(defun flan-fln--smartparens-keys () + "Keep the top-level and up motions this mode's when smartparens is on. +A minor mode's map is looked up before the major mode's, and a common +smartparens setup puts sexp commands on C-M-a, C-M-e and C-M-u. In a .fln +buffer those keys mean forms and blocks, so smartparens gets a map here +that says so and otherwise is its own." + (when (boundp 'smartparens-mode-map) + (let ((map (make-sparse-keymap))) + (set-keymap-parent map smartparens-mode-map) + (define-key map (kbd "C-M-a") #'beginning-of-defun) + (define-key map (kbd "C-M-e") #'end-of-defun) + (define-key map (kbd "C-M-h") #'mark-defun) + (define-key map (kbd "C-M-u") #'flan-fln-up) + (setq-local minor-mode-overriding-map-alist + (cons (cons 'smartparens-mode map) + (assq-delete-all 'smartparens-mode + (copy-sequence minor-mode-overriding-map-alist))))))) + +(with-eval-after-load 'smartparens + ;; `'x' quotes a name and `'(a b)' a list; neither has a closing quote. + (sp-local-pair 'flan-fln-mode "'" nil :actions nil) + (sp-local-pair 'flan-fln-mode "`" nil :actions nil)) + +;;;###autoload +(add-to-list 'auto-mode-alist '("\\.fln\\'" . flan-fln-mode)) + +;;; Evil + +(defun flan-fln--evil (b type) + ;; A line range is handed over already whole -- from a line's start to the + ;; start of the line after it -- and marked expanded, so Evil neither + ;; stretches it to one more line nor leaves the last newline behind. + (cond ((null b) (error "No object here")) + ((eq type 'line) (evil-range (car b) (cdr b) 'line :expanded t)) + (t (evil-range (car b) (cdr b) type)))) + +(defun flan-fln--whole-lines (b) + "B's lines, from the start of the first to the start of the line after." + (and b (flan-fln--lines (flan-fln--bol (car b)) (flan-fln--bol (cdr b))))) + +(defun flan-fln--empty-line-p (pos) + (save-excursion (goto-char (flan-fln--bol pos)) (looking-at-p "[ \t]*$"))) + +(defun flan-fln--comment-line-p (pos) + (and (flan-fln--blank-p pos) (not (flan-fln--empty-line-p pos)))) + +(defun flan-fln--with-comments (b) + "Whole lines B, and the comments that belong to them. +Above: a comment block at B's own column with no blank line under it. +Below: comment lines deeper than B's column straight after it, which close +its block. A comment at another column belongs to the block it lines up +with." + (and b (save-excursion + (let ((col (flan-fln--indent-at (car b)))) + (goto-char (car b)) + (while (and (zerop (forward-line -1)) + (flan-fln--comment-line-p (point)) + (= (current-indentation) col)) + (setq b (cons (point) (cdr b)))) + (goto-char (cdr b)) + (while (and (not (eobp)) + (flan-fln--comment-line-p (point)) + (> (current-indentation) col)) + (forward-line 1) + (setq b (cons (car b) (point)))) + b)))) + +(defun flan-fln--commented-toplevel (pos) + "The top-level form at POS, whole lines with its comment block. +On a comment block that sits directly on a form, that form." + (let ((pos (save-excursion + (goto-char pos) + (beginning-of-line) + (while (and (flan-fln--comment-line-p (point)) + (zerop (current-indentation)) + (zerop (forward-line 1)))) + (if (flan-fln--toplevel-start-p (point)) (point) pos))) + (orig pos)) + ;; A lone comment -- a blank line away from every form -- belongs to + ;; none, and the form above it is not what was pointed at. + (let ((b (flan-fln--with-comments + (flan-fln--whole-lines (flan-fln--toplevel-bounds pos))))) + (and b + (or (not (flan-fln--comment-line-p orig)) + (and (<= (car b) orig) (< orig (cdr b)))) + b)))) + +(defun flan-fln--with-trailing-blanks (b) + "Whole lines B and the empty lines after them. +When nothing follows -- the last form -- the empty lines before it as well, +as Vim's `dap' does, so the buffer does not end in empty lines. A comment +below a form is not taken: it belongs to what follows." + (and b (save-excursion + (goto-char (cdr b)) + (while (and (not (eobp)) (flan-fln--empty-line-p (point)) + (zerop (forward-line 1)))) + (let ((end (point))) + (if (< end (point-max)) + (cons (car b) end) + (goto-char (car b)) + (while (and (zerop (forward-line -1)) + (flan-fln--empty-line-p (point)))) + (cons (if (flan-fln--empty-line-p (point)) + (point) + (min (car b) (line-beginning-position 2))) + end)))))) + +(defun flan-fln--term-around (b) + "B and the spaces after it, or before it when none follow." + (and b (save-excursion + (goto-char (cdr b)) + (let ((e (progn (skip-chars-forward " \t") (point)))) + (if (> e (cdr b)) + (cons (car b) e) + (goto-char (car b)) + (skip-chars-backward " \t") + (cons (point) (cdr b))))))) + +(with-eval-after-load 'evil + ;; Evaluated here rather than written at top level: the macro is Evil's, and + ;; this file loads and compiles without Evil installed. + (eval + '(progn + (evil-define-text-object flan-fln-inner-term (count &optional _beg _end _type) + "A term." + (flan-fln--evil (flan-fln--term-bounds (point)) 'exclusive)) + (evil-define-text-object flan-fln-a-term (count &optional _beg _end _type) + "A term and the spaces after it." + (flan-fln--evil (flan-fln--term-around (flan-fln--term-bounds (point))) + 'exclusive)) + (evil-define-text-object flan-fln-inner-statement (count &optional _beg _end _type) + "A statement, from its first character to its last." + (flan-fln--evil (bounds-of-thing-at-point 'flan-fln-statement) 'exclusive)) + (evil-define-text-object flan-fln-a-statement (count &optional _beg _end _type) + "A statement's whole lines, with the comment block on it." + (flan-fln--evil (flan-fln--with-comments + (flan-fln--whole-lines + (bounds-of-thing-at-point 'flan-fln-statement))) + 'line)) + (evil-define-text-object flan-fln-inner-body (count &optional _beg _end _type) + "A statement's block, its lines." + (flan-fln--evil (flan-fln--whole-lines + (bounds-of-thing-at-point 'flan-fln-body)) + 'line)) + (evil-define-text-object flan-fln-a-body (count &optional _beg _end _type) + "The whole statement the block belongs to, its lines." + (flan-fln--evil (flan-fln--whole-lines + (bounds-of-thing-at-point 'flan-fln-statement)) + 'line)) + (evil-define-text-object flan-fln-inner-clause (count &optional _beg _end _type) + "A clause's block, its lines; a match arm's value when it is on the line." + (let* ((c (flan-fln--clause-at (point))) + (arm (and c (flan-fln--arm c))) + (v (and arm (plist-get arm :value)))) + (if (and v (= (flan-fln--bol (car v)) c)) + (flan-fln--evil v 'exclusive) + (flan-fln--evil (flan-fln--whole-lines (and c (flan-fln--body-bounds c))) + 'line)))) + (evil-define-text-object flan-fln-a-clause (count &optional _beg _end _type) + "A clause: its line and its block." + (flan-fln--evil (flan-fln--whole-lines + (bounds-of-thing-at-point 'flan-fln-clause)) + 'line)) + (evil-define-text-object flan-fln-inner-toplevel (count &optional _beg _end _type) + "A top-level form, its lines, with the comment block on it." + (flan-fln--evil (flan-fln--commented-toplevel (point)) 'line)) + (evil-define-text-object flan-fln-a-toplevel (count &optional _beg _end _type) + "A top-level form with its comment block, and the empty lines after it." + (flan-fln--evil (flan-fln--with-trailing-blanks + (flan-fln--commented-toplevel (point))) + 'line))) + t) + (evil-define-key* '(operator visual) flan-fln-mode-map + "ie" 'flan-fln-inner-term "ae" 'flan-fln-a-term + "is" 'flan-fln-inner-statement "as" 'flan-fln-a-statement + "ii" 'flan-fln-inner-body "ai" 'flan-fln-a-body + "ik" 'flan-fln-inner-clause "ak" 'flan-fln-a-clause + "id" 'flan-fln-inner-toplevel "ad" 'flan-fln-a-toplevel) + ;; Evil's sentence motions, for the statement ones M-a and M-e are. + (evil-define-key* '(normal motion visual) flan-fln-mode-map + "(" #'flan-fln-backward-statement + ")" #'flan-fln-next-statement) + ;; Normal state's own M- bindings would otherwise win over the mode's. + (evil-define-key* 'normal flan-fln-mode-map + (kbd "M-r") #'flan-fln-raise-statement + (kbd "M-k") #'flan-fln-kill-statement + (kbd "M-") #'flan-fln-move-statement-up + (kbd "M-") #'flan-fln-move-statement-down + (kbd "M-") #'flan-fln-slurp + (kbd "M-") #'flan-fln-barf)) + +(provide 'flan-fln-mode) +;;; flan-fln-mode.el ends here diff --git a/emacs/flan-mode.el b/emacs/flan-mode.el index 3c5b9080..1efff081 100644 --- a/emacs/flan-mode.el +++ b/emacs/flan-mode.el @@ -439,19 +439,16 @@ For `syntax-propertize-function'." ;; not. Either way forward, which is the whole of why this terminates. (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))) ;; 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) ;; 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-x C-e") #'flan-eval-last-sexp) (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-d") #'flan-describe) @@ -502,23 +499,45 @@ For `syntax-propertize-function'." ;; because it is the one that works from any state. (define-key map (kbd "C-c C-M-x") #'flan-rerun) 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'.") +;; 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 -(define-derived-mode flan-mode prog-mode "Flan" +(define-derived-mode flan-mode flan-base-mode "Flan" "Major mode for editing Flan. \\{flan-mode-map}" :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 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 outline-regexp ";;;;+[ \t]*") (setq-local imenu-generic-expression flan-imenu-generic-expression) @@ -800,6 +819,12 @@ decision to `calculate-lisp-indent'." ;;;###autoload (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 diff --git a/emacs/flan-watch.el b/emacs/flan-watch.el index d0701a0a..4eff5e7e 100644 --- a/emacs/flan-watch.el +++ b/emacs/flan-watch.el @@ -249,15 +249,19 @@ inline it has no modeline beside it to say so.") (let (bufs) (dolist (w (window-list-1 nil 'nomini t)) (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))) (push b bufs)))) bufs)) (defun flan-watch--ghost-sites () "Watch call sites in the current buffer, as a list of (NAME . END-OF-LINE)." - (let ((re (concat "(\\s-*" flan-watch-ghost-call-regexp - "\\s-+\"\\([^\"\n]*\\)\"")) + ;; Either syntax: `(watch "name" v)' in a .flan file, `watch("name", v)' in + ;; 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)) (save-excursion (goto-char (point-min)) diff --git a/emacs/flan.el b/emacs/flan.el index ad175078..6f5f576e 100644 --- a/emacs/flan.el +++ b/emacs/flan.el @@ -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, ;; never which file the unasked case picks. (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)))) (list (if (and file (not current-prefix-arg)) file @@ -1176,7 +1176,7 @@ the state with something to answer in it." (defun flan-mode-line () "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) ;; First, and it names the condition: a stopped program looks exactly ;; 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 () "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." - (when (derived-mode-p 'flan-mode) + (when (derived-mode-p 'flan-base-mode) ;; Removed first in both branches, because adding is not idempotent: a ;; second install would put the rule in twice and every refresh after that ;; 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 ;; 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 () "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 (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 ;; autoloaded on first use, so by the time it arrives the file being edited has ;; long since had its mode hooks run. (dolist (b (buffer-list)) (with-current-buffer b - (when (derived-mode-p 'flan-mode) (flan-setup)))) + (when (derived-mode-p 'flan-base-mode) (flan-setup)))) ;;; 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 daemon cannot tell from `:file' — an expansion shown in parens is sent back 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" "paren")) diff --git a/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index 16f65fc8..c158bdbb 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -2034,6 +2034,11 @@ stopped program, which is the case where it should fire." (file-name-directory load-file-name)) 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 ;; buffer it reads is a fixture like any other reply here. Loaded for the same ;; reason. diff --git a/emacs/test-flan-fln-live.el b/emacs/test-flan-fln-live.el new file mode 100644 index 00000000..078ded7c --- /dev/null +++ b/emacs/test-flan-fln-live.el @@ -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 "")) + :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 diff --git a/emacs/test-flan-fln.el b/emacs/test-flan-fln.el new file mode 100644 index 00000000..cd114184 --- /dev/null +++ b/emacs/test-flan-fln.el @@ -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 diff --git a/emacs/test-flan.el b/emacs/test-flan.el index 952cb01f..7712e455 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -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 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) (message "flan.el: all tests passed") (message "\n%d failure(s)" test-flan--failures) diff --git a/lib/dev.ml b/lib/dev.ml index 7bf0c4a1..8c0b8967 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -4568,7 +4568,8 @@ let rec handle t req = | Some l, None -> Some (l, 1) | _ -> None 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 = match Wire.string_field req "op" with diff --git a/lib/indent_reader.ml b/lib/indent_reader.ml index aefc217b..2f8ad73f 100644 --- a/lib/indent_reader.ml +++ b/lib/indent_reader.ml @@ -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 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"). *) -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 n = Array.length arr in (* 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 add tok loc = out := { tok; loc; sp = true } :: !out 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 binop t = match t.tok with NAME s -> is_binop s | _ -> false in 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 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. 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 of, silently. *) - if continues && t.loc.Loc.col <= List.hd !stack then + if continues && t.loc.Loc.col <= top then failk "continuation" t.loc "%s" (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 (column %d). Indent it further to continue the line, \ 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 Printf.sprintf "the line above ends with the operator %s, so this line \ continues it, but it is not indented past the start of \ that line (column %d). Indent it further, or finish the \ line above" - (show p.tok) (List.hd !stack)); + (show p.tok) top); if not continues then begin + first_line := false; let at = point p.loc in add NEWLINE at; 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 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 col = Option.value col ~default:1 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' (String.make (line - 1) '\n' ^ String.make (col - 1) ' ' ^ src))); 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 fs = stmts s in (match (peek s.p).tok with diff --git a/lib/source.ml b/lib/source.ml index 102da4fd..d6429e19 100644 --- a/lib/source.ml +++ b/lib/source.ml @@ -33,15 +33,21 @@ type syntax = Paren | Indented let code_syntax = ref Paren 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 | Some ("indented" | "fln") -> Indented | _ -> Paren -let with_code ~syntax ~at f = - let s = !code_syntax and a = !code_at in +let with_code ?indent ~syntax ~at f = + let s = !code_syntax and a = !code_at and i = !code_indent in code_syntax := syntax; 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 starts at 1:1. *) @@ -65,7 +71,7 @@ let read_code ?(expr = false) ~file code = match !code_syntax with | Paren -> read_paren ~line ~col ~file code | Indented -> - (match Indent_reader.read_all ~line ~col ~file code with + (match Indent_reader.read_all ~line ~col ?indent:!code_indent ~file code with | (first :: _ :: _ as forms) when expr -> let last = List.nth forms (List.length forms - 1) in let loc = diff --git a/spec-syntax.md b/spec-syntax.md index 2d075b65..1da02171 100644 --- a/spec-syntax.md +++ b/spec-syntax.md @@ -365,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 location the reader gave that form. `Ast.mark_pause` matches exactly (`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 stale-caller cause. This is independent of steps 1-5 once the marker exists. diff --git a/test/test_syntax.ml b/test/test_syntax.ml index e1a17e11..6b83e947 100644 --- a/test/test_syntax.ml +++ b/test/test_syntax.ml @@ -495,6 +495,22 @@ let () = | [ _; _ ] -> () | _ -> fail "a snippet with leading spaces" | 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:"" "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:"" "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:"" "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 () -> match Source.read_code ~file:"" "(f 1)" with | [ f ] -> span_is "a paren snippet" f (7, 3, 7, 8)