;;; smie.el --- Simple Minded Indentation Engine -*- lexical-binding: t -*-
-;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2014 Free Software Foundation, Inc.
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Keywords: languages, lisp, internal, parsing, indentation
;; building the 2D precedence tables and then computing the precedence levels
;; from it) can be found in pages 187-194 of "Parsing techniques" by Dick Grune
;; and Ceriel Jacobs (BookBody.pdf available at
-;; http://www.cs.vu.nl/~dick/PTAPG.html).
+;; http://dickgrune.com/Books/PTAPG_1st_Edition/).
;;
;; OTOH we had to kill many chickens, read many coffee grounds, and practice
;; untold numbers of black magic spells, to come up with the indentation code.
;; (exp ("IF" exp "ELSE" exp "END") ("CASE" cases "END"))
;; (cases (cases "ELSE" insts) ...)
;; The IF-rule implies ELSE=END and the CASE-rule implies ELSE>END.
-;; FIXME: we could try to resolve such conflicts automatically by changing
-;; the way BNF rules such as the IF-rule is handled. I.e. rather than
-;; IF=ELSE and ELSE=END, we could turn them into IF<ELSE and ELSE>END
-;; and IF=END,
+;; This can be resolved simply with:
+;; (exp ("IF" expelseexp "END") ("CASE" cases "END"))
+;; (expelseexp (exp) (exp "ELSE" exp))
+;; (cases (cases "ELSE" insts) ...)
+;; - Another source of conflict is when a terminator/separator is used to
+;; terminate elements at different levels, as in:
+;; (decls ("VAR" vars) (decls "," decls))
+;; (vars (id) (vars "," vars))
+;; often these can be resolved by making the lexer distinguish the two
+;; kinds of commas, e.g. based on the following token.
;; TODO & BUGS:
;;
+;; - We could try to resolve conflicts such as the IFexpELSEexpEND -vs-
+;; CASE(casesELSEexp)END automatically by changing the way BNF rules such as
+;; the IF-rule is handled. I.e. rather than IF=ELSE and ELSE=END, we could
+;; turn them into IF<ELSE and ELSE>END and IF=END.
;; - Using the structural information SMIE gives us, it should be possible to
;; implement a `smie-align' command that would automatically figure out what
;; there is to align and how to do it (something like: align the token of
;; - Maybe accept two juxtaposed non-terminals in the BNF under the condition
;; that the first always ends with a terminal, or that the second always
;; starts with a terminal.
+;; - Permit EBNF-style notation.
+;; - If the grammar has conflicts, the only way is to make the lexer return
+;; different tokens for the different cases. This extra work performed by
+;; the lexer can be costly and unnecessary: we perform this extra work every
+;; time we find the conflicting token, regardless of whether or not the
+;; difference between the various situations is relevant to the current
+;; situation. E.g. we may try to determine whether a ";" is a ";-operator"
+;; or a ";-separator" in a case where we're skipping over a "begin..end" pair
+;; where the difference doesn't matter. For frequently occurring tokens and
+;; rarely occurring conflicts, this can be a significant performance problem.
+;; We could try and let the lexer return a "set of possible tokens
+;; plus a refinement function" and then let parser call the refinement
+;; function if needed.
+;; - Make it possible to better specify the behavior in the face of
+;; syntax errors. IOW provide some control over the choice of precedence
+;; levels within the limits of the constraints. E.g. make it possible for
+;; the grammar to specify that "begin..end" has lower precedence than
+;; "Module..EndModule", so that if a "begin" is missing, scanning from the
+;; "end" will stop at "Module" rather than going past it (and similarly,
+;; scanning from "Module" should not stop at a spurious "end").
;;; Code:
-(eval-when-compile (require 'cl))
+;; FIXME:
+;; - smie-indent-comment doesn't interact well with mis-indented lines (where
+;; the indent rules don't do what the user wants). Not sure what to do.
+
+(eval-when-compile (require 'cl-lib))
(defgroup smie nil
"Simple Minded Indentation Engine."
;; - a 2 dimensional precedence table (key word "prec2"), is a 2D
;; table recording the precedence relation (can be `<', `=', `>', or
;; nil) between each pair of tokens.
-;; - a precedence-level table (key word "grammar"), which is a alist
+;; - a precedence-level table (key word "grammar"), which is an alist
;; giving for each token its left and right precedence level (a
;; number or nil). This is used in `smie-grammar'.
;; The prec2 tables are only intermediate data structures: the source
;; turns them into a levels table, which is what's used by the rest of
;; the SMIE code.
+(defvar smie-warning-count 0)
+
(defun smie-set-prec2tab (table x y val &optional override)
- (assert (and x y))
+ (cl-assert (and x y))
(let* ((key (cons x y))
(old (gethash key table)))
(if (and old (not (eq old val)))
;; be able to distinguish the two cases so that overrides
;; don't hide real conflicts.
(puthash key (gethash key override) table)
- (display-warning 'smie (format "Conflict: %s %s/%s %s" x old val y)))
+ (display-warning 'smie (format "Conflict: %s %s/%s %s" x old val y))
+ (cl-incf smie-warning-count))
(puthash key val table))))
(put 'smie-precs->prec2 'pure t)
prec2)))
(put 'smie-bnf->prec2 'pure t)
-(defun smie-bnf->prec2 (bnf &rest precs)
+(defun smie-bnf->prec2 (bnf &rest resolvers)
+ "Convert the BNF grammar into a prec2 table.
+BNF is a list of nonterminal definitions of the form:
+ \(NONTERM RHS1 RHS2 ...)
+where each RHS is a (non-empty) list of terminals (aka tokens) or non-terminals.
+Not all grammars are accepted:
+- an RHS cannot be an empty list (this is not needed, since SMIE allows all
+ non-terminals to match the empty string anyway).
+- an RHS cannot have 2 consecutive non-terminals: between each non-terminal
+ needs to be a terminal (aka token). This is a fundamental limitation of
+ the parsing technology used (operator precedence grammar).
+Additionally, conflicts can occur:
+- The returned prec2 table holds constraints between pairs of
+ token, and for any given pair only one constraint can be
+ present, either: T1 < T2, T1 = T2, or T1 > T2.
+- A token can either be an `opener' (something similar to an open-paren),
+ a `closer' (like a close-paren), or `neither' of the two (e.g. an infix
+ operator, or an inner token like \"else\").
+Conflicts can be resolved via RESOLVERS, which is a list of elements that can
+be either:
+- a precs table (see `smie-precs->prec2') to resolve conflicting constraints,
+- a constraint (T1 REL T2) where REL is one of = < or >."
;; FIXME: Add repetition operator like (repeat <separator> <elems>).
;; Maybe also add (or <elem1> <elem2>...) for things like
;; (exp (exp (or "+" "*" "=" ..) exp)).
;; Basically, make it EBNF (except for the specification of a separator in
;; the repetition, maybe).
- (let ((nts (mapcar 'car bnf)) ;Non-terminals
- (first-ops-table ())
- (last-ops-table ())
- (first-nts-table ())
- (last-nts-table ())
- (prec2 (make-hash-table :test 'equal))
- (override (apply 'smie-merge-prec2s
- (mapcar 'smie-precs->prec2 precs)))
- again)
+ (let* ((nts (mapcar 'car bnf)) ;Non-terminals.
+ (first-ops-table ())
+ (last-ops-table ())
+ (first-nts-table ())
+ (last-nts-table ())
+ (smie-warning-count 0)
+ (prec2 (make-hash-table :test 'equal))
+ (override
+ (let ((precs ())
+ (over (make-hash-table :test 'equal)))
+ (dolist (resolver resolvers)
+ (cond
+ ((and (= 3 (length resolver)) (memq (nth 1 resolver) '(= < >)))
+ (smie-set-prec2tab
+ over (nth 0 resolver) (nth 2 resolver) (nth 1 resolver)))
+ ((memq (caar resolver) '(left right assoc nonassoc))
+ (push resolver precs))
+ (t (error "Unknown resolver %S" resolver))))
+ (apply #'smie-merge-prec2s over
+ (mapcar 'smie-precs->prec2 precs))))
+ again)
(dolist (rules bnf)
(let ((nt (car rules))
(last-ops ())
(unless (consp rhs)
(signal 'wrong-type-argument `(consp ,rhs)))
(if (not (member (car rhs) nts))
- (pushnew (car rhs) first-ops)
- (pushnew (car rhs) first-nts)
+ (cl-pushnew (car rhs) first-ops)
+ (cl-pushnew (car rhs) first-nts)
(when (consp (cdr rhs))
;; If the first is not an OP we add the second (which
;; should be an OP if BNF is an "operator grammar").
;; the trouble, and it lets the writer of the BNF
;; be a bit more sloppy by skipping uninteresting base
;; cases which are terminals but not OPs.
- (assert (not (member (cadr rhs) nts)))
- (pushnew (cadr rhs) first-ops)))
+ (when (member (cadr rhs) nts)
+ (error "Adjacent non-terminals: %s %s"
+ (car rhs) (cadr rhs)))
+ (cl-pushnew (cadr rhs) first-ops)))
(let ((shr (reverse rhs)))
(if (not (member (car shr) nts))
- (pushnew (car shr) last-ops)
- (pushnew (car shr) last-nts)
+ (cl-pushnew (car shr) last-ops)
+ (cl-pushnew (car shr) last-nts)
(when (consp (cdr shr))
- (assert (not (member (cadr shr) nts)))
- (pushnew (cadr shr) last-ops)))))
+ (when (member (cadr shr) nts)
+ (error "Adjacent non-terminals: %s %s"
+ (cadr shr) (car shr)))
+ (cl-pushnew (cadr shr) last-ops)))))
(push (cons nt first-ops) first-ops-table)
(push (cons nt last-ops) last-ops-table)
(push (cons nt first-nts) first-nts-table)
(setq rhs (cdr rhs)))))
;; Keep track of which tokens are openers/closer, so they can get a nil
;; precedence in smie-prec2->grammar.
- (puthash :smie-open/close-alist (smie-bnf-classify bnf) prec2)
- (puthash :smie-closer-alist (smie-bnf-closer-alist bnf) prec2)
+ (puthash :smie-open/close-alist (smie-bnf--classify bnf) prec2)
+ (puthash :smie-closer-alist (smie-bnf--closer-alist bnf) prec2)
+ (if (> smie-warning-count 0)
+ (display-warning
+ 'smie (format "Total: %d warnings" smie-warning-count)))
prec2))
;; (defun smie-prec2-closer-alist (prec2 include-inners)
;; openers)
;; alist)))
-(defun smie-bnf-closer-alist (bnf &optional no-inners)
+(defun smie-bnf--closer-alist (bnf &optional no-inners)
;; We can also build this closer-alist table from a prec2 table,
;; but it takes more work, and the order is unpredictable, which
;; is a problem for smie-close-block.
(if no-inners
(let ((last (car (last rhs))))
(unless (member last nts)
- (pushnew (cons (car rhs) last) alist :test #'equal)))
+ (cl-pushnew (cons (car rhs) last) alist :test #'equal)))
;; Reverse so that the "real" closer gets there first,
;; which is important for smie-close-block.
(dolist (term (reverse (cdr rhs)))
(unless (member term nts)
- (pushnew (cons (car rhs) term) alist :test #'equal)))))))
+ (cl-pushnew (cons (car rhs) term) alist :test #'equal)))))))
(nreverse alist)))
-(defun smie-bnf-classify (bnf)
+(defun smie-bnf--set-class (table token class)
+ (let ((prev (gethash token table class)))
+ (puthash token
+ (cond
+ ((eq prev class) class)
+ ((eq prev t) t) ;Non-terminal.
+ (t (display-warning
+ 'smie
+ (format "token %s is both %s and %s" token class prev))
+ 'neither))
+ table)))
+
+(defun smie-bnf--classify (bnf)
"Return a table classifying terminals.
-Each terminal can either be an `opener', a `closer', or neither."
+Each terminal can either be an `opener', a `closer', or `neither'."
(let ((table (make-hash-table :test #'equal))
- (nts (mapcar #'car bnf))
(alist '()))
(dolist (category bnf)
- (puthash (car category) 'neither table) ;Remove non-terminals.
+ (puthash (car category) t table)) ;Mark non-terminals.
+ (dolist (category bnf)
(dolist (rhs (cdr category))
(if (null (cdr rhs))
- (puthash (pop rhs) 'neither table)
- (let ((first (pop rhs)))
- (puthash first
- (if (memq (gethash first table) '(nil opener))
- 'opener
- (unless (member first nts)
- (error "SMIE: token %s is both opener and non-opener"
- first))
- 'neither)
- table))
- (while (cdr rhs)
- (puthash (pop rhs) 'neither table)) ;Remove internals.
- (let ((last (pop rhs)))
- (puthash last
- (if (memq (gethash last table) '(nil closer))
- 'closer
- (unless (member last nts)
- (error "SMIE: token %s is both closer and non-closer"
- last))
- 'neither)
- table)))))
+ (smie-bnf--set-class table (pop rhs) 'neither)
+ (smie-bnf--set-class table (pop rhs) 'opener)
+ (while (cdr rhs) ;Remove internals.
+ (smie-bnf--set-class table (pop rhs) 'neither))
+ (smie-bnf--set-class table (pop rhs) 'closer))))
(maphash (lambda (tok v)
(when (memq v '(closer opener))
(push (cons tok v) alist)))
(push (concat "." (car elem)) res))
(if (eq (cddr elem) val)
(push (concat (car elem) ".") res)))
- (assert res)
+ (cl-assert res)
res))
cycle)))
(mapconcat
;; (right (nth 1 (assoc (cdr k) grammar))))
;; (when (and left right)
;; (cond
-;; ((< left right) (assert (eq v '<)))
-;; ((> left right) (assert (eq v '>)))
-;; (t (assert (eq v '=))))))))
+;; ((< left right) (cl-assert (eq v '<)))
+;; ((> left right) (cl-assert (eq v '>)))
+;; (t (cl-assert (eq v '=))))))))
;; prec2))
(put 'smie-prec2->grammar 'pure t)
;; final `table'. The value of each "variable" is kept in the `car'.
(let ((table ())
(csts ())
- (eqs ())
- tmp x y)
+ (eqs ()))
;; From `prec2' we construct a list of constraints between
;; variables (aka "precedence levels"). These can be either
;; equality constraints (in `eqs') or `<' constraints (in `csts').
(maphash (lambda (k v)
(when (consp k)
- (if (setq tmp (assoc (car k) table))
- (setq x (cddr tmp))
- (setq x (cons nil nil))
- (push (cons (car k) (cons nil x)) table))
- (if (setq tmp (assoc (cdr k) table))
- (setq y (cdr tmp))
- (setq y (cons nil (cons nil nil)))
- (push (cons (cdr k) y) table))
- (ecase v
- (= (push (cons x y) eqs))
- (< (push (cons x y) csts))
- (> (push (cons y x) csts)))))
+ (let ((tmp (assoc (car k) table))
+ x y)
+ (if tmp
+ (setq x (cddr tmp))
+ (setq x (cons nil nil))
+ (push (cons (car k) (cons nil x)) table))
+ (if (setq tmp (assoc (cdr k) table))
+ (setq y (cdr tmp))
+ (setq y (cons nil (cons nil nil)))
+ (push (cons (cdr k) y) table))
+ (pcase v
+ (`= (push (cons x y) eqs))
+ (`< (push (cons x y) csts))
+ (`> (push (cons y x) csts))
+ (_ (error "SMIE error: prec2 has %S↦%S which ∉ {<,+,>}"
+ k v))))))
prec2)
;; First process the equality constraints.
(let ((eqs eqs))
(unless (caar cst)
(setcar (car cst) i)
;; (smie-check-grammar table prec2 'step1)
- (incf i))
+ (cl-incf i))
(setq csts (delq cst csts))))
(unless progress
(error "Can't resolve the precedence cycle: %s"
(smie-debug--describe-cycle
table (smie-debug--prec2-cycle csts)))))
- (incf i 10))
- ;; Propagate equalities back to their source.
+ (cl-incf i 10))
+ ;; Propagate equality constraints back to their sources.
(dolist (eq (nreverse eqs))
(when (null (cadr eq))
;; There's an equality constraint, but we still haven't given
;; So set it here rather than below since doing it below
;; makes it more difficult to obey the equality constraints.
(setcar (cdr eq) i)
- (incf i))
- (assert (or (null (caar eq)) (eq (caar eq) (cadr eq))))
+ (cl-incf i))
+ (cl-assert (or (null (caar eq)) (eq (caar eq) (cadr eq))))
(setcar (car eq) (cadr eq))
;; (smie-check-grammar table prec2 'step2)
)
(dolist (x table)
(unless (nth 1 x)
(setf (nth 1 x) i)
- (incf i)) ;See other (incf i) above.
+ (cl-incf i)) ;See other (cl-incf i) above.
(unless (nth 2 x)
(setf (nth 2 x) i)
- (incf i)))) ;See other (incf i) above.
+ (cl-incf i)))) ;See other (cl-incf i) above.
;; Mark closers and openers.
(dolist (x (gethash :smie-open/close-alist prec2))
(let* ((token (car x))
- (cons (case (cdr x)
- (closer (cddr (assoc token table)))
- (opener (cdr (assoc token table))))))
- (assert (numberp (car cons)))
+ (cons (pcase (cdr x)
+ (`closer (cddr (assoc token table)))
+ (`opener (cdr (assoc token table))))))
+ (cl-assert (numberp (car cons)))
(setf (car cons) (list (car cons)))))
(let ((ca (gethash :smie-closer-alist prec2)))
(when ca (push (cons :smie-closer-alist ca) table)))
is too high. FORW-LEVEL is the forw-level of TOKEN,
POS is its start position in the buffer.
(t POS TOKEN): same thing when we bump on the wrong side of a paren.
+ Instead of t, the `car' can also be some other non-nil non-number value.
(nil POS TOKEN): we skipped over a paren-like pair.
nil: we skipped over an identifier, matched parentheses, ..."
(catch 'return
((null toklevels)
(when (zerop (length token))
(condition-case err
- (progn (goto-char pos) (funcall next-sexp 1) nil)
- (scan-error (throw 'return
- (list t (caddr err)
- (buffer-substring-no-properties
- (caddr err)
- (+ (caddr err)
- (if (< (point) (caddr err))
- -1 1)))))))
+ (progn (funcall next-sexp 1) nil)
+ (scan-error
+ (let* ((epos1 (nth 2 err))
+ (epos (if (<= (point) epos1) (nth 3 err) epos1)))
+ (goto-char pos)
+ (throw 'return
+ (list t epos
+ (buffer-substring-no-properties
+ epos
+ (+ epos (if (< (point) epos) -1 1))))))))
(if (eq pos (point))
;; We did not move, so let's abort the loop.
(throw 'return (list t (point))))))
((not (numberp (funcall op-back toklevels)))
;; A token like a paren-close.
- (assert (numberp ; Otherwise, why mention it in smie-grammar.
- (funcall op-forw toklevels)))
+ (cl-assert (numberp ; Otherwise, why mention it in smie-grammar.
+ (funcall op-forw toklevels)))
(push toklevels levels))
(t
(while (and levels (< (funcall op-back toklevels)
(if (and halfsexp (numberp (funcall op-forw toklevels)))
(push toklevels levels)
(throw 'return
- (prog1 (list (or (car toklevels) t) (point) token)
+ (prog1 (list (or (funcall op-forw toklevels) t)
+ (point) token)
(goto-char pos)))))
(t
(let ((lastlevels levels))
;; Keep looking as long as we haven't matched the
;; topmost operator.
(levels
- (if (numberp (funcall op-forw toklevels))
- (push toklevels levels)))
+ (cond
+ ((numberp (funcall op-forw toklevels))
+ (push toklevels levels))
+ ;; FIXME: For some languages, we can express the grammar
+ ;; OK, but next-sexp doesn't stop where we'd want it to.
+ ;; E.g. in SML, we'd want to stop right in front of
+ ;; "local" if we're scanning (both forward and backward)
+ ;; from a "val/fun/..." at the same level.
+ ;; Same for Pascal/Modula2's "procedure" w.r.t
+ ;; "type/var/const".
+ ;;
+ ;; ((and (functionp (cadr (funcall op-forw toklevels)))
+ ;; (funcall (cadr (funcall op-forw toklevels))
+ ;; levels))
+ ;; (setq levels nil))
+ ))
;; We matched the topmost operator. If the new operator
;; is the last in the corresponding BNF rule, we're done.
((not (numberp (funcall op-forw toklevels)))
((and lastlevels
(smie--associative-p (car lastlevels)))
(throw 'return
- (prog1 (list (or (car toklevels) t) (point) token)
+ (prog1 (list (or (funcall op-forw toklevels) t)
+ (point) token)
(goto-char pos))))
;; - it's an associative operator within a larger construct
;; (e.g. an "elsif"), so we should just ignore it and keep
is too high. LEFT-LEVEL is the left-level of TOKEN,
POS is its start position in the buffer.
(t POS TOKEN): same thing but for an open-paren or the beginning of buffer.
+ Instead of t, the `car' can also be some other non-nil non-number value.
(nil POS TOKEN): we skipped over a paren-like pair.
nil: we skipped over an identifier, matched parentheses, ..."
(smie-next-sexp
(RIGHT-LEVEL POS TOKEN): we couldn't skip TOKEN because its left-level
is too high. RIGHT-LEVEL is the right-level of TOKEN,
POS is its end position in the buffer.
- (t POS TOKEN): same thing but for an open-paren or the beginning of buffer.
+ (t POS TOKEN): same thing but for a close-paren or the end of buffer.
+ Instead of t, the `car' can also be some other non-nil non-number value.
(nil POS TOKEN): we skipped over a paren-like pair.
nil: we skipped over an identifier, matched parentheses, ..."
(smie-next-sexp
(indirect-function 'smie-op-left)
halfsexp))
-;;; Miscellanous commands using the precedence parser.
+;;; Miscellaneous commands using the precedence parser.
(defun smie-backward-sexp-command (&optional n)
"Move backward through N logical elements."
(let ((ender (funcall smie-backward-token-function)))
(cond
((not (and ender (rassoc ender smie-closer-alist)))
- ;; This not is one of the begin..end we know how to check.
+ ;; This is not one of the begin..end we know how to check.
(blink-matching-check-mismatch start end))
((not start) t)
((eq t (car (rassoc ender smie-closer-alist))) nil)
(or (eq (char-before) last-command-event)
(not (memq (char-before)
smie-blink-matching-triggers)))
+ ;; FIXME: For octave's "switch ... case ... case" we flash
+ ;; `switch' at the end of the first `case' and we burp
+ ;; "mismatch" at the end of the second `case'.
(or smie-blink-matching-inners
(not (numberp (nth 2 (assoc token smie-grammar))))))
;; The major mode might set blink-matching-check-function
(let ((blink-matching-check-function #'smie-blink-matching-check))
(blink-matching-open))))))))
+(defvar-local smie--matching-block-data-cache nil)
+
+(defun smie--opener/closer-at-point ()
+ "Return (OPENER TOKEN START END) or nil.
+OPENER is non-nil if TOKEN is an opener and nil if it's a closer."
+ (let* ((start (point))
+ ;; Move to a previous position outside of a token.
+ (_ (funcall smie-backward-token-function))
+ ;; Move to the end of the token before point.
+ (btok (funcall smie-forward-token-function))
+ (bend (point)))
+ (cond
+ ;; Token before point is a closer?
+ ((and (>= bend start) (rassoc btok smie-closer-alist))
+ (funcall smie-backward-token-function)
+ (when (< (point) start)
+ (prog1 (list nil btok (point) bend)
+ (goto-char bend))))
+ ;; Token around point is an opener?
+ ((and (> bend start) (assoc btok smie-closer-alist))
+ (funcall smie-backward-token-function)
+ (when (<= (point) start) (list t btok (point) bend)))
+ ((<= bend start)
+ (let ((atok (funcall smie-forward-token-function))
+ (aend (point)))
+ (cond
+ ((< aend start) nil) ;Hopefully shouldn't happen.
+ ;; Token after point is a closer?
+ ((assoc atok smie-closer-alist)
+ (funcall smie-backward-token-function)
+ (when (<= (point) start)
+ (list t atok (point) aend)))))))))
+
+(defun smie--matching-block-data (orig &rest args)
+ "A function suitable for `show-paren-data-function' (which see)."
+ (if (or (null smie-closer-alist)
+ (equal (cons (point) (buffer-chars-modified-tick))
+ (car smie--matching-block-data-cache)))
+ (or (cdr smie--matching-block-data-cache)
+ (apply orig args))
+ (setq smie--matching-block-data-cache
+ (list (cons (point) (buffer-chars-modified-tick))))
+ (unless (nth 8 (syntax-ppss))
+ (condition-case nil
+ (let ((here (smie--opener/closer-at-point)))
+ (when (and here
+ (or smie-blink-matching-inners
+ (not (numberp
+ (nth (if (nth 0 here) 1 2)
+ (assoc (nth 1 here) smie-grammar))))))
+ (let ((there
+ (cond
+ ((car here) ; Opener.
+ (let ((data (smie-forward-sexp 'halfsexp))
+ (tend (point)))
+ (unless (car data)
+ (funcall smie-backward-token-function)
+ (list (member (cons (nth 1 here) (nth 2 data))
+ smie-closer-alist)
+ (point) tend))))
+ (t ;Closer.
+ (let ((data (smie-backward-sexp 'halfsexp))
+ (htok (nth 1 here)))
+ (if (car data)
+ (let* ((hprec (nth 2 (assoc htok smie-grammar)))
+ (ttok (nth 2 data))
+ (tprec (nth 1 (assoc ttok smie-grammar))))
+ (when (and (numberp hprec) ;Here is an inner.
+ (eq hprec tprec))
+ (goto-char (nth 1 data))
+ (let ((tbeg (point)))
+ (funcall smie-forward-token-function)
+ (list t tbeg (point)))))
+ (let ((tbeg (point)))
+ (funcall smie-forward-token-function)
+ (list (member (cons (nth 2 data) htok)
+ smie-closer-alist)
+ tbeg (point)))))))))
+ ;; Update the cache.
+ (setcdr smie--matching-block-data-cache
+ (list (nth 2 here) (nth 3 here)
+ (nth 1 there) (nth 2 there)
+ (not (nth 0 there)))))))
+ (scan-error nil))
+ (goto-char (caar smie--matching-block-data-cache)))
+ (apply #'smie--matching-block-data orig args)))
+
;;; The indentation engine.
(defcustom smie-indent-basic 4
- :list-intro, in which case ARG is a token and the function should return
non-nil if TOKEN is followed by a list of expressions (not separated by any
token) rather than an expression.
+- :close-all, in which case ARG is a close-paren token at indentation and
+ the function should return non-nil if it should be aligned with the opener
+ of the last close-paren token on the same line, if there are multiple.
+ Otherwise, it will be aligned with its own opener.
When ARG is a token, the function is called with point just before that token.
A return value of nil always means to fallback on the default behavior, so the
OFFSET can be:
nil use the default indentation rule.
-`(column . COLUMN) indent to column COLUMN.
+\(column . COLUMN) indent to column COLUMN.
NUMBER offset by NUMBER, relative to a base token
which is the current token for :after and
its parent for :before.
The functions whose name starts with \"smie-rule-\" are helper functions
designed specifically for use in this function.")
+(defvar smie--hanging-eolp-function
+ ;; FIXME: This is a quick hack for 24.4. Don't document it and replace with
+ ;; a well-defined function with a cleaner interface instead!
+ (lambda ()
+ (skip-chars-forward " \t")
+ (or (eolp)
+ (and ;; (looking-at comment-start-skip) ;(bug#16041).
+ (forward-comment (point-max))))))
+
(defalias 'smie-rule-hanging-p 'smie-indent--hanging-p)
(defun smie-indent--hanging-p ()
"Return non-nil if the current token is \"hanging\".
(save-excursion
(<= (line-end-position)
(progn
- (when (zerop (length (funcall smie-forward-token-function)))
- ;; Could be an open-paren.
- (forward-char 1))
- (skip-chars-forward " \t")
- (or (eolp)
- (and (looking-at comment-start-skip)
- (forward-comment (point-max))))
+ (and (zerop (length (funcall smie-forward-token-function)))
+ (not (eobp))
+ ;; Could be an open-paren.
+ (forward-char 1))
+ (funcall smie--hanging-eolp-function)
(point))))))
(defalias 'smie-rule-bolp 'smie-indent--bolp)
"Return non-nil if the current token is the first on the line."
(save-excursion (skip-chars-backward " \t") (bolp)))
+(defun smie-indent--bolp-1 ()
+ ;; Like smie-indent--bolp but also returns non-nil if it's the first
+ ;; non-comment token. Maybe we should simply always use this?
+ "Return non-nil if the current token is the first on the line.
+Comments are treated as spaces."
+ (let ((bol (line-beginning-position)))
+ (save-excursion
+ (forward-comment (- (point)))
+ (<= (point) bol))))
+
;; Dynamically scoped.
(defvar smie--parent) (defvar smie--after) (defvar smie--token)
(goto-char (cadr (smie-indent--parent)))
(cons 'column
(+ (or offset 0)
- ;; Use smie-indent-virtual when indenting relative to an opener:
- ;; this will also by default use current-column unless
- ;; that opener is hanging, but will additionally consult
- ;; rules-function, so it gives it a chance to tweak
- ;; indentation (e.g. by forcing indentation relative to
- ;; its own parent, as in fn a => fn b => fn c =>).
- (if (or (listp (car smie--parent)) (smie-indent--hanging-p))
- (smie-indent-virtual) (current-column))))))
+ (smie-indent-virtual)))))
(defvar smie-rule-separator-outdent 2)
(defun smie-indent--rule (method token
;; FIXME: Too many parameters.
&optional after parent base-pos)
- "Compute indentation column according to `indent-rule-functions'.
-METHOD and TOKEN are passed to `indent-rule-functions'.
+ "Compute indentation column according to `smie-rules-function'.
+METHOD and TOKEN are passed to `smie-rules-function'.
AFTER is the position after TOKEN, if known.
PARENT is the parent info returned by `smie-backward-sexp', if known.
BASE-POS is the position relative to which offsets should be applied."
;; - :after tok, where
;; ; after is set; parent=nil; base-pos=point;
(save-excursion
- (let ((offset
- (let ((smie--parent parent)
- (smie--token token)
- (smie--after after))
- (funcall smie-rules-function method token))))
+ (let ((offset (smie-indent--rule-1 method token after parent)))
(cond
((not offset) nil)
((eq (car-safe offset) 'column) (cdr offset))
(smie-indent-virtual) (current-column)))))
(t (error "Unknown indentation offset %s" offset))))))
+(defun smie-indent--rule-1 (method token &optional after parent)
+ (let ((smie--parent parent)
+ (smie--token token)
+ (smie--after after))
+ (funcall smie-rules-function method token)))
+
(defun smie-indent-forward-token ()
"Skip token forward and return it, along with its levels."
(let ((tok (funcall smie-forward-token-function)))
((< 0 (length tok)) (assoc tok smie-grammar))
((looking-at "\\s(\\|\\s)\\(\\)")
(forward-char 1)
- (cons (buffer-substring (1- (point)) (point))
- (if (match-end 1) '(0 nil) '(nil 0)))))))
+ (cons (buffer-substring-no-properties (1- (point)) (point))
+ (if (match-end 1) '(0 nil) '(nil 0))))
+ ((looking-at "\\s\"\\|\\s|")
+ (forward-sexp 1)
+ nil)
+ ((eobp) nil)
+ (t (error "Bumped into unknown token")))))
(defun smie-indent-backward-token ()
"Skip token backward and return it, along with its levels."
;; 4 == open paren syntax, 5 == close.
((memq (setq class (syntax-class (syntax-after (1- (point))))) '(4 5))
(forward-char -1)
- (cons (buffer-substring (point) (1+ (point)))
- (if (eq class 4) '(nil 0) '(0 nil)))))))
+ (cons (buffer-substring-no-properties (point) (1+ (point)))
+ (if (eq class 4) '(nil 0) '(0 nil))))
+ ((memq class '(7 15))
+ (backward-sexp 1)
+ nil)
+ ((bobp) nil)
+ (t (error "Bumped into unknown token")))))
(defun smie-indent-virtual ()
;; We used to take an optional arg (with value :not-hanging) to specify that
(save-excursion
;; (forward-comment (point-max))
(when (looking-at "\\s)")
- (while (not (zerop (skip-syntax-forward ")")))
- (skip-chars-forward " \t"))
+ (if (smie-indent--rule-1 :close-all
+ (buffer-substring-no-properties
+ (point) (1+ (point)))
+ (1+ (point)))
+ (while (not (zerop (skip-syntax-forward ")")))
+ (skip-chars-forward " \t"))
+ (forward-char 1))
(condition-case nil
(progn
(backward-sexp 1)
(if (and (< pos (line-beginning-position))
;; Make sure `token' also *starts* on another line.
(save-excursion
- (smie-indent-backward-token)
- (< pos (line-beginning-position))))
+ (let ((endpos (point)))
+ (goto-char pos)
+ (forward-line 1)
+ (and (equal res (smie-indent-forward-token))
+ (eq (point) endpos)))))
nil
(goto-char pos)
res)))))
;; - middle-of-line: "trust current position".
(cond
((smie-indent--rule :before token))
- ((smie-indent--bolp) ;I.e. non-virtual indent.
+ ((smie-indent--bolp-1) ;I.e. non-virtual indent.
;; For an open-paren-like thingy at BOL, always indent only
;; based on other rules (typically smie-indent-after-keyword).
+ ;; FIXME: we do the same if after a comment, since we may be trying
+ ;; to compute the indentation of this comment and we shouldn't indent
+ ;; based on the indentation of subsequent code.
nil)
(t
;; By default use point unless we're hanging.
(save-excursion
(forward-comment (point-max))
(skip-chars-forward " \t\r\n")
- (smie-indent-calculate))))
+ (unless
+ ;; Don't align with a closer, since the comment is "within" the
+ ;; closed element. Don't align with EOB either.
+ (save-excursion
+ (let ((next (funcall smie-forward-token-function)))
+ (or (if (zerop (length next))
+ (or (eobp) (eq (car (syntax-after (point))) 5)))
+ (rassoc next smie-closer-alist))))
+ ;; FIXME: We assume here that smie-indent-calculate will compute the
+ ;; indentation of the next token based on text before the comment,
+ ;; but this is not guaranteed, so maybe we should let
+ ;; smie-indent-calculate return some info about which buffer
+ ;; position was used as the "indentation base" and check that this
+ ;; base is before `pos'.
+ (smie-indent-calculate)))))
(defun smie-indent-comment-continue ()
;; indentation of comment-continue lines.
(save-excursion (indent-line-to indent))
(indent-line-to indent)))))
+(defun smie-auto-fill (do-auto-fill)
+ (let ((fc (current-fill-column)))
+ (when (and fc (> (current-column) fc))
+ ;; The loop below presumes BOL is outside of strings or comments. Also,
+ ;; sometimes we prefer to fill the comment than the code around it.
+ (unless (or (nth 8 (save-excursion
+ (syntax-ppss (line-beginning-position))))
+ (nth 4 (save-excursion
+ (move-to-column fc)
+ (syntax-ppss))))
+ (while
+ (and (with-demoted-errors
+ (save-excursion
+ (let ((end (point))
+ (bsf nil) ;Best-so-far.
+ (gain 0))
+ (beginning-of-line)
+ (while (progn
+ (smie-indent-forward-token)
+ (and (<= (point) end)
+ (<= (current-column) fc)))
+ ;; FIXME? `smie-indent-calculate' can (and often
+ ;; does) return a result that actually depends on the
+ ;; presence/absence of a newline, so the gain computed
+ ;; here may not be accurate, but in practice it seems
+ ;; to work well enough.
+ (skip-chars-forward " \t")
+ (let* ((newcol (smie-indent-calculate))
+ (newgain (- (current-column) newcol)))
+ (when (> newgain gain)
+ (setq gain newgain)
+ (setq bsf (point)))))
+ (when (> gain 0)
+ (goto-char bsf)
+ (newline-and-indent)
+ 'done))))
+ (> (current-column) fc))))
+ (when (> (current-column) fc)
+ (funcall do-auto-fill)))))
+
+
(defun smie-setup (grammar rules-function &rest keywords)
"Setup SMIE navigation and indentation.
GRAMMAR is a grammar table generated by `smie-prec2->grammar'.
KEYWORDS are additional arguments, which can use the following keywords:
- :forward-token FUN
- :backward-token FUN"
- (set (make-local-variable 'smie-rules-function) rules-function)
- (set (make-local-variable 'smie-grammar) grammar)
- (set (make-local-variable 'indent-line-function) 'smie-indent-line)
- (set (make-local-variable 'forward-sexp-function)
- 'smie-forward-sexp-command)
+ (setq-local smie-rules-function rules-function)
+ (setq-local smie-grammar grammar)
+ (setq-local indent-line-function #'smie-indent-line)
+ (add-function :around (local 'normal-auto-fill-function) #'smie-auto-fill)
+ (setq-local forward-sexp-function #'smie-forward-sexp-command)
(while keywords
(let ((k (pop keywords))
(v (pop keywords)))
- (case k
- (:forward-token
+ (pcase k
+ (`:forward-token
(set (make-local-variable 'smie-forward-token-function) v))
- (:backward-token
+ (`:backward-token
(set (make-local-variable 'smie-backward-token-function) v))
- (t (message "smie-setup: ignoring unknown keyword %s" k)))))
+ (_ (message "smie-setup: ignoring unknown keyword %s" k)))))
(let ((ca (cdr (assq :smie-closer-alist grammar))))
(when ca
- (set (make-local-variable 'smie-closer-alist) ca)
+ (setq-local smie-closer-alist ca)
;; Only needed for interactive calls to blink-matching-open.
- (set (make-local-variable 'blink-matching-check-function)
- #'smie-blink-matching-check)
+ (setq-local blink-matching-check-function #'smie-blink-matching-check)
(add-hook 'post-self-insert-hook
#'smie-blink-matching-open 'append 'local)
- (set (make-local-variable 'smie-blink-matching-triggers)
- (append smie-blink-matching-triggers
- ;; Rather than wait for SPC to blink, try to blink as
- ;; soon as we type the last char of a block ender.
- (let ((closers (sort (mapcar #'cdr smie-closer-alist)
- #'string-lessp))
- (triggers ())
- closer)
- (while (setq closer (pop closers))
- (unless (and closers
- ;; FIXME: this eliminates prefixes of other
- ;; closers, but we should probably elimnate
- ;; prefixes of other keywords as well.
- (string-prefix-p closer (car closers)))
- (push (aref closer (1- (length closer))) triggers)))
- (delete-dups triggers)))))))
+ (add-function :around (local 'show-paren-data-function)
+ #'smie--matching-block-data)
+ ;; Setup smie-blink-matching-triggers. Rather than wait for SPC to
+ ;; blink, try to blink as soon as we type the last char of a block ender.
+ (let ((closers (sort (mapcar #'cdr smie-closer-alist) #'string-lessp))
+ (triggers ())
+ closer)
+ (while (setq closer (pop closers))
+ (unless
+ ;; FIXME: this eliminates prefixes of other closers, but we
+ ;; should probably eliminate prefixes of other keywords as well.
+ (and closers (string-prefix-p closer (car closers)))
+ (push (aref closer (1- (length closer))) triggers)))
+ (setq-local smie-blink-matching-triggers
+ (append smie-blink-matching-triggers
+ (delete-dups triggers)))))))
+
+(declare-function edebug-instrument-function "edebug" (func))
+
+(defun smie-edebug ()
+ "Instrument the `smie-rules-function' for Edebug."
+ (interactive)
+ (require 'edebug)
+ (if (symbolp smie-rules-function)
+ (edebug-instrument-function smie-rules-function)
+ (error "Sorry, don't know how to instrument a lambda expression")))
+
+(defun smie--next-indent-change ()
+ "Go to the next line that needs to be reindented (and reindent it)."
+ (interactive)
+ (while
+ (let ((tick (buffer-chars-modified-tick)))
+ (indent-according-to-mode)
+ (eq tick (buffer-chars-modified-tick)))
+ (forward-line 1)))
+
+;;; User configuration
+
+;; This is designed to be a completely independent "module", so we can play
+;; with various kinds of smie-config modules without having to change the core.
+
+;; This smie-config module is fairly primitive and suffers from serious
+;; restrictions:
+;; - You can only change a returned offset, so you can't change the offset
+;; passed to smie-rule-parent, nor can you change the object with which
+;; to align (in general).
+;; - The rewrite rule can only distinguish cases based on the kind+token arg
+;; and smie-rules-function's return value, so you can't distinguish cases
+;; where smie-rules-function returns the same value.
+;; - Since config-rules depend on the return value of smie-rules-function, any
+;; config change that modifies this return value (e.g. changing
+;; foo-indent-basic) ends up invalidating config-rules.
+;; This last one is a serious problem since it means that file-local
+;; config-rules will only work if the user hasn't changed foo-indent-basic.
+;; One possible way to change it is to modify smie-rules-functions so they can
+;; return special symbols like +, ++, -, etc. Or make them use a new
+;; smie-rule-basic function which can then be used to know when a returned
+;; offset was computed based on foo-indent-basic.
+
+(defvar-local smie-config--mode-local nil
+ "Indentation config rules installed for this major mode.
+Typically manipulated from the major-mode's hook.")
+(defvar-local smie-config--buffer-local nil
+ "Indentation config rules installed for this very buffer.
+E.g. provided via a file-local call to `smie-config-local'.")
+(defvar smie-config--trace nil
+ "Variable used to trace calls to `smie-rules-function'.")
+
+(defun smie-config--advice (orig kind token)
+ (let* ((ret (funcall orig kind token))
+ (sig (list kind token ret))
+ (brule (rassoc sig smie-config--buffer-local))
+ (mrule (rassoc sig smie-config--mode-local)))
+ (when smie-config--trace
+ (setq smie-config--trace (or brule mrule)))
+ (cond
+ (brule (car brule))
+ (mrule (car mrule))
+ (t ret))))
+
+(defun smie-config--mode-hook (rules)
+ (setq smie-config--mode-local
+ (append rules smie-config--mode-local))
+ (add-function :around (local 'smie-rules-function) #'smie-config--advice))
+
+(defvar smie-config--modefuns nil)
+
+(defun smie-config--setter (var value)
+ (setq-default var value)
+ (let ((old-modefuns smie-config--modefuns))
+ (setq smie-config--modefuns nil)
+ (pcase-dolist (`(,mode . ,rules) value)
+ (let ((modefunname (intern (format "smie-config--modefun-%s" mode))))
+ (fset modefunname (lambda () (smie-config--mode-hook rules)))
+ (push modefunname smie-config--modefuns)
+ (add-hook (intern (format "%s-hook" mode)) modefunname)))
+ ;; Neuter any left-over previously installed hook.
+ (dolist (modefun old-modefuns)
+ (unless (memq modefun smie-config--modefuns)
+ (fset modefun #'ignore)))))
+
+(defcustom smie-config nil
+ ;; FIXME: there should be a file-local equivalent.
+ "User configuration of SMIE indentation.
+This is a list of elements (MODE . RULES), where RULES is a list
+of elements describing when and how to change the indentation rules.
+Each RULE element should be of the form (NEW KIND TOKEN NORMAL),
+where KIND and TOKEN are the elements passed to `smie-rules-function',
+NORMAL is the value returned by `smie-rules-function' and NEW is the
+value with which to replace it."
+ :version "24.4"
+ ;; FIXME improve value-type.
+ :type '(choice (const nil)
+ (alist :key-type symbol))
+ :initialize 'custom-initialize-default
+ :set #'smie-config--setter)
+
+(defun smie-config-local (rules)
+ "Add RULES as local indentation rules to use in this buffer.
+These replace any previous local rules, but supplement the rules
+specified in `smie-config'."
+ (setq smie-config--buffer-local rules)
+ (add-function :around (local 'smie-rules-function) #'smie-config--advice))
+
+;; Make it so we can set those in the file-local block.
+;; FIXME: Better would be to be able to write "smie-config-local: (...)" rather
+;; than "eval: (smie-config-local '(...))".
+(put 'smie-config-local 'safe-local-eval-function t)
+
+(defun smie-config--get-trace ()
+ (save-excursion
+ (forward-line 0)
+ (skip-chars-forward " \t")
+ (let* ((trace ())
+ (srf-fun (lambda (orig kind token)
+ (let* ((pos (point))
+ (smie-config--trace t)
+ (res (funcall orig kind token)))
+ (push (if (consp smie-config--trace)
+ (list pos kind token res smie-config--trace)
+ (list pos kind token res))
+ trace)
+ res))))
+ (unwind-protect
+ (progn
+ (add-function :around (local 'smie-rules-function) srf-fun)
+ (cons (smie-indent-calculate)
+ trace))
+ (remove-function (local 'smie-rules-function) srf-fun)))))
+
+(defun smie-config-show-indent (&optional arg)
+ "Display the SMIE rules that are used to indent the current line.
+If prefix ARG is given, then move briefly point to the buffer
+position corresponding to each rule."
+ (interactive "P")
+ (let ((trace (cdr (smie-config--get-trace))))
+ (cond
+ ((null trace) (message "No SMIE rules involved"))
+ ((not arg)
+ (message "Rules used: %s"
+ (mapconcat (lambda (elem)
+ (pcase-let ((`(,_pos ,kind ,token ,res ,rewrite)
+ elem))
+ (format "%S %S -> %S%s" kind token res
+ (if (null rewrite) ""
+ (format "(via %S)" (nth 3 rewrite))))))
+ trace
+ ", ")))
+ (t
+ (save-excursion
+ (pcase-dolist (`(,pos ,kind ,token ,res ,rewrite) trace)
+ (message "%S %S -> %S%s" kind token res
+ (if (null rewrite) ""
+ (format "(via %S)" (nth 3 rewrite))))
+ (goto-char pos)
+ (sit-for blink-matching-delay)))))))
+
+(defun smie-config--guess-value (sig)
+ (add-function :around (local 'smie-rules-function) #'smie-config--advice)
+ (let* ((rule (cons 0 sig))
+ (smie-config--buffer-local (cons rule smie-config--buffer-local))
+ (goal (current-indentation))
+ (cur (smie-indent-calculate)))
+ (cond
+ ((and (eq goal
+ (progn (setf (car rule) (- goal cur))
+ (smie-indent-calculate))))
+ (- goal cur)))))
+(defun smie-config-set-indent ()
+ "Add a rule to adjust the indentation of current line."
+ (interactive)
+ (let* ((trace (cdr (smie-config--get-trace)))
+ (_ (unless trace (error "No SMIE rules involved")))
+ (sig (if (null (cdr trace))
+ (pcase-let* ((elem (car trace))
+ (`(,_pos ,kind ,token ,res ,rewrite) elem))
+ (list kind token (or (nth 3 rewrite) res)))
+ (let* ((choicestr
+ (completing-read
+ "Adjust rule: "
+ (mapcar (lambda (elem)
+ (format "%s %S"
+ (substring (symbol-name (cadr elem))
+ 1)
+ (nth 2 elem)))
+ trace)
+ nil t nil nil
+ nil)) ;FIXME: Provide good default!
+ (choicelst (car (read-from-string
+ (concat "(:" choicestr ")")))))
+ (catch 'found
+ (pcase-dolist (`(,_pos ,kind ,token ,res ,rewrite) trace)
+ (when (and (eq kind (car choicelst))
+ (equal token (nth 1 choicelst)))
+ (throw 'found (list kind token
+ (or (nth 3 rewrite) res)))))))))
+ (default-new (smie-config--guess-value sig))
+ (newstr (read-string (format "Adjust rule (%S %S -> %S) to%s: "
+ (nth 0 sig) (nth 1 sig) (nth 2 sig)
+ (if (not default-new) ""
+ (format " (default %S)" default-new)))
+ nil nil (format "%S" default-new)))
+ (new (car (read-from-string newstr))))
+ (let ((old (rassoc sig smie-config--buffer-local)))
+ (when old
+ (setq smie-config--buffer-local
+ (remove old smie-config--buffer-local))))
+ (push (cons new sig) smie-config--buffer-local)
+ (message "Added rule %S %S -> %S (via %S)"
+ (nth 0 sig) (nth 1 sig) new (nth 2 sig))
+ (add-function :around (local 'smie-rules-function) #'smie-config--advice)))
+
+(defun smie-config--guess (beg end)
+ (let ((otraces (make-hash-table :test #'equal))
+ (smie-config--buffer-local nil)
+ (smie-config--mode-local nil)
+ (pr (make-progress-reporter "Analyzing the buffer" beg end)))
+
+ ;; First, lets get the indentation traces and offsets for the region.
+ (save-excursion
+ (goto-char beg)
+ (forward-line 0)
+ (while (< (point) end)
+ (skip-chars-forward " \t")
+ (unless (eolp) ;Skip empty lines.
+ (progress-reporter-update pr (point))
+ (let* ((itrace (smie-config--get-trace))
+ (nindent (car itrace))
+ (trace (mapcar #'cdr (cdr itrace)))
+ (cur (current-indentation)))
+ (when (numberp nindent) ;Skip `noindent' and friends.
+ (cl-incf (gethash (cons (- cur nindent) trace) otraces 0)))))
+ (forward-line 1)))
+ (progress-reporter-done pr)
+
+ ;; Second, compile the data. Our algorithm only knows how to adjust rules
+ ;; where the smie-rules-function returns an integer. We call those
+ ;; "adjustable sigs". We build a table mapping each adjustable sig
+ ;; to its data, describing the total number of times we encountered it,
+ ;; the offsets found, and the traces in which it was found.
+ (message "Guessing...")
+ (let ((sigs (make-hash-table :test #'equal)))
+ (maphash (lambda (otrace count)
+ (let ((offset (car otrace))
+ (trace (cdr otrace))
+ (double nil))
+ (let ((sigs trace))
+ (while sigs
+ (let ((sig (pop sigs)))
+ (if (and (integerp (nth 2 sig)) (member sig sigs))
+ (setq double t)))))
+ (if double
+ ;; Disregard those traces where an adjustable sig
+ ;; appears twice, because the rest of the code assumes
+ ;; that adding a rule to add an offset N will change the
+ ;; end result by N rather than 2*N or more.
+ nil
+ (dolist (sig trace)
+ (if (not (integerp (nth 2 sig)))
+ ;; Disregard those sigs that return nil or a column,
+ ;; because our algorithm doesn't know how to adjust
+ ;; them anyway.
+ nil
+ (let ((sig-data (or (gethash sig sigs)
+ (let ((data (list 0 nil nil)))
+ (puthash sig data sigs)
+ data))))
+ (cl-incf (nth 0 sig-data) count)
+ (push (cons count otrace) (nth 2 sig-data))
+ (let ((sig-off-data
+ (or (assq offset (nth 1 sig-data))
+ (let ((off-data (cons offset 0)))
+ (push off-data (nth 1 sig-data))
+ off-data))))
+ (cl-incf (cdr sig-off-data) count))))))))
+ otraces)
+
+ ;; Finally, guess the indentation rules.
+ (let ((ssigs nil)
+ (rules nil))
+ ;; Sort the sigs by frequency of occurrence.
+ (maphash (lambda (sig sig-data) (push (cons sig sig-data) ssigs)) sigs)
+ (setq ssigs (sort ssigs (lambda (sd1 sd2) (> (cadr sd1) (cadr sd2)))))
+ (while ssigs
+ (pcase-let ((`(,sig ,total ,off-alist ,cotraces) (pop ssigs)))
+ (cl-assert (= total (apply #'+ (mapcar #'cdr off-alist))))
+ (let* ((sorted-off-alist
+ (sort off-alist (lambda (x y) (> (cdr x) (cdr y)))))
+ (offset (caar sorted-off-alist)))
+ (if (zerop offset)
+ ;; Nothing to do with this sig; indentation is
+ ;; correct already.
+ nil
+ (push (cons (+ offset (nth 2 sig)) sig) rules)
+ ;; Adjust the rest of the data.
+ (pcase-dolist ((and cotrace `(,count ,toffset . ,trace))
+ cotraces)
+ (setf (nth 1 cotrace) (- toffset offset))
+ (dolist (sig trace)
+ (let ((sig-data (cdr (assq sig ssigs))))
+ (when sig-data
+ (let* ((ooff-data (assq toffset (nth 1 sig-data)))
+ (noffset (- toffset offset))
+ (noff-data
+ (or (assq noffset (nth 1 sig-data))
+ (let ((off-data (cons noffset 0)))
+ (push off-data (nth 1 sig-data))
+ off-data))))
+ (cl-assert (>= (cdr ooff-data) count))
+ (cl-decf (cdr ooff-data) count)
+ (cl-incf (cdr noff-data) count))))))))))
+ (message "Guessing...done")
+ rules))))
+
+(defun smie-config-guess ()
+ "Try and figure out this buffer's indentation settings.
+To save the result for future sessions, use `smie-config-save'."
+ (interactive)
+ (if (eq smie-grammar 'unset)
+ (user-error "This buffer does not seem to be using SMIE"))
+ (let ((config (smie-config--guess (point-min) (point-max))))
+ (cond
+ ((null config) (message "Nothing to change"))
+ ((null smie-config--buffer-local)
+ (smie-config-local config)
+ (message "Local rules set"))
+ ((y-or-n-p "Replace existing local config? ")
+ (message "Local rules replaced")
+ (smie-config-local config))
+ ((y-or-n-p "Merge with existing local config? ")
+ (message "Local rules adjusted")
+ (smie-config-local (append config smie-config--buffer-local)))
+ (t
+ (message "Rules guessed: %S" config)))))
+
+(defun smie-config-save ()
+ "Save local rules for use with this major mode.
+One way to generate local rules is the command `smie-config-guess'."
+ (interactive)
+ (cond
+ ((null smie-config--buffer-local)
+ (message "No local rules to save"))
+ (t
+ (let* ((existing (assq major-mode smie-config))
+ (config
+ (cond ((null existing)
+ (message "Local rules saved in `smie-config'")
+ smie-config--buffer-local)
+ ((y-or-n-p "Replace the existing mode's config? ")
+ (message "Mode rules replaced in `smie-config'")
+ smie-config--buffer-local)
+ ((y-or-n-p "Merge with existing mode's config? ")
+ (message "Mode rules adjusted in `smie-config'")
+ (append smie-config--buffer-local (cdr existing)))
+ (t (error "Abort")))))
+ (if existing
+ (setcdr existing config)
+ (push (cons major-mode config) smie-config))
+ (setq smie-config--mode-local config)
+ (kill-local-variable 'smie-config--buffer-local)
+ (customize-mark-as-set 'smie-config)))))
(provide 'smie)
;;; smie.el ends here
HCoop / bpt / emacs.git / blobdiff