X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/f7ff1b0f0792f1f870778404531e68e77832c4a1..131a3a12c4b0171c71c122c3330f85fc19e9bb8f:/lisp/emacs-lisp/smie.el diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 2701d6b940..1819daa3df 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -1,6 +1,6 @@ ;;; 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 ;; Keywords: languages, lisp, internal, parsing, indentation @@ -56,7 +56,7 @@ ;; 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. @@ -69,13 +69,23 @@ ;; (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 IFEND -;; 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 IFEND 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 @@ -84,10 +94,34 @@ ;; - 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." @@ -110,7 +144,7 @@ ;; - 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 @@ -118,8 +152,10 @@ ;; 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))) @@ -129,7 +165,8 @@ ;; 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) @@ -173,21 +210,54 @@ one of those elements share the same precedence level and associativity." 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 ). ;; Maybe also add (or ...) 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 ()) @@ -198,8 +268,8 @@ one of those elements share the same precedence level and associativity." (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"). @@ -209,15 +279,19 @@ one of those elements share the same precedence level and associativity." ;; 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) @@ -263,8 +337,11 @@ one of those elements share the same precedence level and associativity." (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) @@ -319,7 +396,7 @@ one of those elements share the same precedence level and associativity." ;; 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. @@ -339,45 +416,41 @@ from the table, e.g. the table will not include things like (\"if\" . \"else\"). (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))) @@ -410,7 +483,7 @@ CSTS is a list of pairs representing arcs in a graph." (push (concat "." (car elem)) res)) (if (eq (cddr elem) val) (push (concat (car elem) ".") res))) - (assert res) + (cl-assert res) res)) cycle))) (mapconcat @@ -425,9 +498,9 @@ CSTS is a list of pairs representing arcs in a graph." ;; (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) @@ -441,25 +514,28 @@ PREC2 is a table as returned by `smie-precs->prec2' or ;; 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)) @@ -499,14 +575,14 @@ PREC2 is a table as returned by `smie-precs->prec2' or (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 @@ -516,8 +592,8 @@ PREC2 is a table as returned by `smie-precs->prec2' or ;; 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) ) @@ -526,17 +602,17 @@ PREC2 is a table as returned by `smie-precs->prec2' or (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))) @@ -615,6 +691,7 @@ Possible return values: 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 @@ -630,21 +707,23 @@ Possible return values: ((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) @@ -655,7 +734,8 @@ Possible return values: (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)) @@ -668,8 +748,22 @@ Possible return values: ;; 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))) @@ -686,7 +780,8 @@ Possible return values: ((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 @@ -706,6 +801,7 @@ Possible return values: 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 @@ -725,7 +821,8 @@ Possible return values: (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 @@ -735,7 +832,7 @@ Possible return values: (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." @@ -863,7 +960,7 @@ If non-nil, it will blink not only for \"begin..end\" but also for \"if...else\" (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) @@ -918,6 +1015,9 @@ This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'. (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 @@ -927,6 +1027,93 @@ This uses SMIE's tables and is expected to be placed on `post-self-insert-hook'. (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 @@ -949,6 +1136,10 @@ METHOD can be: - :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 @@ -956,7 +1147,7 @@ function should return nil for arguments it does not expect. 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. @@ -964,6 +1155,15 @@ NUMBER offset by NUMBER, relative to a base token 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\". @@ -973,13 +1173,11 @@ the beginning of a line." (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) @@ -987,6 +1185,16 @@ the beginning of a line." "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) @@ -1039,14 +1247,7 @@ Only meaningful when called from within `smie-rules-function'." (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) @@ -1126,8 +1327,8 @@ Only meaningful when called from within `smie-rules-function'." (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." @@ -1140,11 +1341,7 @@ 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)) @@ -1165,6 +1362,12 @@ BASE-POS is the position relative to which offsets should be applied." (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))) @@ -1172,8 +1375,13 @@ BASE-POS is the position relative to which offsets should be applied." ((< 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." @@ -1184,8 +1392,13 @@ BASE-POS is the position relative to which offsets should be applied." ;; 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 @@ -1223,8 +1436,13 @@ in order to figure out the indentation of some other (further down) point." (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) @@ -1246,8 +1464,11 @@ should not be computed on the basis of the following token." (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))))) @@ -1263,9 +1484,12 @@ should not be computed on the basis of the following token." ;; - 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. @@ -1366,7 +1590,21 @@ should not be computed on the basis of the following token." (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. @@ -1515,6 +1753,47 @@ to which that point should be aligned, if we were to reindent it.") (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'. @@ -1522,45 +1801,409 @@ RULES-FUNCTION is a set of indentation rules for use on `smie-rules-function'. 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