2137 lines
95 KiB
EmacsLisp
2137 lines
95 KiB
EmacsLisp
;;; flan-fln-mode.el --- Major mode for indented Flan (.fln) -*- lexical-binding: t; -*-
|
|
|
|
;; Author: Joseph Ferano <joseph@ferano.io>
|
|
;; 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. A `=>' ending a line inside brackets opens a
|
|
;; lambda's block there, whose lines are statements again.
|
|
;; 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.")
|
|
|
|
;; What follows a word that starts a clause or a header: a space and not an
|
|
;; assignment, or the end of the line. `on = 2' assigns a variable named on,
|
|
;; as `assigns' in lib/indent_reader.ml reads it.
|
|
(defconst flan-fln--word-end-re
|
|
"\\(?:[ \t]+\\(?:[^-+*/= \t\n]\\|[-+*/]\\(?:[^=]\\|$\\)\\)\\|[ \t]*$\\)")
|
|
|
|
(defconst flan-fln--clause-re
|
|
(concat "\\(else\\|elif\\|on\\|restart\\)" flan-fln--word-end-re))
|
|
|
|
(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" "macro" "type" "class" "generic" "multi" "method"))
|
|
|
|
;; The headers whose block follows on the lines under them. `defer' and
|
|
;; `quote' open one only when nothing follows them on the line; `fn' does not
|
|
;; 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" "macro" "class" "multi" "method"))
|
|
|
|
(defconst flan-fln--declaration-words
|
|
'(("fn" . "defn") ("fn-" . "defn-") ("def" . "def") ("once" . "defonce")
|
|
("const" . "defconst") ("struct" . "defstruct") ("data" . "defdata")
|
|
("enum" . "defenum") ("union" . "defunion") ("import" . "import")
|
|
("let" . "def") ("macro" . "defmacro") ("type" . "defalias") ("class" . "defclass")
|
|
("generic" . "defgeneric") ("multi" . "defmulti") ("method" . "defmethod"))
|
|
"Each declaration header word, and the paren head it reads as.")
|
|
|
|
;;; Syntax
|
|
|
|
(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--closer-line-p (pos)
|
|
"Non-nil if POS's line starts inside a bracket with the bracket's closer."
|
|
(save-excursion
|
|
(let ((s (syntax-ppss (flan-fln--bol pos))))
|
|
(and (nth 1 s) (not (nth 3 s))
|
|
(progn (goto-char (flan-fln--bol pos))
|
|
(skip-chars-forward " \t")
|
|
(looking-at "\\s)"))))))
|
|
|
|
(defun flan-fln--lambda-arrow (pos)
|
|
"The `=>' whose block POS's line is in, when that block is inside brackets.
|
|
A `=>' ending a line inside a bracket opens a block there, which lasts until
|
|
the bracket closes (lib/indent_reader.ml's `layout'): a line inside the same
|
|
bracket after it is a statement of that block, not a continuation. A line
|
|
that starts with the bracket's closer is not in the block.
|
|
Each call scans the lines from the open bracket to POS, so walking a long
|
|
bracketed literal line by line costs the square of its length."
|
|
(save-excursion
|
|
(let* ((bol (flan-fln--bol pos))
|
|
(s (syntax-ppss bol))
|
|
(open (nth 1 s)))
|
|
(when (and open (not (nth 3 s)) (not (flan-fln--closer-line-p bol)))
|
|
(goto-char open)
|
|
(let (hit)
|
|
(while (and (not hit) (< (line-end-position) bol))
|
|
(let ((end (flan-fln--code-end (point))))
|
|
(goto-char end)
|
|
(when (and (looking-back "[ \t]=>" (line-beginning-position))
|
|
(= (nth 1 (save-excursion (syntax-ppss (- end 2)))) open))
|
|
(setq hit (- end 2))))
|
|
(forward-line 1))
|
|
hit)))))
|
|
|
|
(defun flan-fln--bracketed-p (pos)
|
|
"Non-nil if POS's line is inside a bracket or a string, where a line break
|
|
is only a space: not in a lambda's block."
|
|
(and (flan-fln--in-open-p pos) (not (flan-fln--lambda-arrow pos))))
|
|
|
|
(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.
|
|
Not a line of a lambda's block inside brackets, which is a statement."
|
|
(or (flan-fln--bracketed-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--continues-p (pos start)
|
|
"Non-nil if POS's line continues the statement that starts at START.
|
|
A line that starts with the closer of a bracket opened before START closes
|
|
something START is inside, a lambda's block's call, and is not START's."
|
|
(and (flan-fln--continuation-p pos)
|
|
(not (and (flan-fln--closer-line-p pos)
|
|
(< (nth 1 (save-excursion (syntax-ppss (flan-fln--bol pos))))
|
|
(flan-fln--bol start))))))
|
|
|
|
(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 (cond
|
|
;; A closer's line belongs with the line its bracket opens on,
|
|
;; not with a lambda's block just above it.
|
|
((flan-fln--closer-line-p bol)
|
|
(setq bol (flan-fln--bol (nth 1 (save-excursion (syntax-ppss bol))))))
|
|
((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)) (start bol) n)
|
|
(while (and (setq n (flan-fln--next-code bol))
|
|
(flan-fln--continues-p n start))
|
|
(setq bol n))
|
|
bol))
|
|
|
|
;;; Words at a line's own depth
|
|
|
|
(defun flan-fln--find-top (re beg end)
|
|
"(BEG . END) of the first match of RE between BEG and END at BEG's bracket
|
|
depth, outside strings and comments, or nil."
|
|
(save-excursion
|
|
(goto-char beg)
|
|
(let ((depth (car (syntax-ppss beg))) hit)
|
|
(while (and (not hit) (re-search-forward re end t))
|
|
(let ((m (cons (match-beginning 0) (match-end 0))))
|
|
(let ((s (save-excursion (syntax-ppss (car m)))))
|
|
(if (and (= (car s) depth) (not (nth 8 s)))
|
|
(setq hit m)
|
|
(goto-char (cdr m))))))
|
|
hit)))
|
|
|
|
(defun flan-fln--joined-end (l)
|
|
"Where the code of the joined line starting at L ends."
|
|
(flan-fln--code-end (flan-fln--logical-end l)))
|
|
|
|
(defun flan-fln--then (l)
|
|
"Where the condition of the one-line if or elif at L ends, before its
|
|
`then', or nil when the line has no `then' of its own."
|
|
(let ((m (flan-fln--find-top "[ \t]+then[ \t]" (flan-fln--first-char l)
|
|
(flan-fln--joined-end l))))
|
|
(and m (car m))))
|
|
|
|
(defun flan-fln--value-end (l)
|
|
"Where a value written on the joined line L ends: at the line's code end,
|
|
or, when the line ends in `=>', at the end of the lambda's block under it."
|
|
(let ((last (flan-fln--logical-end l)))
|
|
(if (flan-fln--ends-in-arrow-p last)
|
|
(cdr (flan-fln--span l (flan-fln--statement-last l t)))
|
|
(flan-fln--code-end last))))
|
|
|
|
(defun flan-fln--clause-value (l)
|
|
"Bounds of the value on the clause line L itself: `x' of `else x' or of
|
|
`elif c then x'; nil when the clause's value is its block."
|
|
(let ((end (flan-fln--value-end l))
|
|
(then (flan-fln--then l)))
|
|
(save-excursion
|
|
(goto-char (flan-fln--first-char l))
|
|
(cond
|
|
((and (looking-at "elif[ \t]") then)
|
|
(goto-char then)
|
|
(skip-chars-forward " \t")
|
|
(forward-char 4)
|
|
(skip-chars-forward " \t")
|
|
(and (< (point) end) (cons (point) end)))
|
|
((and (looking-at "else[ \t]+") (< (match-end 0) end))
|
|
(cons (match-end 0) end))))))
|
|
|
|
(defun flan-fln--value-start (l)
|
|
"Where the value of the joined line L starts, after its first `=' or
|
|
`+=' at the line's own depth, or nil when it binds or assigns nothing."
|
|
(let ((m (flan-fln--find-top "[ \t][-+*/]?=[ \t]+" (flan-fln--first-char l)
|
|
(flan-fln--joined-end l))))
|
|
(and m (cdr m))))
|
|
|
|
(defun flan-fln--ends-in-arrow-p (pos)
|
|
"Non-nil if POS's line ends in `=>': a lambda's header, its block under it."
|
|
(save-excursion
|
|
(let ((end (flan-fln--code-end pos)))
|
|
(goto-char end)
|
|
(and (not (nth 8 (syntax-ppss end)))
|
|
(looking-back "[ \t]=>" (line-beginning-position))))))
|
|
|
|
(defun flan-fln--lambda-header-p (pos end)
|
|
"Non-nil if a lambda with its body under it starts at POS and runs to END:
|
|
`fn(a, b) =>', or `fn(a: C, b) -> R =>', with nothing after the `=>'."
|
|
(save-excursion
|
|
(goto-char pos)
|
|
(and (looking-at "fn(")
|
|
(let ((close (ignore-errors (scan-lists (+ pos 2) 1 0))))
|
|
(and close (<= close end)
|
|
(progn (goto-char end) (looking-back "[ \t]=>" close)))))))
|
|
|
|
(defun flan-fln--value-opens-p (l)
|
|
"Non-nil if the value the joined line L binds or assigns goes on under it:
|
|
`= match x', `= if c' with no `then', `= handler-case', `= restart-case',
|
|
or a lambda header. These are the values
|
|
lib/indent_reader.ml's `value_line' reads a block for, besides a bare `='
|
|
and a call ending in `:'."
|
|
(let ((v (flan-fln--value-start l))
|
|
(end (flan-fln--joined-end l)))
|
|
(and v (< v end)
|
|
(save-excursion
|
|
(goto-char v)
|
|
(or (looking-at "\\(?:match\\|handler-case\\|handler-bind\\|restart-case\\)\\(?:[ \t]\\|$\\)")
|
|
(and (looking-at "if[ \t]") (not (flan-fln--then l)))
|
|
(flan-fln--lambda-header-p v end))))))
|
|
|
|
;;; 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
|
|
(not (and (flan-fln--closer-line-p next)
|
|
(not (flan-fln--continues-p next start))))
|
|
(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--trim-closers (beg end)
|
|
"END, less the closers before it whose brackets open before BEG.
|
|
The last statement of a lambda's block inside a call ends with the call's `)'
|
|
on its line, which is not the statement's."
|
|
(save-excursion
|
|
(goto-char end)
|
|
(let (done)
|
|
(while (not done)
|
|
(skip-chars-backward " \t" beg)
|
|
(let ((open (and (> (point) beg) (memq (char-before) '(?\) ?\] ?\}))
|
|
(nth 1 (save-excursion (syntax-ppss (1- (point))))))))
|
|
(if (and open (< open beg))
|
|
(backward-char 1)
|
|
(setq done t))))
|
|
(point))))
|
|
|
|
(defun flan-fln--span (start last)
|
|
"(BEG . END) from the text of START's line to the code end of LAST's."
|
|
(let ((beg (flan-fln--first-char start)))
|
|
(cons beg (flan-fln--trim-closers beg (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--let-line-p (l)
|
|
"Non-nil if the line L starts with `let', at any column."
|
|
(save-excursion (goto-char (flan-fln--first-char l)) (looking-at "let[ \t]")))
|
|
|
|
(defun flan-fln--binding-column (l)
|
|
"The column of the first name on the `let' line L: where the let's other
|
|
bindings line up. Nil when a tab sits before the name: a tab has no one
|
|
width, and the reader refuses it there."
|
|
(save-excursion
|
|
(goto-char (flan-fln--first-char l))
|
|
(skip-chars-forward "let")
|
|
(let ((from (point)))
|
|
(skip-chars-forward " \t")
|
|
(unless (save-excursion (search-backward "\t" from t))
|
|
(current-column)))))
|
|
|
|
(defun flan-fln--binding-shape-p (l &optional global)
|
|
"Non-nil if the joined line L reads as a binding: a name, `~x', a
|
|
`[...]' or `{...}' pattern or `(not)', then ` = ' or `: T = '. With
|
|
GLOBAL, a top-level let's line, `: T' alone too."
|
|
(save-excursion
|
|
(goto-char (flan-fln--first-char l))
|
|
(let ((end (flan-fln--joined-end l)))
|
|
(cond
|
|
((looking-at "[[{(]")
|
|
(let ((c (ignore-errors (scan-lists (point) 1 0))))
|
|
(and c (<= c end)
|
|
(progn (goto-char c) (looking-at "[ \t]+=\\(?:[ \t]\\|$\\)")))))
|
|
((looking-at "~?[^][ \t\n(){},;\":.~][^][ \t\n(){},;\":.]*\\(?:\\([ \t]+=\\(?:[ \t]\\|$\\)\\)\\|:[ \t]\\)")
|
|
(or (match-beginning 1) global
|
|
(flan-fln--find-top "[ \t]=\\(?:[ \t]\\|$\\)" (match-end 0) end)))))))
|
|
|
|
(defun flan-fln--binding-let (l)
|
|
"The `let' line whose binding the joined line L is, or nil.
|
|
Lines indented under a let whose value ends on its line are more bindings
|
|
of it (lib/indent_reader.ml's `binding_lines'), lined up with its first
|
|
name."
|
|
(and (not (flan-fln--continuation-p l))
|
|
(let ((p (flan-fln--parent l)))
|
|
(and p (flan-fln--let-line-p p)
|
|
(flan-fln--binding-shape-p l (zerop (flan-fln--indent-at p)))
|
|
(not (flan-fln--opener-p p (flan-fln--logical-end p)))
|
|
p))))
|
|
|
|
(defun flan-fln--line-statement (pos)
|
|
"The first line of the statement POS's line starts or continues.
|
|
A clause line answers for itself; a let's binding line gives the let."
|
|
(let ((l (flan-fln--code-line-at pos)))
|
|
(and l (let ((s (flan-fln--logical-start l)))
|
|
(or (flan-fln--binding-let s) s)))))
|
|
|
|
(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', `let', `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 "<buffer>"))
|
|
(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))
|
|
;; Not the brackets a lambda's block is in: a line of the block is a
|
|
;; statement of its own.
|
|
((and g (cdr g) (> (car g) (car b))
|
|
(not (let ((a (flan-fln--lambda-arrow pos)))
|
|
(and a (< (car g) a) (< a pos)))))
|
|
(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))
|
|
;; A let's binding line starts no form; its value is what runs there.
|
|
((let ((raw (flan-fln--logical-start (flan-fln--code-line-at pos))))
|
|
(and (flan-fln--binding-let raw) (flan-fln--binding-value raw))))
|
|
(t (let ((s (flan-fln--statement-start-at pos)))
|
|
(and s (or (flan-fln--merged-let-value s)
|
|
(flan-fln--statement-bounds s))))))))
|
|
|
|
(defun flan-fln--merged-let-value (s)
|
|
"Bounds of the value of the `let' at S when the let before it takes it in.
|
|
The reader merges consecutive lets into one binding vector, so a second
|
|
`let b = 2' starts no form of its own; its value, or its value's block, is
|
|
the form that runs where the line stands."
|
|
(let ((p (and (flan-fln--let-p s) (flan-fln--sibling s -1))))
|
|
(when (and p (flan-fln--let-p p))
|
|
(flan-fln--binding-value s))))
|
|
|
|
(defun flan-fln--binding-value (s)
|
|
"Bounds of the value the binding line S binds: after its `=' on the line,
|
|
or the block under it."
|
|
(let ((v (flan-fln--value-start s))
|
|
(end (flan-fln--joined-end s)))
|
|
(cond ((not (and v (< v end))) (flan-fln--body-bounds s))
|
|
;; `= match x', a lambda header: the value takes the lines under it.
|
|
((flan-fln--opener-p s (flan-fln--logical-end s))
|
|
(cons v (cdr (flan-fln--statement-bounds s))))
|
|
;; Otherwise the lines under a let are its other bindings.
|
|
(t (cons v end)))))
|
|
|
|
(defun flan-fln--clause-target (l)
|
|
"What a clause line L stops at: an elif's condition, else its block.
|
|
A one-line `else x' stops at x."
|
|
(save-excursion
|
|
(goto-char (flan-fln--first-char l))
|
|
(let ((end (flan-fln--joined-end l)))
|
|
(cond
|
|
((looking-at "elif[ \t]+")
|
|
(cons (match-end 0) (or (flan-fln--then l) end)))
|
|
((flan-fln--clause-value l))
|
|
(t (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))
|
|
;; A one-line if's `then' ends no condition worth sending alone: the
|
|
;; line's last word is the value, and the if goes on to its clauses.
|
|
(when (and (not (flan-fln--then l))
|
|
(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 (flan-fln--value-end l))
|
|
(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)))
|
|
;; Nor, in a pattern, a dotted name: `Dir.north' is a value to
|
|
;; compare with, and only a bare name or `.x' binds.
|
|
(unless (and skip-heads (or (eq (char-after) ?\()
|
|
(string-match-p "\\`[^.]+\\." n)))
|
|
(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--let-p (start)
|
|
"Non-nil if START's statement is a local `let'.
|
|
A let takes no block: lines under it are its value's (`= match x', a lambda
|
|
header) or more bindings of it, and its names last to the end of the block
|
|
it is in."
|
|
(and (> (flan-fln--indent-at start) 0)
|
|
(save-excursion (goto-char (flan-fln--first-char start))
|
|
(looking-at "let[ \t]"))))
|
|
|
|
(defun flan-fln--block-rest (start)
|
|
"START's statement and every statement after it in the same block."
|
|
(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 `let', 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--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 `let', 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)
|
|
flan-fln--word-end-re))
|
|
(let* ((w (match-string-no-properties 1))
|
|
(w-end (match-end 1))
|
|
(end (flan-fln--code-end last))
|
|
(alone (>= w-end end)))
|
|
(cond
|
|
;; `else x' after an if's block is the whole else.
|
|
((member w '("defer" "quote" "else")) alone)
|
|
((member w '("fn" "fn-" "multi" "method"))
|
|
(not (re-search-forward "[ \t]=[ \t]" end t)))
|
|
;; `struct Pt(x: i32)' has its fields on the line.
|
|
((member w '("struct" "union" "class"))
|
|
(not (save-excursion
|
|
(goto-char w-end)
|
|
(looking-at "[ \t]+[^][ \t\n(){},;\":]+("))))
|
|
((member w '("if" "elif")) (not (flan-fln--then start)))
|
|
(t t)))))
|
|
;; `let r = match n', `x = if c', `fn f(x) = match x', a lambda
|
|
;; header: the value goes on under the line.
|
|
(flan-fln--value-opens-p start)
|
|
;; A lambda header as a statement of its own.
|
|
(flan-fln--lambda-header-p (flan-fln--first-char start)
|
|
(flan-fln--code-end last))
|
|
(save-excursion
|
|
(goto-char (flan-fln--code-end last))
|
|
(let ((bol (line-beginning-position)))
|
|
(or (looking-back ":" bol)
|
|
(looking-back "[ \t]->" bol)
|
|
;; A lambda's header, at the top of a line or inside brackets.
|
|
(looking-back "[ \t]=>" bol)
|
|
;; `let x =' and `let colors =' at the top level with the value as a block,
|
|
;; which the author's list leaves out and the reader reads.
|
|
(looking-back "[ \t]=" bol))))))
|
|
|
|
(defun flan-fln--outside-block (p pos)
|
|
"P, or when P's line is in a lambda's block inside brackets that POS is not
|
|
inside, the first line of the statement that block's `=>' is in: a block
|
|
whose brackets have closed is no block POS can join."
|
|
(let ((a (flan-fln--lambda-arrow p)))
|
|
(if (and a (not (memq (nth 1 (save-excursion (syntax-ppss (flan-fln--bol p))))
|
|
(nth 9 (save-excursion (syntax-ppss (flan-fln--bol pos)))))))
|
|
(flan-fln--outside-block (flan-fln--logical-start a) pos)
|
|
p)))
|
|
|
|
(defun flan-fln--stack (pos)
|
|
"The open block columns above POS's line, deepest first, as (COL . LINE)."
|
|
(let ((p (flan-fln--prev-code pos)) out (min most-positive-fixnum))
|
|
(while p
|
|
(setq p (flan-fln--outside-block (flan-fln--logical-start p) pos))
|
|
(let ((i (flan-fln--indent-at p)))
|
|
(when (< i min) (push (cons i p) out) (setq min i)))
|
|
(setq p (and (> 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))))
|
|
(cond
|
|
;; A lambda's block goes under the line its `=>' ends, which may be a
|
|
;; line of a call wrapped inside its brackets.
|
|
((and prev (flan-fln--ends-in-arrow-p prev))
|
|
(cons (+ (flan-fln--indent-at prev) flan-fln-indent-offset) stack))
|
|
((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))
|
|
;; After a let's line, its next binding's column too, lined up with
|
|
;; its first name -- second, so RET after a let stays at its column.
|
|
;; After a binding line, that column is on the stack, first.
|
|
((and prev (flan-fln--let-line-p (flan-fln--logical-start prev)))
|
|
(let ((b (flan-fln--binding-column (flan-fln--logical-start prev))))
|
|
(if (or (null b) (memq b stack)) stack
|
|
(cons (car stack) (cons b (cdr stack))))))
|
|
(t stack))))
|
|
|
|
(defun flan-fln--block-levels (pos)
|
|
"Columns TAB offers POS's line at a block's level, deepest first.
|
|
In a lambda's block inside brackets, only those right of the line its `=>'
|
|
ends: a line at or left of it would be outside the block, still inside the
|
|
brackets, which the reader refuses."
|
|
(let ((arrow (flan-fln--lambda-arrow pos)))
|
|
(if (not arrow)
|
|
(flan-fln--levels pos)
|
|
(let ((base (flan-fln--indent-at arrow)))
|
|
(or (seq-filter (lambda (c) (> c base)) (flan-fln--levels pos))
|
|
(list (+ base flan-fln-indent-offset)))))))
|
|
|
|
(defun flan-fln--clause-columns (word pos)
|
|
"Columns of the lines above POS a clause WORD may sit under, deepest first."
|
|
(let ((re (concat (regexp-opt (cdr (assoc word flan-fln--clause-headers)))
|
|
"\\(?:[ \t]\\|$\\)")))
|
|
(delq nil
|
|
(mapcar (lambda (e)
|
|
(let ((l (cdr e)))
|
|
(and l
|
|
(save-excursion
|
|
(goto-char (flan-fln--first-char l))
|
|
(or (looking-at re)
|
|
;; `let s = if c' and `r = match x' take
|
|
;; their clauses at the line's column.
|
|
(and (flan-fln--value-opens-p l)
|
|
(progn (goto-char (flan-fln--value-start l))
|
|
(looking-at re)))))
|
|
(car e))))
|
|
(flan-fln--stack pos)))))
|
|
|
|
(defun flan-fln--holds-block-p (open pos)
|
|
"Non-nil if a line between OPEN and POS's line ends in a `=>' directly
|
|
inside the bracket at OPEN: a lambda's block the bracket holds."
|
|
(save-excursion
|
|
(let ((bol (flan-fln--bol pos)) hit)
|
|
(goto-char open)
|
|
(while (and (not hit) (< (line-end-position) bol))
|
|
(let ((end (flan-fln--code-end (point))))
|
|
(goto-char end)
|
|
(when (and (looking-back "[ \t]=>" (line-beginning-position))
|
|
(eql (nth 1 (save-excursion (syntax-ppss (- end 2)))) open))
|
|
(setq hit t)))
|
|
(forward-line 1))
|
|
hit)))
|
|
|
|
(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 there too, so
|
|
RET before the `)' of `and(a|)' leaves room to type the next argument where
|
|
it belongs. The one exception is the closer of a bracket that holds a
|
|
lambda's block: it ends that block, and goes to the opening line's column."
|
|
(save-excursion
|
|
(let ((closing (and (save-excursion (back-to-indentation) (looking-at "\\s)"))
|
|
(flan-fln--holds-block-p open (point)))))
|
|
(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)
|
|
((and (> (car s) 0) (not (flan-fln--lambda-arrow (point))))
|
|
(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--block-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--block-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--bracketed-p (point))))
|
|
(let ((cur (current-indentation)))
|
|
(indent-line-to (or (seq-find (lambda (c) (< c cur))
|
|
(flan-fln--block-levels (point)))
|
|
;; A lambda's block inside brackets has no
|
|
;; level left of its own.
|
|
(if (flan-fln--lambda-arrow (point)) cur 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--bracketed-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'.")
|
|
|
|
;; A defining form written as the fallback call, `defmacro(m, [x]):' or
|
|
;; `defmethod(area, point, [p]):'. The heads are `flan-mode''s own, so a
|
|
;; head it learns is drawn here too; its name is drawn as the sugar draws the
|
|
;; same kind of name.
|
|
(defconst flan-fln--fallback-type-heads
|
|
(seq-filter (lambda (h) (member h '("defstruct" "defdata" "defunion" "defenum"
|
|
"defalias" "defclass")))
|
|
flan--definers))
|
|
|
|
(defconst flan-fln--fallback-variable-heads
|
|
(seq-filter (lambda (h) (member h '("def" "defonce" "defconst"))) flan--definers))
|
|
|
|
(defconst flan-fln--fallback-function-heads
|
|
(seq-remove (lambda (h) (or (member h flan-fln--fallback-type-heads)
|
|
(member h flan-fln--fallback-variable-heads)
|
|
(member h '("defmacro" "import" "package"
|
|
"declare" "declare-c"))))
|
|
flan--definers)
|
|
"The fallback heads that define something called, for imenu.")
|
|
|
|
(defun flan-fln--fallback-re (heads)
|
|
(concat "^" (regexp-opt heads t) "(" flan-fln--name-re))
|
|
|
|
(defun flan-fln--return-type-matcher (limit)
|
|
"Find the next return type up to LIMIT: after the `->' of a fn header, a
|
|
lambda or a `Fn(...)' type, and not after a match arm's."
|
|
(let (found)
|
|
(while (and (not found)
|
|
(re-search-forward "[ \t]->[ \t]+\\([$a-zA-Z][^][ \t\n(){},;\"=]*\\)"
|
|
limit t))
|
|
(let ((arrow (match-beginning 0)))
|
|
(setq found (save-excursion
|
|
(save-match-data
|
|
(goto-char (line-beginning-position))
|
|
(or (re-search-forward "\\(?:^[ \t]*fn-?[ \t]\\|\\_<C?[fF]n(\\)"
|
|
arrow t)
|
|
;; A header wrapped inside its parentheses: the
|
|
;; `)' before the arrow closes a `fn f(' above.
|
|
(progn
|
|
(goto-char arrow)
|
|
(skip-chars-backward " \t")
|
|
(and (eq (char-before) ?\))
|
|
(let ((open (ignore-errors (scan-lists (point) -1 0))))
|
|
(and open
|
|
(progn
|
|
(goto-char open)
|
|
(looking-back "\\(?:^[ \t]*fn-?[ \t]+[^][ \t\n(){},;\":]+\\|\\_<C?[fF]n\\)"
|
|
(line-beginning-position)))))))))))))
|
|
found))
|
|
|
|
(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) flan-fln--word-end-re)
|
|
1 font-lock-keyword-face)
|
|
(,(concat "^\\(fn-?\\|macro\\|generic\\|multi\\|method\\)[ \t]+" flan-fln--name-re)
|
|
2 font-lock-function-name-face)
|
|
(,(concat "^\\(?:struct\\|data\\|union\\|enum\\|type\\|class\\)[ \t]+" flan-fln--name-re)
|
|
1 font-lock-type-face)
|
|
;; A method's class, `method area(p: point)', and a value after `when'.
|
|
(,(concat "^method[ \t]+[^][ \t\n(){},;\":]+([^][ \t\n(){},;\":]+:[ \t]*" flan-fln--name-re)
|
|
1 font-lock-type-face)
|
|
("^method[ \t].*)[ \t]+\\(when\\)[ \t]" 1 font-lock-keyword-face)
|
|
;; An alias's type, `type Row = Vec(i32)'.
|
|
(,(concat "^type[ \t]+[^][ \t\n(){},;\":]+[ \t]+=[ \t]+" flan-fln--name-re)
|
|
1 font-lock-type-face)
|
|
;; A defining form as the fallback call: the head a keyword, its first
|
|
;; argument the name it defines.
|
|
(,(flan-fln--fallback-re flan-fln--fallback-type-heads)
|
|
(1 font-lock-keyword-face) (2 font-lock-type-face))
|
|
(,(flan-fln--fallback-re flan-fln--fallback-variable-heads)
|
|
(1 font-lock-keyword-face) (2 font-lock-variable-name-face))
|
|
(,(flan-fln--fallback-re
|
|
(seq-remove (lambda (h) (or (member h flan-fln--fallback-type-heads)
|
|
(member h flan-fln--fallback-variable-heads)))
|
|
flan--definers))
|
|
(1 font-lock-keyword-face) (2 font-lock-function-name-face))
|
|
;; A condition's parent, `struct DiskFull :parent IoError'.
|
|
(,(concat "^struct[ \t]+[^][ \t\n(){},;\":]+\\(?:([^)\n]*)\\)?[ \t]+:parent[ \t]+"
|
|
flan-fln--name-re)
|
|
1 font-lock-type-face)
|
|
;; A global: a let at column 0 is one.
|
|
(,(concat "^\\(?:let\\|once\\|const\\)[ \t]+" flan-fln--name-re)
|
|
1 font-lock-variable-name-face)
|
|
;; A restart clause's name, `restart retry() "Try again"'.
|
|
(,(concat "^[ \t]*restart[ \t]+" flan-fln--name-re)
|
|
1 font-lock-function-name-face)
|
|
;; A lambda's `fn', glued to its parameters.
|
|
("\\(?:^\\|[ \t=(,]\\)\\(fn\\)(" 1 font-lock-keyword-face)
|
|
;; And the `=>' its body follows.
|
|
("[ \t]\\(=>\\)\\(?:[ \t]\\|$\\)" 1 font-lock-keyword-face)
|
|
;; An enum member written `Dir.north', a constant as `:north' is.
|
|
("\\_<[A-Z][^][ \t\n(){},;\":.]*\\.[^][ \t\n(){},;\":.]+\\_>"
|
|
. font-lock-constant-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)
|
|
(flan-fln--return-type-matcher 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\\|str\\|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-?\\|generic\\|multi\\|method\\)[ \t]+" flan-fln--name-re) 1)
|
|
("Functions" ,(flan-fln--fallback-re flan-fln--fallback-function-heads) 2)
|
|
("Macros" ,(concat "^\\(?:macro[ \t]+\\|defmacro(\\)" flan-fln--name-re) 1)
|
|
("Types" ,(concat "^\\(?:struct\\|data\\|union\\|enum\\|type\\|class\\)[ \t]+" flan-fln--name-re) 1)
|
|
("Types" ,(flan-fln--fallback-re flan-fln--fallback-type-heads) 2)
|
|
("Variables" ,(concat "^\\(?:let\\|once\\|const\\)[ \t]+" flan-fln--name-re) 1)
|
|
("Variables" ,(flan-fln--fallback-re flan-fln--fallback-variable-heads) 2))
|
|
"Imenu index for `flan-fln-mode'.")
|
|
|
|
(defun flan-fln-current-defun-name ()
|
|
"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-?\\|macro\\|generic\\|multi\\|method\\|class\\|let\\|once\\|const\\|struct\\|data\\|union\\|enum\\|type\\)[ \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-<up>") #'flan-fln-move-statement-up)
|
|
(define-key map (kbd "M-<down>") #'flan-fln-move-statement-down)
|
|
(define-key map (kbd "M-<right>") #'flan-fln-slurp)
|
|
(define-key map (kbd "M-<left>") #'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; the value on the line of a match arm, a
|
|
one-line else or an elif's `then'."
|
|
(let* ((c (flan-fln--clause-at (point)))
|
|
(arm (and c (flan-fln--arm c)))
|
|
(v (if arm (plist-get arm :value)
|
|
(and c (flan-fln--clause-value c)))))
|
|
(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-<up>") #'flan-fln-move-statement-up
|
|
(kbd "M-<down>") #'flan-fln-move-statement-down
|
|
(kbd "M-<right>") #'flan-fln-slurp
|
|
(kbd "M-<left>") #'flan-fln-barf))
|
|
|
|
(provide 'flan-fln-mode)
|
|
;;; flan-fln-mode.el ends here
|