1642 lines
71 KiB
EmacsLisp
1642 lines
71 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.
|
|
;; 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))
|
|
(declare-function flan--eval-expression "flan" (start end arg))
|
|
(declare-function flan--text "flan" (start end))
|
|
(declare-function flan--text-at "flan" (start end))
|
|
(declare-function flan--report "flan" (reply what &optional at))
|
|
(declare-function flan--request "flan" (form))
|
|
(defvar flan--declaration-heads)
|
|
(defvar flan--defun-heads)
|
|
;; Set buffer-locally when the packages are there; declared so the setq-local
|
|
;; below does not make a stray global.
|
|
(defvar er/try-expand-list)
|
|
(defvar evil-shift-width)
|
|
(defvar evil-state)
|
|
(declare-function smartparens-mode "smartparens" (&optional arg))
|
|
(declare-function sp-local-pair "smartparens" (modes open close &rest args))
|
|
(declare-function evil-define-key* "evil-core" (state keymap key def &rest bindings))
|
|
(declare-function evil-range "evil-common" (beg end &optional type &rest properties))
|
|
|
|
(defcustom flan-fln-indent-offset 2
|
|
"Columns one block level adds in a .fln file."
|
|
:type 'integer
|
|
:group 'flan)
|
|
|
|
(defcustom flan-fln-smartparens t
|
|
"Turn on plain `smartparens-mode' in .fln buffers, when it is installed.
|
|
Plain rather than strict: strict mode keeps s-expressions balanced, and a
|
|
.fln file's blocks are not s-expressions, so it would refuse edits that are
|
|
fine here. Brackets and strings are still paired."
|
|
:type 'boolean
|
|
:group 'flan)
|
|
|
|
;;; Words
|
|
|
|
;; The spaced binary operators of lib/indent_reader.ml (`binops'). A line
|
|
;; that starts with one, or follows a line that ends with one, continues the
|
|
;; line above.
|
|
(defconst flan-fln--binops
|
|
'("or" "and" "==" "!=" "<" "<=" ">" ">=" "<<" ">>" "+" "-" "*" "/" "%"))
|
|
|
|
(defconst flan-fln--binop-re (regexp-opt flan-fln--binops))
|
|
|
|
(defconst flan-fln--clause-words '("else" "elif" "on" "restart")
|
|
"Words that start a clause of the statement above, at its column.")
|
|
|
|
(defconst flan-fln--clause-re
|
|
"\\(else\\|elif\\|on\\|restart\\)\\(?:[ \t]\\|$\\)")
|
|
|
|
(defconst flan-fln--clause-headers
|
|
'(("else" "if" "elif") ("elif" "if" "elif")
|
|
("on" "handler-case" "handler-bind" "on")
|
|
("restart" "restart-case" "restart"))
|
|
"For each clause word, the words of the lines it may sit under.")
|
|
|
|
;; `header_follow' in lib/indent_reader.ml: the words a statement starts with.
|
|
(defconst flan-fln--header-words
|
|
'("fn" "fn-" "def" "once" "const" "struct" "union" "data" "enum" "import"
|
|
"if" "elif" "else" "while" "until" "for" "match" "let" "return" "break"
|
|
"continue" "defer" "handler-case" "handler-bind" "restart-case" "on"
|
|
"restart" "quote"))
|
|
|
|
;; The headers whose block follows on the lines under them. `defer' and
|
|
;; `quote' open one only when nothing follows them on the line; `fn' does not
|
|
;; when it is the one-line `fn f(x) = e'; `if' does not when it is the one-line
|
|
;; `if c then a else b'.
|
|
(defconst flan-fln--opener-words
|
|
'("fn" "fn-" "struct" "union" "data" "enum" "if" "elif" "else" "while"
|
|
"until" "for" "match" "defer" "handler-case" "handler-bind"
|
|
"restart-case" "on" "restart" "quote"))
|
|
|
|
(defconst flan-fln--declaration-words
|
|
'(("fn" . "defn") ("fn-" . "defn-") ("def" . "def") ("once" . "defonce")
|
|
("const" . "defconst") ("struct" . "defstruct") ("data" . "defdata")
|
|
("enum" . "defenum") ("union" . "defunion") ("import" . "import"))
|
|
"Each declaration header word, and the paren head it reads as.")
|
|
|
|
;;; Syntax
|
|
|
|
(defvar flan-fln-mode-syntax-table
|
|
(let ((table (make-syntax-table)))
|
|
;; Name characters: a name is anything up to a delimiter (`is_delimiter'
|
|
;; in lib/reader.ml), so `key-pressed?', `dyn->f64' and `rl/draw-fps' are
|
|
;; one symbol each.
|
|
(dolist (c '(?- ?_ ?? ?! ?/ ?. ?$ ?& ?* ?+ ?< ?> ?= ?% ?@ ?# ?^ ?| ?~))
|
|
(modify-syntax-entry c "_" table))
|
|
;; Not `:', which ends `x: T' and `comment:': a name glued to it would
|
|
;; otherwise read as `x:', a name nothing defines. A `:key' keyword is
|
|
;; drawn by its own font-lock rule instead.
|
|
(modify-syntax-entry ?: "." table)
|
|
(modify-syntax-entry ?\; "<" table)
|
|
(modify-syntax-entry ?\n ">" table)
|
|
(modify-syntax-entry ?\" "\"" table)
|
|
;; `\c' is a character literal, `\(' included: escaping it keeps the
|
|
;; paren out of the bracket count.
|
|
(modify-syntax-entry ?\\ "\\" table)
|
|
(modify-syntax-entry ?' "'" table)
|
|
;; A comma separates, so it is not part of any term.
|
|
(modify-syntax-entry ?, "." table)
|
|
(modify-syntax-entry ?\( "()" table)
|
|
(modify-syntax-entry ?\) ")(" table)
|
|
(modify-syntax-entry ?\[ "(]" table)
|
|
(modify-syntax-entry ?\] ")[" table)
|
|
(modify-syntax-entry ?{ "(}" table)
|
|
(modify-syntax-entry ?} "){" table)
|
|
table)
|
|
"Syntax table for `flan-fln-mode'.")
|
|
|
|
;;; Lines
|
|
|
|
;; Every object is built from these. A position argument names the line it
|
|
;; is on; each answers for that line and leaves point alone.
|
|
|
|
(defun flan-fln--bol (pos)
|
|
(save-excursion (goto-char pos) (line-beginning-position)))
|
|
|
|
(defun flan-fln--indent-at (pos)
|
|
(save-excursion (goto-char pos) (current-indentation)))
|
|
|
|
(defun flan-fln--first-char (pos)
|
|
"Where the text of POS's line starts."
|
|
(save-excursion (goto-char pos) (back-to-indentation) (point)))
|
|
|
|
(defun flan-fln--in-open-p (pos)
|
|
"Non-nil if POS's line starts inside a bracket or a string."
|
|
(let ((s (save-excursion (syntax-ppss (flan-fln--bol pos)))))
|
|
(or (> (car s) 0) (nth 3 s))))
|
|
|
|
(defun flan-fln--blank-p (pos)
|
|
"Non-nil if POS's line holds no code: it is blank, or only a comment."
|
|
(save-excursion
|
|
(goto-char (flan-fln--bol pos))
|
|
(and (not (nth 3 (syntax-ppss (point))))
|
|
(progn (skip-chars-forward " \t")
|
|
(or (eolp) (eq (char-after) ?\;))))))
|
|
|
|
(defun flan-fln--code-end (pos)
|
|
"Where the code on POS's line ends: before a trailing comment and spaces."
|
|
(save-excursion
|
|
(goto-char pos)
|
|
(let* ((bol (line-beginning-position))
|
|
(eol (line-end-position))
|
|
(s (syntax-ppss eol)))
|
|
(goto-char (if (and (nth 4 s) (>= (nth 8 s) bol)) (nth 8 s) eol))
|
|
(skip-chars-backward " \t" bol)
|
|
(point))))
|
|
|
|
(defun flan-fln--ends-in-op-p (pos)
|
|
"Non-nil if POS's line ends in a spaced binary operator."
|
|
(save-excursion
|
|
(let ((end (flan-fln--code-end pos)))
|
|
(goto-char end)
|
|
(and (not (nth 3 (syntax-ppss end)))
|
|
(looking-back (concat "\\(?:^\\|[ \t]\\)" flan-fln--binop-re)
|
|
(line-beginning-position))))))
|
|
|
|
(defun flan-fln--starts-with-op-p (pos)
|
|
"Non-nil if POS's line starts with a spaced binary operator."
|
|
(save-excursion
|
|
(goto-char pos)
|
|
(back-to-indentation)
|
|
(looking-at (concat flan-fln--binop-re "\\(?:[ \t]\\|$\\)"))))
|
|
|
|
(defun flan-fln--prev-code (pos)
|
|
"The start of the nearest code line above POS's line, or nil."
|
|
(save-excursion
|
|
(goto-char pos)
|
|
(let (hit)
|
|
(while (and (not hit) (zerop (forward-line -1)))
|
|
(unless (flan-fln--blank-p (point)) (setq hit (point))))
|
|
hit)))
|
|
|
|
(defun flan-fln--next-code (pos)
|
|
"The start of the nearest code line below POS's line, or nil."
|
|
(save-excursion
|
|
(goto-char pos)
|
|
(let (hit)
|
|
(while (and (not hit) (zerop (forward-line 1)) (not (eobp)))
|
|
(unless (flan-fln--blank-p (point)) (setq hit (point))))
|
|
;; The last line of a buffer with no final newline: `forward-line'
|
|
;; reports it could not move a whole line, but it did reach it.
|
|
(when (and (not hit) (eobp) (not (bolp))
|
|
(> (line-beginning-position) (flan-fln--bol pos))
|
|
(not (flan-fln--blank-p (point))))
|
|
(setq hit (line-beginning-position)))
|
|
hit)))
|
|
|
|
(defun flan-fln--continuation-p (pos)
|
|
"Non-nil if POS's line continues the line above it.
|
|
Inside a bracket or a string, after a line that ends in a spaced operator, or
|
|
starting with one: the reader's three ways a line break is not a new line."
|
|
(or (flan-fln--in-open-p pos)
|
|
(flan-fln--starts-with-op-p pos)
|
|
(let ((p (flan-fln--prev-code pos)))
|
|
(and p (flan-fln--ends-in-op-p p)))))
|
|
|
|
(defun flan-fln--clause-line-p (pos)
|
|
"Non-nil if POS's line starts a clause: else, elif, on or restart.
|
|
A word, and only when a space or the end of the line follows it."
|
|
(and (not (flan-fln--continuation-p pos))
|
|
(save-excursion
|
|
(goto-char pos)
|
|
(back-to-indentation)
|
|
(looking-at flan-fln--clause-re))))
|
|
|
|
(defun flan-fln--logical-start (pos)
|
|
"The first line of the line POS is on, after continuation lines are joined."
|
|
(let ((bol (flan-fln--bol pos)) p)
|
|
(while (and (flan-fln--continuation-p bol)
|
|
(setq p (flan-fln--prev-code bol)))
|
|
(setq bol p))
|
|
bol))
|
|
|
|
(defun flan-fln--logical-end (pos)
|
|
"The last line of the joined line whose first line is POS's."
|
|
(let ((bol (flan-fln--bol pos)) n)
|
|
(while (and (setq n (flan-fln--next-code bol))
|
|
(flan-fln--continuation-p n))
|
|
(setq bol n))
|
|
bol))
|
|
|
|
;;; Statements
|
|
|
|
(defun flan-fln--statement-last (start &optional no-clauses)
|
|
"The last code line of the statement whose first line is START.
|
|
With NO-CLAUSES, stop before the first clause at START's column: the first
|
|
line's own block only."
|
|
(let* ((indent (flan-fln--indent-at start))
|
|
(last (flan-fln--logical-end start))
|
|
(next (flan-fln--next-code last)))
|
|
(while (and next
|
|
(or (> (flan-fln--indent-at next) indent)
|
|
(flan-fln--continuation-p next)
|
|
(and (not no-clauses)
|
|
(= (flan-fln--indent-at next) indent)
|
|
(flan-fln--clause-line-p next))))
|
|
(setq last (flan-fln--logical-end next)
|
|
next (flan-fln--next-code last)))
|
|
last))
|
|
|
|
(defun flan-fln--span (start last)
|
|
"(BEG . END) from the text of START's line to the code end of LAST's."
|
|
(cons (flan-fln--first-char start) (flan-fln--code-end last)))
|
|
|
|
(defun flan-fln--statement-bounds (start)
|
|
"Bounds of the statement whose first line is START."
|
|
(flan-fln--span start (flan-fln--statement-last start)))
|
|
|
|
(defun flan-fln--clause-header (start)
|
|
"The header line the clause at START belongs to, or START if it is not one."
|
|
(if (not (flan-fln--clause-line-p start))
|
|
start
|
|
(let ((ind (flan-fln--indent-at start)) (p start) hit)
|
|
(while (and (not hit) (setq p (flan-fln--prev-code p)))
|
|
(setq p (flan-fln--logical-start p))
|
|
(let ((i (flan-fln--indent-at p)))
|
|
(cond ((< i ind) (setq hit start))
|
|
((and (= i ind) (not (flan-fln--clause-line-p p)))
|
|
(setq hit p)))))
|
|
(or hit start))))
|
|
|
|
(defun flan-fln--code-line-at (pos)
|
|
"POS's line if it holds code, else the code line above, else the one below."
|
|
(let ((bol (flan-fln--bol pos)))
|
|
(if (flan-fln--blank-p bol)
|
|
(or (flan-fln--prev-code bol) (flan-fln--next-code bol))
|
|
bol)))
|
|
|
|
(defun flan-fln--line-statement (pos)
|
|
"The first line of the statement POS's line starts or continues.
|
|
A clause line answers for itself."
|
|
(let ((l (flan-fln--code-line-at pos)))
|
|
(and l (flan-fln--logical-start l))))
|
|
|
|
(defun flan-fln--statement-start-at (pos)
|
|
"The first line of the statement at POS; a clause gives its header's."
|
|
(let ((l (flan-fln--line-statement pos)))
|
|
(and l (flan-fln--clause-header l))))
|
|
|
|
(defun flan-fln--parent (start)
|
|
"The nearest line above START that is shallower: its block's owner, or nil.
|
|
A clause line owns its own block, so it can be the answer."
|
|
(let ((ind (flan-fln--indent-at start)) (p start) hit)
|
|
(when (> ind 0)
|
|
(while (and (not hit) (setq p (flan-fln--prev-code p)))
|
|
(setq p (flan-fln--logical-start p))
|
|
(when (< (flan-fln--indent-at p) ind) (setq hit p))))
|
|
hit))
|
|
|
|
(defun flan-fln--body-bounds (start)
|
|
"Bounds of the block under START's first line, or nil when it has none."
|
|
(let* ((head-last (flan-fln--logical-end start))
|
|
(first (flan-fln--next-code head-last)))
|
|
(when (and first (> (flan-fln--indent-at first) (flan-fln--indent-at start)))
|
|
(flan-fln--span first (flan-fln--statement-last start t)))))
|
|
|
|
(defun flan-fln--clause-at (pos)
|
|
"The clause line whose clause holds POS, the innermost one, or nil.
|
|
A match arm is a clause too: its pattern line and its value or block."
|
|
(let* ((line (flan-fln--line-statement pos))
|
|
(p line)
|
|
(limit (and line (1+ (flan-fln--indent-at line))))
|
|
hit)
|
|
(while (and p (not hit))
|
|
(let ((i (flan-fln--indent-at p)))
|
|
(when (< i limit)
|
|
(if (or (flan-fln--clause-line-p p) (flan-fln--arm p))
|
|
(setq hit p)
|
|
(setq limit i)))
|
|
(setq p (and (> limit 0)
|
|
(let ((q (flan-fln--prev-code p)))
|
|
(and q (flan-fln--logical-start q)))))))
|
|
hit))
|
|
|
|
(defun flan-fln--clause-bounds (start)
|
|
(flan-fln--span start (flan-fln--statement-last start t)))
|
|
|
|
;;; Top-level forms
|
|
|
|
(defun flan-fln--toplevel-start-p (pos)
|
|
"Non-nil if POS's line starts a top-level form.
|
|
Column 0 and code, and not a clause, an operator continuation, or a line
|
|
inside a bracket or a string -- spec-syntax.md §4.5, tightened."
|
|
(and (not (flan-fln--blank-p pos))
|
|
(zerop (flan-fln--indent-at pos))
|
|
(not (flan-fln--continuation-p pos))
|
|
(not (flan-fln--clause-line-p pos))))
|
|
|
|
(defun flan-fln--toplevel-start (pos)
|
|
"The first line of the top-level form at or before POS, else the next one."
|
|
(save-excursion
|
|
(goto-char (flan-fln--bol pos))
|
|
(let (hit)
|
|
(while (and (not hit)
|
|
(progn (when (flan-fln--toplevel-start-p (point))
|
|
(setq hit (point)))
|
|
(not hit))
|
|
(zerop (forward-line -1))))
|
|
(unless hit
|
|
(goto-char (flan-fln--bol pos))
|
|
(while (and (not hit) (zerop (forward-line 1)) (not (eobp)))
|
|
(when (flan-fln--toplevel-start-p (point)) (setq hit (point)))))
|
|
hit)))
|
|
|
|
(defun flan-fln--toplevel-last (start)
|
|
"The last code line of the top-level form starting at START."
|
|
(save-excursion
|
|
(goto-char start)
|
|
(let ((last start))
|
|
(while (and (zerop (forward-line 1)) (not (eobp))
|
|
(not (flan-fln--toplevel-start-p (point))))
|
|
(unless (flan-fln--blank-p (point)) (setq last (point))))
|
|
;; A last line with no newline after it.
|
|
(when (and (eobp) (not (bolp))
|
|
(not (flan-fln--toplevel-start-p (line-beginning-position)))
|
|
(not (flan-fln--blank-p (point))))
|
|
(setq last (line-beginning-position)))
|
|
last)))
|
|
|
|
(defun flan-fln--toplevel-bounds (pos)
|
|
"Bounds of the top-level form at POS, or nil in a buffer with none."
|
|
(let ((s (flan-fln--toplevel-start pos)))
|
|
(and s (flan-fln--span s (flan-fln--toplevel-last s)))))
|
|
|
|
(defun flan-fln--beginning-of-defun (&optional arg)
|
|
"Move to the start of the ARGth top-level form back; forward when negative.
|
|
For `beginning-of-defun-function'."
|
|
(setq arg (or arg 1))
|
|
(let ((found t))
|
|
(if (> arg 0)
|
|
(dotimes (_ arg)
|
|
(let ((here (point)) hit)
|
|
(beginning-of-line)
|
|
(when (and (< (point) here) (flan-fln--toplevel-start-p (point)))
|
|
(setq hit t))
|
|
(while (and (not hit) (zerop (forward-line -1)))
|
|
(when (flan-fln--toplevel-start-p (point)) (setq hit t)))
|
|
(unless hit (setq found nil))))
|
|
(dotimes (_ (- arg))
|
|
(let (hit)
|
|
(while (and (not hit) (zerop (forward-line 1)) (not (eobp)))
|
|
(when (flan-fln--toplevel-start-p (point)) (setq hit t)))
|
|
(unless hit (setq found nil)))))
|
|
found))
|
|
|
|
(defun flan-fln--end-of-defun ()
|
|
"From the start of a top-level form, move to its end.
|
|
For `end-of-defun-function'."
|
|
(goto-char (cdr (flan-fln--span (point) (flan-fln--toplevel-last (point))))))
|
|
|
|
;;; Terms and groups
|
|
|
|
(defun flan-fln--term-forward (pos)
|
|
(save-excursion
|
|
(goto-char pos)
|
|
(let (done)
|
|
(while (and (not done) (not (eobp)))
|
|
(let ((c (char-after))
|
|
(syn (syntax-class (syntax-after (point)))))
|
|
(cond ((memq c '(?\s ?\t ?\n ?, ?\;)) (setq done t))
|
|
((eq c ?\\) (forward-char (min 2 (- (point-max) (point)))))
|
|
((memq syn '(4 7))
|
|
(condition-case nil (forward-sexp 1)
|
|
(scan-error (setq done t))))
|
|
((eq syn 5) (setq done t))
|
|
(t (forward-char 1)))))
|
|
(point))))
|
|
|
|
(defun flan-fln--term-back (pos)
|
|
(save-excursion
|
|
(goto-char pos)
|
|
(let (done)
|
|
(while (and (not done) (not (bobp)))
|
|
(let ((c (char-before))
|
|
(syn (syntax-class (syntax-after (1- (point))))))
|
|
(cond ((and (> (1- (point)) (point-min))
|
|
(eq (char-before (1- (point))) ?\\))
|
|
(backward-char 2))
|
|
((memq c '(?\s ?\t ?\n ?,)) (setq done t))
|
|
((eq syn 4) (setq done t))
|
|
((memq syn '(5 7))
|
|
(condition-case nil (backward-sexp 1)
|
|
(scan-error (setq done t))))
|
|
(t (backward-char 1)))))
|
|
(point))))
|
|
|
|
(defun flan-fln--trim-colon (beg end)
|
|
"END, less the trailing colon of `x:' or `f(x):' when BEG..END has one."
|
|
(if (and (> end (1+ beg)) (eq (char-before end) ?:)
|
|
(not (eq (char-after beg) ?:)))
|
|
(1- end)
|
|
end))
|
|
|
|
(defun flan-fln--term-bounds (pos)
|
|
"Bounds of the term at POS: a run with no space in it outside brackets."
|
|
(let ((s (save-excursion (syntax-ppss pos))))
|
|
(unless (nth 4 s)
|
|
(let* ((pos (if (nth 3 s) (nth 8 s) pos))
|
|
(beg (flan-fln--term-back pos))
|
|
(end (flan-fln--trim-colon beg (flan-fln--term-forward pos))))
|
|
(and (< beg end) (cons beg end))))))
|
|
|
|
(defun flan-fln--term-before (pos)
|
|
"Bounds of the term that ends at POS, spaces before POS skipped, or nil.
|
|
A comment is skipped too: nothing in one is a term."
|
|
(save-excursion
|
|
(goto-char pos)
|
|
(let ((s (syntax-ppss pos)))
|
|
(when (nth 4 s) (goto-char (nth 8 s))))
|
|
(skip-chars-backward " \t,")
|
|
(let* ((end (point))
|
|
(beg (flan-fln--term-back end))
|
|
(end (flan-fln--trim-colon beg end)))
|
|
(and (< beg end) (cons beg end)))))
|
|
|
|
(defun flan-fln--group-bounds (pos)
|
|
"Bounds of the innermost bracket pair around POS, or nil."
|
|
(let ((open (nth 1 (save-excursion (syntax-ppss pos)))))
|
|
(and open (cons open (ignore-errors (scan-lists open 1 0))))))
|
|
|
|
(defun flan-fln--group-form-start (open)
|
|
"Where the reader starts the form the bracket at OPEN belongs to.
|
|
A bracket glued to what is before it is a call, an index or a struct literal,
|
|
and the form starts where that term does (`f' of `f(x)', not the paren). A
|
|
free `(' groups one value and the form is that value. A free `[' or `{' is
|
|
the form."
|
|
(let ((before (char-before open)))
|
|
(cond
|
|
((and before (not (memq before '(?\s ?\t ?\n ?, ?\( ?\[ ?\{))))
|
|
(let ((b (flan-fln--term-back open)))
|
|
;; `-f(x)' reads as the negation of the call, and the call starts at f.
|
|
(if (and (eq (char-after b) ?-)
|
|
(string-match-p "[a-zA-Z$_*]" (string (char-after (1+ b)))))
|
|
(1+ b)
|
|
b)))
|
|
((eq (char-after open) ?\()
|
|
(save-excursion
|
|
(goto-char (1+ open))
|
|
(skip-chars-forward " \t\n")
|
|
(if (eq (char-after) ?\)) open (point))))
|
|
(t open))))
|
|
|
|
;;; Declarations
|
|
|
|
(defun flan-fln--declaration-head-at (pos &optional heads)
|
|
"The paren head of the declaration written at POS, or nil.
|
|
The .fln twin of `flan--declaration-head-at': POS must be at column 0 and not
|
|
in a string or comment, and the header word -- `fn', `def', `struct', ... --
|
|
or the fallback call's name, `defmethod(', must read as one of HEADS,
|
|
`flan--declaration-heads' by default."
|
|
(save-excursion
|
|
(let ((state (syntax-ppss pos)))
|
|
(goto-char pos)
|
|
(and (zerop (current-column))
|
|
(zerop (car state))
|
|
(not (nth 8 state))
|
|
(let ((head
|
|
(cond
|
|
((looking-at (concat (regexp-opt (mapcar #'car flan-fln--declaration-words) t)
|
|
"[ \t]"))
|
|
(cdr (assoc (match-string-no-properties 1)
|
|
flan-fln--declaration-words)))
|
|
((looking-at "\\([^][ \t\n(){},;\":]+\\)(")
|
|
(match-string-no-properties 1)))))
|
|
(and head (member head (or heads flan--declaration-heads)) head))))))
|
|
|
|
;;; Sending
|
|
|
|
(defun flan-fln--client ()
|
|
(require 'flan))
|
|
|
|
(defun flan-fln--cut-indent (beg)
|
|
"The byte column of the statement BEG was cut out of, when BEG is mid-line.
|
|
A condition or an arm's value starts after `elif ' or `-> ', and a line that
|
|
continues it is indented past the statement's start, perhaps not past the
|
|
cut. The reader is told where the statement starts (`:indent'), so it
|
|
reads the text as the file has it, and every location it reports is still
|
|
the buffer's own."
|
|
(save-excursion
|
|
(goto-char beg)
|
|
(when (> (current-column) (current-indentation))
|
|
(back-to-indentation)
|
|
(1+ (- (position-bytes (point))
|
|
(position-bytes (line-beginning-position)))))))
|
|
|
|
(defun flan-fln--eval-expression (beg end arg)
|
|
"Evaluate BEG..END as an expression, as `flan--eval-expression' does, and
|
|
with `:indent' when BEG is mid-line."
|
|
(flan--report
|
|
(flan--request
|
|
(let ((at (flan--text-at beg end))
|
|
(indent (flan-fln--cut-indent beg)))
|
|
(append (list :op "eval-expr" :code (car at)
|
|
:file (or buffer-file-name "<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))
|
|
((and g (cdr g) (> (car g) (car b)))
|
|
(cons (flan-fln--group-form-start (car g)) (cdr g)))
|
|
(arm (plist-get arm :value))
|
|
((and l (flan-fln--clause-line-p l)) (flan-fln--clause-target l))
|
|
(t (let ((s (flan-fln--statement-start-at pos)))
|
|
(and s (flan-fln--statement-bounds s)))))))
|
|
|
|
(defun flan-fln--clause-target (l)
|
|
"What a clause line L stops at: an elif's condition, else its block."
|
|
(save-excursion
|
|
(goto-char (flan-fln--first-char l))
|
|
(if (looking-at "elif[ \t]+")
|
|
(cons (match-end 0) (flan-fln--code-end (flan-fln--logical-end l)))
|
|
(flan-fln--body-bounds l))))
|
|
|
|
(defun flan-fln--condition (l)
|
|
"Bounds of the condition on the if, elif, while or until line L, or nil.
|
|
A loop's label, `while :outer c', is not part of it."
|
|
(save-excursion
|
|
(goto-char (flan-fln--first-char l))
|
|
(when (looking-at "\\(?:if\\|elif\\|while\\|until\\)[ \t]+\\(?::[^ \t]+[ \t]+\\)?")
|
|
(let ((beg (match-end 0))
|
|
(end (flan-fln--code-end (flan-fln--logical-end l))))
|
|
(and (< beg end) (cons beg end))))))
|
|
|
|
(defun flan-fln--arm (l)
|
|
"The match arm whose joined line starts at L, or nil.
|
|
A plist: :arrow, where its ` -> ' starts; :value, the bounds of what follows
|
|
the arrow on the line, or of the block under it; :binds, non-nil when the
|
|
pattern names something, so the value cannot be evaluated alone."
|
|
(let ((parent (flan-fln--parent l)))
|
|
(when (and parent
|
|
(string-match-p "\\(?:\\`\\|[ \t]=[ \t]+\\)match\\(?:[ \t]\\|\\'\\)"
|
|
(buffer-substring-no-properties
|
|
(flan-fln--first-char parent)
|
|
(flan-fln--code-end parent))))
|
|
(save-excursion
|
|
(let* ((start (flan-fln--first-char l))
|
|
(last (flan-fln--code-end (flan-fln--logical-end l)))
|
|
(depth (car (syntax-ppss start)))
|
|
arrow)
|
|
(goto-char start)
|
|
(while (and (not arrow)
|
|
(re-search-forward "[ \t]\\(->\\)\\(?:[ \t]\\|$\\)" last t))
|
|
(let ((ps (save-excursion (syntax-ppss (match-beginning 1)))))
|
|
(when (and (= (car ps) depth) (not (nth 8 ps)))
|
|
(setq arrow (match-beginning 1)))))
|
|
(when arrow
|
|
(let* ((pat (string-trim (buffer-substring-no-properties start arrow)))
|
|
(vbeg (save-excursion (goto-char (+ arrow 2))
|
|
(skip-chars-forward " \t") (point)))
|
|
(value (if (< vbeg last) (cons vbeg last)
|
|
(flan-fln--body-bounds l))))
|
|
(and value
|
|
(list :arrow arrow :value value
|
|
:binds (flan-fln--uses-any-p
|
|
(flan-fln--pattern-names pat)
|
|
(buffer-substring-no-properties
|
|
(car value) (cdr value))))))))))))
|
|
|
|
(defconst flan-fln--name-char "[:alnum:]_?!*/$<>=%+-"
|
|
"The characters a name is made of, for a character class.")
|
|
|
|
(defun flan-fln--pattern-names (pat)
|
|
"The names pattern PAT binds: its lowercase words that are not constants,
|
|
fields, keywords, constructors or `_'."
|
|
(let ((re (concat "\\(?:\\`\\|[^" flan-fln--name-char ".:]\\)"
|
|
"\\([a-z][" flan-fln--name-char "]*\\)"))
|
|
(start 0) names)
|
|
(while (string-match re pat start)
|
|
(let ((n (match-string 1 pat)))
|
|
(setq start (match-end 1))
|
|
(unless (or (member n flan--constants)
|
|
(and (< start (length pat)) (memq (aref pat start) '(?\( ?.))))
|
|
(push n names))))
|
|
names))
|
|
|
|
(defun flan-fln--uses-any-p (names text)
|
|
"Non-nil if TEXT has any of NAMES as a whole name."
|
|
(seq-some (lambda (n)
|
|
(string-match-p (concat "\\(?:\\`\\|[^" flan-fln--name-char ".]\\)"
|
|
(regexp-quote n)
|
|
"\\(?:\\'\\|[^" flan-fln--name-char "]\\)")
|
|
text))
|
|
names))
|
|
|
|
(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)))))))
|
|
|
|
(defun flan-fln--point-for-last ()
|
|
"Point, or under Evil's normal state the position after the cursor's char.
|
|
The cursor sits *on* the last character of a line, never after it."
|
|
(if (and (bound-and-true-p evil-local-mode)
|
|
(memq evil-state '(normal motion))
|
|
(not (eolp)))
|
|
(1+ (point))
|
|
(point)))
|
|
|
|
(defun flan-fln--statement-ending-at (pos)
|
|
"Bounds of the innermost statement whose last line is POS's, or nil."
|
|
(let ((l (flan-fln--line-statement pos)))
|
|
(when (and l (not (flan-fln--blank-p pos)) (not (flan-fln--clause-line-p l))
|
|
(= (flan-fln--statement-last l) (flan-fln--bol pos)))
|
|
(flan-fln--statement-bounds l))))
|
|
|
|
;;;###autoload
|
|
(defun flan-fln-eval-last (&optional arg)
|
|
"Evaluate the statement that ends at point, or the term before point.
|
|
At the end of a line, the innermost statement whose last line it is; a
|
|
declaration at column 0 is installed. Anywhere else, the term that ends
|
|
before point. With ARG, stop there instead, as \\[flan-eval-last-sexp] does."
|
|
(interactive "P")
|
|
(flan-fln--client)
|
|
(let* ((end (flan-fln--point-for-last))
|
|
;; A line the next one continues -- an operator at either side of
|
|
;; the break, or a bracket left open -- ends where the whole joined
|
|
;; line does, not at its last word.
|
|
(end (if (and (>= end (flan-fln--code-end end))
|
|
(not (flan-fln--blank-p end))
|
|
(let ((n (flan-fln--next-code end)))
|
|
(and n (flan-fln--continuation-p n))))
|
|
(flan-fln--code-end
|
|
(flan-fln--logical-end (flan-fln--logical-start end)))
|
|
end))
|
|
(at-end (and (>= end (flan-fln--code-end end))
|
|
(not (flan-fln--blank-p end))))
|
|
(l (and at-end (flan-fln--line-statement end)))
|
|
;; Point ends the line L starts, joined lines included.
|
|
(l-end (and l (= (flan-fln--bol end) (flan-fln--logical-end l))))
|
|
(arm (and l-end (flan-fln--arm l)))
|
|
(st (and at-end (not arm) (flan-fln--statement-ending-at end)))
|
|
(opens (and l-end (not st) (not arm)
|
|
(or (flan-fln--clause-line-p l)
|
|
(/= (flan-fln--statement-last l)
|
|
(flan-fln--logical-end l))))))
|
|
(cond
|
|
(arm (let ((b (flan-fln--arm-to-send l arm)))
|
|
(flan-fln--send (car b) (cdr b) arg flan--declaration-heads)))
|
|
(st (flan-fln--send (car st) (cdr st) arg flan--declaration-heads))
|
|
;; The end of a line that opens a block: its last word is not what was
|
|
;; meant. A condition is a value of its own; anything else is sent
|
|
;; with its block, a clause with the statement it belongs to.
|
|
((and opens (flan-fln--condition l))
|
|
(let ((c (flan-fln--condition l)))
|
|
(flan-fln--eval-expression (car c) (cdr c) arg)))
|
|
(opens
|
|
(let ((b (flan-fln--statement-bounds (flan-fln--clause-header l))))
|
|
(flan-fln--send (car b) (cdr b) arg flan--declaration-heads)))
|
|
(t
|
|
(let ((tb (flan-fln--term-before end)))
|
|
(unless tb (user-error "flan: no form before point to evaluate"))
|
|
(flan--eval-expression (car tb) (cdr tb) arg))))))
|
|
|
|
(defun flan-fln--snap-lines (beg end)
|
|
"BEG..END widened to whole lines, less leading blank lines and trailing space."
|
|
(let ((first (flan-fln--bol beg))
|
|
(last (flan-fln--bol (if (and (> end beg)
|
|
(save-excursion (goto-char end) (bolp)))
|
|
(1- end)
|
|
end))))
|
|
(when (flan-fln--blank-p first) (setq first (flan-fln--next-code first)))
|
|
(when (and first (<= first last))
|
|
(cons (flan-fln--first-char first)
|
|
(save-excursion (goto-char last) (end-of-line)
|
|
(skip-chars-backward " \t\n" first) (point))))))
|
|
|
|
(defun flan-fln--bare-let-p (start)
|
|
"Non-nil if START's statement is a `let' with no block of its own."
|
|
(and (save-excursion (goto-char (flan-fln--first-char start))
|
|
(looking-at "let[ \t]"))
|
|
(= (flan-fln--statement-last start) (flan-fln--logical-end start))))
|
|
|
|
(defun flan-fln--block-rest (start)
|
|
"START's statement and every statement after it in the same block."
|
|
(let* ((ind (flan-fln--indent-at start))
|
|
(last (flan-fln--statement-last start))
|
|
(next (flan-fln--next-code last)))
|
|
(while (and next (= (flan-fln--indent-at next) ind)
|
|
(not (flan-fln--clause-line-p next)))
|
|
(setq last (flan-fln--statement-last next)
|
|
next (flan-fln--next-code last)))
|
|
(flan-fln--span start last)))
|
|
|
|
(defun flan-fln--statement-to-send (pos)
|
|
"The statement at POS as sent by `C-c C-e': with its body and clauses, and
|
|
for a bare `let x = v', with the rest of its block, which is its scope."
|
|
(let* ((l (flan-fln--line-statement pos))
|
|
(arm (and l (flan-fln--arm l)))
|
|
(s (flan-fln--statement-start-at pos)))
|
|
(cond (arm (flan-fln--arm-to-send l arm))
|
|
((null s) nil)
|
|
((flan-fln--bare-let-p s) (flan-fln--block-rest s))
|
|
(t (flan-fln--statement-bounds s)))))
|
|
|
|
;;;###autoload
|
|
(defun flan-fln-eval-statement (&optional arg)
|
|
"Evaluate the statement at point, with its body and clauses.
|
|
With an active region, the lines it touches instead. On a bare `let x = v',
|
|
the `let' and the rest of its block, which is what it is in scope for; the
|
|
span sent is flashed so the extent is visible. A declaration at column 0 is
|
|
installed. ARG is as for \\[flan-fln-eval-last]."
|
|
(interactive "P")
|
|
(flan-fln--client)
|
|
(let ((b (if (use-region-p)
|
|
(flan-fln--snap-lines (region-beginning) (region-end))
|
|
(flan-fln--statement-to-send (point)))))
|
|
(unless b (user-error "flan: no statement at point to evaluate"))
|
|
(when (use-region-p) (deactivate-mark))
|
|
(flan-fln--send (car b) (cdr b) arg flan--defun-heads)))
|
|
|
|
;;;###autoload
|
|
(defun flan-fln-eval-statement-and-next ()
|
|
"Evaluate the statement at point, then move to the statement after it."
|
|
(interactive)
|
|
(flan-fln--client)
|
|
(let ((b (flan-fln--statement-to-send (point))))
|
|
(unless b (user-error "flan: no statement at point to evaluate"))
|
|
(prog1 (flan-fln--send (car b) (cdr b) nil flan--defun-heads)
|
|
(let ((n (flan-fln--next-code (cdr b))))
|
|
(goto-char (if n (flan-fln--first-char n) (cdr b)))))))
|
|
|
|
;;; Motion
|
|
|
|
(defun flan-fln-backward-statement (&optional n)
|
|
"Move to the start of the statement at point, or to the one before it.
|
|
Before it at the same level, else out to the line that owns this block."
|
|
(interactive "^p")
|
|
(dotimes (_ (or n 1))
|
|
(let* ((l (flan-fln--line-statement (point)))
|
|
(here (and l (flan-fln--first-char l))))
|
|
(cond
|
|
((null l))
|
|
((> (point) here) (goto-char here))
|
|
(t
|
|
(let ((ind (flan-fln--indent-at l)) (p l) hit)
|
|
(while (and (not hit) (setq p (flan-fln--prev-code p)))
|
|
(setq p (flan-fln--logical-start p))
|
|
(when (<= (flan-fln--indent-at p) ind)
|
|
(setq hit (if (= (flan-fln--indent-at p) ind)
|
|
(flan-fln--clause-header p)
|
|
p))))
|
|
(when hit (goto-char (flan-fln--first-char hit)))))))))
|
|
|
|
(defun flan-fln-forward-statement (&optional n)
|
|
"Move to the end of the statement at point, or of the one after it."
|
|
(interactive "^p")
|
|
(dotimes (_ (or n 1))
|
|
(let* ((s (flan-fln--statement-start-at (point)))
|
|
(e (and s (cdr (flan-fln--statement-bounds s)))))
|
|
(cond
|
|
((null s))
|
|
((< (point) e) (goto-char e))
|
|
(t (let ((nx (flan-fln--next-code (flan-fln--statement-last s))))
|
|
(when nx
|
|
(goto-char (cdr (flan-fln--statement-bounds
|
|
(flan-fln--clause-header
|
|
(flan-fln--logical-start nx))))))))))))
|
|
|
|
(defun flan-fln-next-statement (&optional n)
|
|
"Move to the start of the statement after the one at point."
|
|
(interactive "^p")
|
|
(dotimes (_ (or n 1))
|
|
(let* ((s (flan-fln--statement-start-at (point)))
|
|
(nx (and s (flan-fln--next-code (flan-fln--statement-last s)))))
|
|
(when nx (goto-char (flan-fln--first-char nx))))))
|
|
|
|
(defun flan-fln-up (&optional n)
|
|
"Move up to the bracket around point, or to the line that owns its block."
|
|
(interactive "^p")
|
|
(dotimes (_ (or n 1))
|
|
(let ((open (nth 1 (syntax-ppss))))
|
|
(if open
|
|
(goto-char open)
|
|
(let* ((l (flan-fln--line-statement (point)))
|
|
(p (and l (flan-fln--parent l))))
|
|
(if p (goto-char (flan-fln--first-char p))
|
|
(user-error "flan: at top level")))))))
|
|
|
|
;;; Marking, for expand-region and anything else that marks
|
|
|
|
(defun flan-fln--region ()
|
|
(if (use-region-p) (cons (region-beginning) (region-end)) (cons (point) (point))))
|
|
|
|
(defun flan-fln--larger-p (b r)
|
|
"Non-nil if bounds B contain region R and are larger than it."
|
|
(and b (cdr b) (<= (car b) (car r)) (>= (cdr b) (cdr r))
|
|
(> (- (cdr b) (car b)) (- (cdr r) (car r)))))
|
|
|
|
(defun flan-fln--mark (b)
|
|
(when b
|
|
(goto-char (car b))
|
|
(push-mark (cdr b) t t)
|
|
(activate-mark)
|
|
b))
|
|
|
|
(defun flan-fln-mark-term ()
|
|
"Mark the term at point, or the one around the marked text."
|
|
(interactive)
|
|
(let* ((r (flan-fln--region))
|
|
(b (flan-fln--term-bounds (car r))))
|
|
;; Out through the brackets until the term holds the region.
|
|
(while (and b (not (flan-fln--larger-p b r)))
|
|
(let ((g (flan-fln--group-bounds (car b))))
|
|
(setq b (and g (flan-fln--term-bounds (car g))))))
|
|
(flan-fln--mark b)))
|
|
|
|
(defun flan-fln-mark-group ()
|
|
"Mark the bracket group around point, or around the marked text."
|
|
(interactive)
|
|
(let* ((r (flan-fln--region))
|
|
(b (flan-fln--group-bounds (car r))))
|
|
(while (and b (not (flan-fln--larger-p b r)))
|
|
(setq b (flan-fln--group-bounds (car b))))
|
|
(flan-fln--mark b)))
|
|
|
|
(defun flan-fln--statement-around (r)
|
|
"The innermost statement that holds region R and is larger than it."
|
|
(let* ((s (flan-fln--statement-start-at (car r)))
|
|
(b (and s (flan-fln--statement-bounds s))))
|
|
(while (and s (not (flan-fln--larger-p b r)))
|
|
;; A clause's statement is its header's.
|
|
(let ((h (flan-fln--clause-header s)))
|
|
(setq s (if (/= h s) h (flan-fln--parent s)))
|
|
(setq b (and s (flan-fln--statement-bounds s)))))
|
|
b))
|
|
|
|
(defun flan-fln-mark-statement ()
|
|
"Mark the statement at point, or the one around the marked text."
|
|
(interactive)
|
|
(flan-fln--mark (flan-fln--statement-around (flan-fln--region))))
|
|
|
|
(defun flan-fln-mark-clause ()
|
|
"Mark the clause at point, or the one around the marked text."
|
|
(interactive)
|
|
(let* ((r (flan-fln--region))
|
|
(c (flan-fln--clause-at (car r)))
|
|
(b (and c (flan-fln--clause-bounds c))))
|
|
(while (and c (not (flan-fln--larger-p b r)))
|
|
(setq c (let ((p (flan-fln--parent c))) (and p (flan-fln--clause-at p))))
|
|
(setq b (and c (flan-fln--clause-bounds c))))
|
|
(flan-fln--mark b)))
|
|
|
|
(defun flan-fln-mark-toplevel ()
|
|
"Mark the top-level form at point."
|
|
(interactive)
|
|
(flan-fln--mark (flan-fln--toplevel-bounds (car (flan-fln--region)))))
|
|
|
|
;; thing-at-point, so `(bounds-of-thing-at-point 'flan-fln-statement)' and
|
|
;; everything built on it knows the objects.
|
|
(put 'flan-fln-term 'bounds-of-thing-at-point
|
|
(lambda () (flan-fln--term-bounds (point))))
|
|
(put 'flan-fln-group 'bounds-of-thing-at-point
|
|
(lambda () (flan-fln--group-bounds (point))))
|
|
(put 'flan-fln-statement 'bounds-of-thing-at-point
|
|
(lambda () (let ((s (flan-fln--statement-start-at (point))))
|
|
(and s (flan-fln--statement-bounds s)))))
|
|
(put 'flan-fln-body 'bounds-of-thing-at-point
|
|
(lambda () (let ((s (flan-fln--statement-start-at (point))))
|
|
(and s (flan-fln--body-bounds s)))))
|
|
(put 'flan-fln-clause 'bounds-of-thing-at-point
|
|
(lambda () (let ((c (flan-fln--clause-at (point))))
|
|
(and c (flan-fln--clause-bounds c)))))
|
|
(put 'flan-fln-toplevel 'bounds-of-thing-at-point
|
|
(lambda () (flan-fln--toplevel-bounds (point))))
|
|
|
|
;;; Indentation
|
|
|
|
;; TAB offers the columns of the blocks open above the line, plus one level
|
|
;; deeper after a line that opens a block. The first TAB takes the deepest,
|
|
;; each repeated TAB steps out one. A block's column is the program's
|
|
;; meaning, so nothing here ever moves a line on its own: `indent-region'
|
|
;; shifts rigidly and only when the first line is at no valid column, and a
|
|
;; yank moves its lines together.
|
|
|
|
(defun flan-fln--opener-p (start last)
|
|
"Non-nil if the joined line START..LAST opens a block on the lines under it."
|
|
(or (save-excursion
|
|
(goto-char start)
|
|
(back-to-indentation)
|
|
(and (looking-at (concat (regexp-opt flan-fln--opener-words t)
|
|
"\\([ \t]\\|$\\)"))
|
|
(let ((w (match-string-no-properties 1))
|
|
(alone (string= (match-string-no-properties 2) ""))
|
|
(end (flan-fln--code-end last)))
|
|
(cond
|
|
((member w '("defer" "quote")) alone)
|
|
((member w '("fn" "fn-"))
|
|
(not (re-search-forward "[ \t]=[ \t]" end t)))
|
|
((member w '("if" "elif"))
|
|
(not (re-search-forward "[ \t]then[ \t]" end t)))
|
|
(t t)))))
|
|
(save-excursion
|
|
(goto-char (flan-fln--code-end last))
|
|
(let ((bol (line-beginning-position)))
|
|
(or (looking-back ":" bol)
|
|
(looking-back "[ \t]->" bol)
|
|
;; `let x =' and `def colors =' with the value as a block,
|
|
;; which the author's list leaves out and the reader reads.
|
|
(looking-back "[ \t]=" bol)
|
|
;; `let f = fn(x)' with its body under it.
|
|
(looking-back "\\_<fn([^()]*)" bol))))))
|
|
|
|
(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--logical-start p))
|
|
(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))))
|
|
(if (and prev (flan-fln--opener-p (flan-fln--logical-start prev) prev))
|
|
(cons (+ (flan-fln--indent-at (flan-fln--logical-start prev))
|
|
flan-fln-indent-offset)
|
|
stack)
|
|
stack)))
|
|
|
|
(defun flan-fln--clause-columns (word pos)
|
|
"Columns of the lines above POS a clause WORD may sit under, deepest first."
|
|
(let ((heads (cdr (assoc word flan-fln--clause-headers))))
|
|
(delq nil
|
|
(mapcar (lambda (e)
|
|
(and (cdr e)
|
|
(save-excursion
|
|
(goto-char (flan-fln--first-char (cdr e)))
|
|
(and (looking-at (concat (regexp-opt heads)
|
|
"\\(?:[ \t]\\|$\\)"))
|
|
(car e)))))
|
|
(flan-fln--stack pos)))))
|
|
|
|
(defun flan-fln--bracket-column (open)
|
|
"The column a line inside the bracket at OPEN goes to.
|
|
Under the first element when one follows the bracket on its line, one level
|
|
in from that line when none does -- the paren mode's rule for data and
|
|
calls alike. A line that starts with the closing bracket goes to the
|
|
opening line's column."
|
|
(save-excursion
|
|
(let ((closing (save-excursion (back-to-indentation) (looking-at "\\s)"))))
|
|
(goto-char open)
|
|
(if closing
|
|
(current-indentation)
|
|
(forward-char 1)
|
|
(skip-chars-forward " \t")
|
|
(if (or (eolp) (eq (char-after) ?\;))
|
|
(+ (current-indentation) flan-fln-indent-offset)
|
|
(current-column))))))
|
|
|
|
(defun flan-fln--indent-candidates (pos)
|
|
"Columns TAB offers POS's line, deepest first; nil to leave it alone."
|
|
(save-excursion
|
|
(goto-char (flan-fln--bol pos))
|
|
(let ((s (syntax-ppss (point))))
|
|
(cond
|
|
((nth 3 s) nil)
|
|
((> (car s) 0) (list (flan-fln--bracket-column (nth 1 s))))
|
|
(t
|
|
(let ((prev (flan-fln--prev-code (point))))
|
|
(cond
|
|
((null prev) (list 0))
|
|
((save-excursion (back-to-indentation) (looking-at flan-fln--clause-re))
|
|
(or (flan-fln--clause-columns (match-string-no-properties 1) (point))
|
|
(flan-fln--levels (point))))
|
|
((or (flan-fln--starts-with-op-p (point))
|
|
(flan-fln--ends-in-op-p prev))
|
|
(list (+ (flan-fln--indent-at (flan-fln--logical-start prev))
|
|
flan-fln-indent-offset)))
|
|
(t (flan-fln--levels (point))))))))))
|
|
|
|
(defun flan-fln-indent-line ()
|
|
"Indent the line to a block column.
|
|
A line with text at a valid column stays there: its column is its meaning,
|
|
and a TAB pressed to see where it goes must not change it. An empty line
|
|
goes to the deepest column. Each repeated TAB then steps out one."
|
|
(let* ((cands (flan-fln--indent-candidates (point)))
|
|
(cur (current-indentation))
|
|
(target
|
|
(cond ((null cands) nil)
|
|
((and (eq this-command 'indent-for-tab-command)
|
|
(eq last-command 'indent-for-tab-command)
|
|
(memq cur cands))
|
|
(or (cadr (memq cur cands)) (car cands)))
|
|
((and (memq cur cands)
|
|
(not (save-excursion (beginning-of-line)
|
|
(looking-at-p "[ \t]*$"))))
|
|
cur)
|
|
(t (car cands)))))
|
|
(if (null target)
|
|
'noindent
|
|
(let ((from-end (and (> (current-column) cur) (- (point-max) (point)))))
|
|
(indent-line-to target)
|
|
(when from-end (goto-char (- (point-max) from-end)))))))
|
|
|
|
(defun flan-fln-indent-region (start end)
|
|
"Shift START..END rigidly so its first line sits at a block column.
|
|
Never re-indents a line against the others: the columns are the program."
|
|
(save-excursion
|
|
(goto-char start)
|
|
(beginning-of-line)
|
|
(while (and (< (point) end) (flan-fln--blank-p (point))
|
|
(zerop (forward-line 1))))
|
|
(when (< (point) end)
|
|
(let ((cands (flan-fln--indent-candidates (point)))
|
|
(cur (current-indentation)))
|
|
(when (and cands (not (memq cur cands)))
|
|
(indent-rigidly (point) end (- (car cands) cur)))))))
|
|
|
|
(defun flan-fln-dedent-or-delete (arg)
|
|
"In a line's indentation, drop it one block level; else delete a character."
|
|
(interactive "*p")
|
|
(if (and (= arg 1) (not (use-region-p))
|
|
(> (current-column) 0)
|
|
(= (current-column) (current-indentation))
|
|
(not (flan-fln--in-open-p (point))))
|
|
(let ((cur (current-indentation)))
|
|
(indent-line-to (or (seq-find (lambda (c) (< c cur))
|
|
(flan-fln--levels (point)))
|
|
0)))
|
|
(let ((cmd (or (command-remapping 'delete-backward-char)
|
|
#'delete-backward-char)))
|
|
(setq this-command cmd)
|
|
(call-interactively cmd))))
|
|
|
|
(defun flan-fln--electric-clause ()
|
|
"Snap an else, elif, on or restart line to its header as it is typed.
|
|
Run when the word is finished by a space or a newline."
|
|
(when (memq last-command-event '(?\s ?\n ?\r))
|
|
(save-excursion
|
|
(let ((nl (not (eq last-command-event ?\s))))
|
|
(when nl (forward-line -1))
|
|
(let ((text (buffer-substring-no-properties
|
|
(line-beginning-position)
|
|
(if nl (line-end-position) (point)))))
|
|
(when (and (string-match "\\`[ \t]*\\(else\\|elif\\|on\\|restart\\)[ \t]*\\'"
|
|
text)
|
|
(not (flan-fln--in-open-p (point))))
|
|
(let ((cols (flan-fln--clause-columns (match-string 1 text) (point))))
|
|
(when (and cols (not (memq (current-indentation) cols)))
|
|
(indent-line-to (car cols))))))))
|
|
;; The new line was indented from the old one before it moved.
|
|
(when (memq last-command-event '(?\n ?\r))
|
|
(let ((c (car (flan-fln--indent-candidates (point)))))
|
|
(when (and c (= (current-column) (current-indentation)))
|
|
(indent-line-to c))))))
|
|
|
|
(defun flan-fln-shift-right (start end &optional n)
|
|
"Shift the lines of the region, or the line, right by N block levels."
|
|
(interactive (if (use-region-p)
|
|
(list (region-beginning) (region-end) (prefix-numeric-value current-prefix-arg))
|
|
(list (line-beginning-position) (line-end-position)
|
|
(prefix-numeric-value current-prefix-arg))))
|
|
(let ((deactivate-mark nil))
|
|
(indent-rigidly (flan-fln--bol start) end (* (or n 1) flan-fln-indent-offset))))
|
|
|
|
(defun flan-fln-shift-left (start end &optional n)
|
|
"Shift the lines of the region, or the line, left by N block levels."
|
|
(interactive (if (use-region-p)
|
|
(list (region-beginning) (region-end) (prefix-numeric-value current-prefix-arg))
|
|
(list (line-beginning-position) (line-end-position)
|
|
(prefix-numeric-value current-prefix-arg))))
|
|
(let ((deactivate-mark nil))
|
|
(indent-rigidly (flan-fln--bol start) end (- (* (or n 1) flan-fln-indent-offset)))))
|
|
|
|
(defun flan-fln--yank-base (start end first-ws)
|
|
"The column the yanked text between START and END was written at.
|
|
FIRST-WS is the width of its first line's own indentation, when it kept one."
|
|
(if (> first-ws 0)
|
|
first-ws
|
|
;; The first line was cut from its first character: read the column off
|
|
;; the lines under it. A clause sits at the statement's column; failing
|
|
;; one, the shallowest line is a body, one level in.
|
|
(let (min clause)
|
|
(save-excursion
|
|
(goto-char start)
|
|
(while (and (zerop (forward-line 1)) (< (point) end))
|
|
(unless (flan-fln--blank-p (point))
|
|
(let ((i (current-indentation)))
|
|
(when (or (null min) (< i min)) (setq min i clause nil))
|
|
(when (and (= i min)
|
|
(save-excursion (back-to-indentation)
|
|
(looking-at flan-fln--clause-re)))
|
|
(setq clause t))))))
|
|
(cond ((null min) 0)
|
|
(clause min)
|
|
(t (max 0 (- min flan-fln-indent-offset)))))))
|
|
|
|
(defun flan-fln-yank (&optional arg)
|
|
"Yank, then move the lines after the first with it, rigidly.
|
|
The first line lands at point; every other line keeps its place relative to
|
|
it, so a block pasted at another depth stays one block."
|
|
(interactive "*P")
|
|
(let* ((col (current-column))
|
|
(at-indent (<= col (current-indentation))))
|
|
(setq this-command 'yank)
|
|
(yank arg)
|
|
(let ((end (copy-marker (max (point) (mark t))))
|
|
(start (min (point) (mark t))))
|
|
(save-excursion
|
|
(goto-char start)
|
|
(when (< (line-end-position) end)
|
|
(let* ((ws (save-excursion (skip-chars-forward " \t") (- (point) start)))
|
|
(base (flan-fln--yank-base start end ws)))
|
|
(when (and at-indent (> ws 0))
|
|
(delete-region start (+ start ws)))
|
|
(forward-line 1)
|
|
(when (< (point) end)
|
|
(indent-rigidly (point) end (- col base))))))
|
|
(set-marker end nil))))
|
|
|
|
;;; Block editing
|
|
|
|
(defun flan-fln--ensure-final-newline ()
|
|
(save-excursion
|
|
(goto-char (point-max))
|
|
(unless (bolp) (insert "\n"))))
|
|
|
|
(defun flan-fln--lines (start last)
|
|
"(BEG . END) of the whole lines START through LAST, final newline included."
|
|
(cons start (save-excursion (goto-char last) (line-beginning-position 2))))
|
|
|
|
(defun flan-fln--statement-lines (s)
|
|
(flan-fln--lines s (flan-fln--statement-last s)))
|
|
|
|
(defun flan-fln-kill-statement ()
|
|
"Kill the statement at point, whole lines, body and clauses included."
|
|
(interactive)
|
|
(flan-fln--ensure-final-newline)
|
|
(let ((s (flan-fln--statement-start-at (point))))
|
|
(unless s (user-error "flan: no statement at point"))
|
|
(let ((l (flan-fln--statement-lines s)))
|
|
(kill-region (car l) (cdr l)))))
|
|
|
|
(defun flan-fln--sibling (s dir)
|
|
"The statement next to S at its level: before it when DIR is -1, else after."
|
|
(let ((ind (flan-fln--indent-at s)))
|
|
(if (< dir 0)
|
|
(let ((p (flan-fln--prev-code s)) hit)
|
|
(while (and p (not hit))
|
|
(setq p (flan-fln--logical-start p))
|
|
(let ((i (flan-fln--indent-at p)))
|
|
(cond ((< i ind) (setq p nil))
|
|
((= i ind) (setq hit (flan-fln--clause-header p)))
|
|
(t (setq p (flan-fln--prev-code p))))))
|
|
hit)
|
|
(let ((n (flan-fln--next-code (flan-fln--statement-last s))))
|
|
(and n (= (flan-fln--indent-at n) ind)
|
|
(not (flan-fln--clause-line-p n))
|
|
n)))))
|
|
|
|
(defun flan-fln--swap (a b)
|
|
"Swap the whole-line statements A and B, A above B; keep point in its own."
|
|
(let* ((la (flan-fln--statement-lines a))
|
|
(lb (flan-fln--statement-lines b))
|
|
(ta (buffer-substring (car la) (cdr la)))
|
|
(gap (buffer-substring (cdr la) (car lb)))
|
|
(tb (buffer-substring (car lb) (cdr lb)))
|
|
(in-b (>= (point) (car lb)))
|
|
(off (- (point) (if in-b (car lb) (car la)))))
|
|
(goto-char (car la))
|
|
(delete-region (car la) (cdr lb))
|
|
(insert tb gap ta)
|
|
(goto-char (+ (car la) off (if in-b 0 (+ (length tb) (length gap)))))))
|
|
|
|
(defun flan-fln-move-statement-up ()
|
|
"Swap the statement at point with the one before it at its level."
|
|
(interactive)
|
|
(flan-fln--ensure-final-newline)
|
|
(let* ((s (flan-fln--statement-start-at (point)))
|
|
(p (and s (flan-fln--sibling s -1))))
|
|
(unless p (user-error "flan: no statement above this one at its level"))
|
|
(flan-fln--swap p s)))
|
|
|
|
(defun flan-fln-move-statement-down ()
|
|
"Swap the statement at point with the one after it at its level."
|
|
(interactive)
|
|
(flan-fln--ensure-final-newline)
|
|
(let* ((s (flan-fln--statement-start-at (point)))
|
|
(n (and s (flan-fln--sibling s 1))))
|
|
(unless n (user-error "flan: no statement below this one at its level"))
|
|
(flan-fln--swap s n)))
|
|
|
|
(defun flan-fln--owner (pos)
|
|
"The line that owns the block POS is in or opens: a header with a body."
|
|
(let ((s (flan-fln--statement-start-at pos)))
|
|
(cond ((null s) nil)
|
|
((flan-fln--body-bounds (flan-fln--line-statement pos))
|
|
(flan-fln--line-statement pos))
|
|
(t (flan-fln--parent (flan-fln--line-statement pos))))))
|
|
|
|
(defun flan-fln--shift-lines (l delta)
|
|
(indent-rigidly (car l) (cdr l) delta))
|
|
|
|
(defun flan-fln-slurp ()
|
|
"Pull the statement after this block into it, as its last statement."
|
|
(interactive)
|
|
(flan-fln--ensure-final-newline)
|
|
(let* ((o (or (flan-fln--owner (point)) (user-error "flan: no block here")))
|
|
(last (flan-fln--statement-last o t))
|
|
(n (flan-fln--next-code last))
|
|
(body (flan-fln--body-bounds o)))
|
|
(unless (and n (= (flan-fln--indent-at n) (flan-fln--indent-at o))
|
|
(not (flan-fln--clause-line-p n)))
|
|
(user-error "flan: no statement after this block to pull in"))
|
|
(save-excursion
|
|
(flan-fln--shift-lines (flan-fln--statement-lines n)
|
|
(- (flan-fln--indent-at (car body))
|
|
(flan-fln--indent-at o))))))
|
|
|
|
(defun flan-fln-barf ()
|
|
"Push this block's last statement out, to follow the block."
|
|
(interactive)
|
|
(flan-fln--ensure-final-newline)
|
|
(let* ((o (or (flan-fln--owner (point)) (user-error "flan: no block here")))
|
|
(body (flan-fln--body-bounds o))
|
|
(ind (flan-fln--indent-at (car body)))
|
|
(last (flan-fln--statement-last o t))
|
|
(after (flan-fln--next-code last))
|
|
(child (flan-fln--bol (car body))) c)
|
|
(when (and after (= (flan-fln--indent-at after) (flan-fln--indent-at o))
|
|
(flan-fln--clause-line-p after))
|
|
(user-error "flan: a clause follows this block; its last statement cannot leave it"))
|
|
(while (setq c (flan-fln--sibling child 1)) (setq child c))
|
|
(when (= (flan-fln--bol child) (flan-fln--bol (car body)))
|
|
(user-error "flan: this block has one statement; pushing it out would empty it"))
|
|
(save-excursion
|
|
(flan-fln--shift-lines (flan-fln--statement-lines child)
|
|
(- (flan-fln--indent-at o) ind)))))
|
|
|
|
(defun flan-fln-raise-statement ()
|
|
"Replace the statement that owns this block with the statement at point."
|
|
(interactive)
|
|
(flan-fln--ensure-final-newline)
|
|
(let* ((s (or (flan-fln--statement-start-at (point))
|
|
(user-error "flan: no statement at point")))
|
|
(o (or (flan-fln--parent s) (user-error "flan: at top level")))
|
|
(h (flan-fln--clause-header o))
|
|
(ls (flan-fln--statement-lines s))
|
|
(lh (flan-fln--statement-lines h))
|
|
(text (buffer-substring (car ls) (cdr ls)))
|
|
(delta (- (flan-fln--indent-at h) (flan-fln--indent-at s))))
|
|
(goto-char (car lh))
|
|
(delete-region (car lh) (cdr lh))
|
|
(let ((beg (point)))
|
|
(insert text)
|
|
(indent-rigidly beg (point) delta)
|
|
(goto-char beg)
|
|
(back-to-indentation))))
|
|
|
|
;;; Font lock
|
|
|
|
(defconst flan-fln--name-re "\\([^][ \t\n(){},;\":]+\\)"
|
|
"A declared name: a run up to a bracket, a space, or the colon of `x: T'.")
|
|
|
|
(defvar flan-fln-font-lock-keywords
|
|
`(;; The header words, at the start of a line and followed by a space or the
|
|
;; end of it: `if(c, a)' is the fallback call and is not a header.
|
|
(,(concat "^[ \t]*" (regexp-opt flan-fln--header-words t) "\\(?:[ \t]\\|$\\)")
|
|
1 font-lock-keyword-face)
|
|
(,(concat "^\\(fn-?\\)[ \t]+" flan-fln--name-re)
|
|
2 font-lock-function-name-face)
|
|
(,(concat "^\\(?:struct\\|data\\|union\\|enum\\)[ \t]+" flan-fln--name-re)
|
|
1 font-lock-type-face)
|
|
(,(concat "^\\(?:def\\|once\\|const\\)[ \t]+" flan-fln--name-re)
|
|
1 font-lock-variable-name-face)
|
|
;; The words inside a line: `for i in range(n)', `if c then a else b', a
|
|
;; `where' constraint.
|
|
("[ \t]\\(then\\|else\\|in\\|where\\)[ \t]" 1 font-lock-keyword-face)
|
|
;; The operator words.
|
|
("\\_<\\(and\\|or\\|not\\)\\_>" 1 font-lock-keyword-face)
|
|
(,(concat "\\_<" (regexp-opt flan--constants t) "\\_>")
|
|
1 font-lock-constant-face)
|
|
;; A keyword. `x:' is a name with a colon glued on, not one.
|
|
("\\(?:^\\|[][ \t(){},]\\)\\(:[^][ \t\n(){},;\":]+\\)" 1 font-lock-constant-face)
|
|
;; A type: after the `: ' of an annotation and after `-> '.
|
|
("[^ \t\n:]:[ \t]+\\([$a-zA-Z][^][ \t\n(){},;\"=]*\\)" 1 font-lock-type-face)
|
|
("[ \t]->[ \t]+\\([$a-zA-Z][^][ \t\n(){},;\"=]*\\)" 1 font-lock-type-face)
|
|
;; The package half of a qualified name, as `flan-mode' draws it.
|
|
("\\_<\\([a-zA-Z][a-zA-Z0-9!?*+=<>._-]*/\\)" 1 font-lock-type-face)
|
|
("\\_<\\(?:[iu]\\(?:8\\|16\\|32\\|64\\)\\|f\\(?:32\\|64\\)\\|bool\\|string\\|dyn\\|Never\\|Allocator\\|Ptr\\|Option\\|Vec\\|Map\\|C?Fn\\)\\_>"
|
|
. font-lock-type-face)
|
|
("\\_<\\$[^][ \t\n(){},;\":]*" . font-lock-type-face)
|
|
;; A character literal, `\c' or `\space'.
|
|
("\\\\\\(?:space\\|newline\\|tab\\|return\\|[^ \t\n]\\)" . font-lock-string-face)
|
|
("\\_<-?[0-9][0-9a-fA-FxX_.]*\\_>" . 'font-lock-number-face))
|
|
"Font lock for `flan-fln-mode'.")
|
|
|
|
(defvar flan-fln-imenu-generic-expression
|
|
`(("Functions" ,(concat "^fn-?[ \t]+" flan-fln--name-re) 1)
|
|
("Macros" ,(concat "^defmacro(" flan-fln--name-re) 1)
|
|
("Types" ,(concat "^\\(?:struct\\|data\\|union\\|enum\\)[ \t]+" flan-fln--name-re) 1)
|
|
("Variables" ,(concat "^\\(?:def\\|once\\|const\\)[ \t]+" flan-fln--name-re) 1))
|
|
"Imenu index for `flan-fln-mode'.")
|
|
|
|
(defun flan-fln-current-defun-name ()
|
|
"The name the top-level form at point declares, or nil."
|
|
(let ((s (flan-fln--toplevel-start (point))))
|
|
(when s
|
|
(save-excursion
|
|
(goto-char s)
|
|
(and (looking-at (concat "\\(?:fn-?\\|def\\|once\\|const\\|struct\\|data\\|union\\|enum\\)[ \t]+"
|
|
flan-fln--name-re))
|
|
(match-string-no-properties 1))))))
|
|
|
|
;;; The mode
|
|
|
|
(defvar flan-fln-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(set-keymap-parent map flan-base-mode-map)
|
|
(define-key map (kbd "C-c C-c") #'flan-fln-eval-defun)
|
|
(define-key map (kbd "C-M-x") #'flan-fln-eval-defun)
|
|
(define-key map (kbd "C-x C-e") #'flan-fln-eval-last)
|
|
(define-key map (kbd "C-c C-e") #'flan-fln-eval-statement)
|
|
(define-key map (kbd "C-c C-n") #'flan-fln-eval-statement-and-next)
|
|
;; 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--with-trailing-blanks (b)
|
|
"B's whole lines and the blank lines after them.
|
|
With none after -- the last form -- the blank lines before it instead, as
|
|
Vim's `dap' does, so the buffer does not end in empty lines."
|
|
(and b (let ((n (flan-fln--next-code (1- (cdr b)))))
|
|
(if n
|
|
(cons (car b) n)
|
|
(let ((p (flan-fln--prev-code (car b))))
|
|
(cons (if p (save-excursion (goto-char p) (line-beginning-position 2))
|
|
(car b))
|
|
(point-max)))))))
|
|
|
|
(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."
|
|
(flan-fln--evil (flan-fln--whole-lines
|
|
(bounds-of-thing-at-point 'flan-fln-statement))
|
|
'line))
|
|
(evil-define-text-object flan-fln-inner-body (count &optional _beg _end _type)
|
|
"A statement's block, its lines."
|
|
(flan-fln--evil (flan-fln--whole-lines
|
|
(bounds-of-thing-at-point 'flan-fln-body))
|
|
'line))
|
|
(evil-define-text-object flan-fln-a-body (count &optional _beg _end _type)
|
|
"The whole statement the block belongs to, its lines."
|
|
(flan-fln--evil (flan-fln--whole-lines
|
|
(bounds-of-thing-at-point 'flan-fln-statement))
|
|
'line))
|
|
(evil-define-text-object flan-fln-inner-clause (count &optional _beg _end _type)
|
|
"A clause's block, its lines; a match arm's value when it is on the line."
|
|
(let* ((c (flan-fln--clause-at (point)))
|
|
(arm (and c (flan-fln--arm c)))
|
|
(v (and arm (plist-get arm :value))))
|
|
(if (and v (= (flan-fln--bol (car v)) c))
|
|
(flan-fln--evil v 'exclusive)
|
|
(flan-fln--evil (flan-fln--whole-lines (and c (flan-fln--body-bounds c)))
|
|
'line))))
|
|
(evil-define-text-object flan-fln-a-clause (count &optional _beg _end _type)
|
|
"A clause: its line and its block."
|
|
(flan-fln--evil (flan-fln--whole-lines
|
|
(bounds-of-thing-at-point 'flan-fln-clause))
|
|
'line))
|
|
(evil-define-text-object flan-fln-inner-toplevel (count &optional _beg _end _type)
|
|
"A top-level form, its lines."
|
|
(flan-fln--evil (flan-fln--whole-lines
|
|
(bounds-of-thing-at-point 'flan-fln-toplevel))
|
|
'line))
|
|
(evil-define-text-object flan-fln-a-toplevel (count &optional _beg _end _type)
|
|
"A top-level form and the blank lines after it."
|
|
(flan-fln--evil (flan-fln--with-trailing-blanks
|
|
(flan-fln--whole-lines
|
|
(bounds-of-thing-at-point 'flan-fln-toplevel)))
|
|
'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
|