[elpa] externals/flylisp 20fe3e7 1/5: flylisp: New package. See announcement: http://lists.gnu.org/archive/html/emacs-devel/2013-12/msg00486.html

[Stefan Monnier]

branch: externals/flylisp
commit 20fe3e77bb73773c8678e65ae38020b0b7f996eb
Author: Barry <gundaetiapo@gmail.com>
Commit: Barry <gundaetiapo@gmail.com>

    flylisp: New package. See announcement: 
http://lists.gnu.org/archive/html/emacs-devel/2013-12/msg00486.html
---
 flylisp.el | 506 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 506 insertions(+)

diff --git a/flylisp.el b/flylisp.el
new file mode 100644
index 0000000..4c34d3b
--- /dev/null
+++ b/flylisp.el
@@ -0,0 +1,506 @@
+;;; flylisp.el --- Color unbalanced parentheses and parentheses inconsistent 
with indentation -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2013  Free Software Foundation, Inc.
+
+;; Author: Barry O'Reilly <gundaetiapo@gmail.com>
+;; Version: 0.2
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Colors mismatched open parentheses with fl-mismatched-face, red by
+;; default.
+;;
+;; Also colors open and close parentheses which are inconsistent with
+;; the indentation of lines between them with fl-inconsistent-face,
+;; orange by default. This is useful for the Lisp programmer who
+;; infers a close paren's location from the open paren and
+;; indentation. The coloring serves as a warning that the indentation
+;; misleads about where the close paren is. It may also help to
+;; localize the mistake, whether due to a misindented line or a
+;; misplaced paren.
+;;
+;; As an example, consider:
+;;
+;;   (aaa (bbb "word-a
+;;   word-b" (ccc 1
+;;                2)
+;;        fff))
+;;
+;; (aaa ...) and (ccc ...) are consistent, so are not colored.
+;; (bbb ...) is inconsistent because the indentation of fff is
+;; inconsistent with the actual location of the close paren. The open
+;; and close paren are thus colored with the fl-inconsistent-face.
+;; This example also shows that multi line strings don't cause an
+;; inconsistency.
+;;
+;; Currently, the package only detects close parens that are after the
+;; place indentation would predict. A planned feature is to also
+;; indicate when the close paren is before.
+;;
+;; Also planned is to color mismatched close parens.
+
+;;; Code:
+
+;; TODO: There are display problems with mismatched parens, due to the
+;; region not expanding enough, in turn due to an apparent syntax-ppss
+;; bug. See Emacs bug 16247.
+
+;; TODO: Algorithm doesn't account for close paren which is too soon.
+;;
+;; (abc
+;;   (def))
+;;   (ghi)
+;;
+;; (abc ...) are inconsistent parens because (ghi) is indented too far
+
+;; TODO: implement mismatched close parens
+
+;; TODO: Write tests:
+;;
+;;   ;; Expect (abc ...) is consistent, (def ...) is inconsistent:
+;;   (abc a-symbol (a-func-call "word-a
+;;   word-b" (def ghi
+;;           jkl)
+;;
+;;   ;; Expect (when ...) is inconsistent:
+;;   (when (and t
+;;         nil))
+;;   ;; After change, expect (when ...) is consistent and last paren 
mismatched:
+;;   (when (and t)
+;;         nil))
+;;
+;;   Given (a ...) inconsistent, change to (a ...(), and verify close
+;;   paren is consistent.
+
+(require 'cl-lib)
+(require 'jit-lock)
+
+(defgroup flylisp nil
+  "Color unbalanced parentheses and parentheses inconsistent with indentation."
+  :prefix "flylisp-"
+  :group 'paren-matching)
+
+(defgroup flylisp-faces nil
+  "Faces for flylisp package. "
+  :group 'flylisp
+  :group 'faces)
+
+(defface fl-inconsistent-face
+  '((((class color) (background light))
+     :foreground "dark orange")
+    (((class color) (background dark))
+     :foreground "orange"))
+  "Face applied to matching open and close parens whose placement
+is inconsistent with indentation."
+  :group 'flylisp-faces)
+
+(defface fl-mismatched-face
+  '((((class color) (background light))
+     :foreground "dark red")
+    (((class color) (background dark))
+     :foreground "red"))
+  "Face applied to a paren who has no match."
+  :group 'flylisp-faces)
+
+;; An open paren and algorithmic data about it.
+;;
+;; position is the position in the buffer of the open paren
+;;
+;; close is one of:
+;;   - nil if unknown
+;;   - the position before the matching close paren
+;;   - the symbol 'mismatched if no matching close paren exists
+;;
+;; column is the displayed column of the open paren in its logical
+;; line of the buffer
+;;
+;; inconsistent is whether the open paren's close paren is
+;; inconsistent with the indentation within the list defined by the
+;; parens. It is one of:
+;;   - nil if unknown or consistent
+;;   - an integer offset from the open position to the position of the
+;;     first inconsistency. This offset is also cached in the open
+;;     paren text properties for performance.
+(cl-defstruct fl--Open position close column inconsistent)
+
+(defsubst fl--colorize-inconsistent (open-obj)
+  "Colorize the fl--Open OPEN-OBJ as inconsistent."
+  (add-text-properties (fl--Open-position open-obj)
+                       (1+ (fl--Open-position open-obj))
+                       `(fl-inconsistency
+                         ,(fl--Open-inconsistent open-obj)
+                         font-lock-face
+                         fl-inconsistent-face
+                         rear-nonsticky
+                         t))
+  (add-text-properties (fl--Open-close open-obj)
+                       (1+ (fl--Open-close open-obj))
+                       `(font-lock-face
+                         fl-inconsistent-face
+                         rear-nonsticky
+                         t)))
+
+(defsubst fl--line-check-opens (open-stack)
+  "Check fl--Open objects of the OPEN-STACK list for
+consistency.
+
+The inconsistent==nil elements of OPEN-STACK must have columns
+that are strictly decreasing moving towards the tail (a necessary
+but not sufficient condition for being consistent). The
+implementation optimizes on this assumption.
+
+Call with point on the line being checked; puts point on the next
+line or EOB."
+  (let ((indent-pos (progn (back-to-indentation)
+                           (point)))
+        (indent-column (current-column))
+        (line-end (progn (end-of-line)
+                         (point))))
+    ;; Assess open-objs against indent-column
+    (unless (eq indent-pos line-end) ; Skip whitespace lines
+      ;; Since we're only interested in marking Opens inconsistent,
+      ;; the open-stack's documented property allows the iteration to
+      ;; stop at the first inconsistent==nil Open with small enough
+      ;; column.
+      (while (and open-stack
+                  (or (fl--Open-inconsistent (car open-stack))
+                      (<= indent-column
+                          (fl--Open-column (car open-stack)))))
+        ;; Check fl--Open-inconsistent to avoid excessive
+        ;; syntax-ppss when there's a lot of bad
+        ;; indentation.
+        (unless (or (fl--Open-inconsistent (car open-stack))
+                    ;; Multi line strings don't cause inconsistency
+                    (nth 3 (syntax-ppss indent-pos)))
+          (setf (fl--Open-inconsistent (car open-stack))
+                (- indent-pos (fl--Open-position (car open-stack)))))
+        (pop open-stack)))
+    ;; Go to next line. Since we already know line-end, use it
+    ;; instead of rescanning the line
+    ;;
+    ;; goto-char tolerates going beyond EOB
+    (goto-char (1+ line-end))))
+
+(defsubst fl--region-check-opens (downward-objs
+                                  upward-objs)
+  "Check inputted parens in a region for inconsistency, first
+going down in sexp depth then up per the DOWNWARD-OBJS and
+UPWARD-OBJS.
+
+Point must be at the start of the region to process and will end
+up near the end.
+
+DOWNWARD-OBJS is a list of fl--Open objects. Each must be a
+parent of the next in the list.
+
+UPWARD-OBJS is a list of fl--Open objects. Each must be a child
+of the next in the list."
+  (while downward-objs
+    (fl--line-check-opens upward-objs)
+    (while (and downward-objs
+                (< (fl--Open-position (car downward-objs))
+                   (point)))
+      (push (pop downward-objs)
+            upward-objs)))
+  (while (and upward-objs
+              (number-or-marker-p (fl--Open-close (car upward-objs))))
+    (fl--line-check-opens upward-objs)
+    (while (and upward-objs
+                (number-or-marker-p (fl--Open-close (car upward-objs)))
+                (< (fl--Open-close (car upward-objs))
+                   (point)))
+      (pop upward-objs))))
+
+(defsubst fl--set-closes (open-obj-list)
+  "Sets the close attribute of each element of OPEN-OBJ-LIST.
+
+OPEN-OBJ-LIST is a list of fl--Open. Each must be a child of the
+next in the list. This is used to scan-lists efficiently."
+  ;; Note: Because fl--Open-position values come from (nth 9
+  ;; (syntax-ppss)), we know they are not inside a string or comment.
+  ;; Thus buf-pos inits to a valid position to start scan-lists from.
+  (let ((buf-pos (and open-obj-list
+                      ;; scan_lists tolerates buf-pos past EOB
+                      (1+ (fl--Open-position (car open-obj-list))))))
+    (dolist (open-i open-obj-list)
+      (when buf-pos
+        (setq buf-pos (condition-case nil
+                          (scan-lists buf-pos 1 1)
+                        (scan-error nil))))
+      (setf (fl--Open-close open-i) (if buf-pos
+                                        (1- buf-pos)
+                                      'mismatched)))))
+
+(defun fl-propertize-region (start end)
+  (save-excursion
+    ;; In order to correctly remove faces from parens that changed
+    ;; from multiline to uniline, we clear all parens in the JIT lock
+    ;; region to start with.
+    (fl-unpropertize-region start end)
+    (let* ((timing-info (list (current-time)))
+           (start-ps (syntax-ppss start))
+           ;; Open positions, outer to inner
+           (ps-opens (nth 9 start-ps))
+           ;; fl--Open objects, positions inner to outer
+           (open-objs nil))
+      (push (current-time) timing-info)
+      ;; Process the broader region spanned by ps-opens. Consider only
+      ;; the ps-opens, not their children which lie entirely outside
+      ;; the JIT lock region.
+      ;;
+      ;; We mostly avoid further sexp parsing in the broader region,
+      ;; except to check for a multiline string just before setting
+      ;; inconsistent.
+      (dolist (ps-open-i ps-opens)
+        (push (make-fl--Open :position
+                             ps-open-i
+                             :column
+                             (progn
+                               (goto-char ps-open-i)
+                               (current-column)))
+              open-objs))
+      (push (current-time) timing-info)
+      ;; Filter out parens which don't need consideration outside the
+      ;; JIT lock region. The ones that do are currently fontified as
+      ;; inconsistent, and could become consistent if all its enclosed
+      ;; lines are checked.
+      ;;
+      ;; In addition to filtering, this passage sets close positions
+      ;; and may reapply the inconsistency-face to some close parens
+      ;; which were just cleared.
+      (setq open-objs
+            (let* ((objs-head (cons nil open-objs))
+                   (prev-open objs-head)
+                   (open-i (cdr objs-head))
+                   ;; Whether we've called fl--set-closes
+                   ;;
+                   ;; fl--set-closes is fairly expensive when near the
+                   ;; beginning of a long Lisp function. We can avoid
+                   ;; calling it if all open-objs are propertized as
+                   ;; consistent or mismatched.
+                   (closes-set nil))
+              (while open-i
+                (let* ((inconsistency-offset
+                        (get-text-property (fl--Open-position (car open-i))
+                                           'fl-inconsistency))
+                       (inconsistency-pos
+                        (and inconsistency-offset
+                             (+ (fl--Open-position (car open-i))
+                                inconsistency-offset))))
+                  (if (or (not inconsistency-pos)
+                          ;; Always nil so as "or" evaluation continues
+                          (unless closes-set
+                            ;; Lazy one-time call
+                            (fl--set-closes open-objs)
+                            (not (setq closes-set t)))
+                          ;; Spot check using the cached offset to
+                          ;; possibly avoid a complete check in
+                          ;; fl--region-check-opens for open-i.
+                          ;;
+                          ;; Because of buffer changes,
+                          ;; inconsistency-pos is not necessarily
+                          ;; the original. Just do a valid check.
+                          (and (< (fl--Open-position (car open-i))
+                                  inconsistency-pos)
+                               (number-or-marker-p (fl--Open-close (car 
open-i)))
+                               (<= inconsistency-pos
+                                   (fl--Open-close (car open-i)))
+                               (progn
+                                 (goto-char inconsistency-pos)
+                                 (fl--line-check-opens (list (car open-i)))
+                                 (when (fl--Open-inconsistent (car open-i))
+                                   (fl--colorize-inconsistent (car open-i))
+                                   t))))
+                      ;; Remove (car open-i) from list
+                      (setcdr prev-open (cdr open-i))
+                    (pop prev-open))
+                  (pop open-i)))
+              (cdr objs-head)))
+      (push (current-time) timing-info)
+      (when open-objs
+        ;; Check lists beginning before JIT lock's region (could
+        ;; scan to after JIT lock's region)
+        (let ((open-objs-reversed (reverse open-objs)))
+          (goto-char (fl--Open-position (car open-objs-reversed)))
+          (fl--region-check-opens open-objs-reversed
+                                  nil)))
+      (push (current-time) timing-info)
+      (goto-char start)
+      ;; Process within the inputted JIT lock region
+      (let* (;; Sparse vector of open paren data, indexed by position
+             ;; in buffer minus start. This benchmarked better than
+             ;; keeping a stack of fl--Open objects updated from the
+             ;; parse states of syntax-ppss.
+             (open-paren-table (make-vector (- end start) nil)))
+        (while (< (point) end)
+          (let ((indent-pos (progn (back-to-indentation)
+                                   (point)))
+                ;; Column at which text starts on the line
+                (indent-column (current-column))
+                (line-ppss (syntax-ppss))
+                (line-end (progn (end-of-line)
+                                 (point))))
+            ;; Skip whitespace only lines and lines beginning inside
+            ;; string
+            (unless (or (eq indent-pos line-end)
+                        (nth 3 line-ppss))
+              ;; Iterate over list of unclosed open parens
+              (dolist (open-pos (nth 9 line-ppss))
+                ;; Skip the already processed ones outside the region
+                (when (<= start open-pos)
+                  (let ((open-obj (or (aref open-paren-table
+                                            (- open-pos start))
+                                      (progn
+                                        (push (make-fl--Open
+                                               :position open-pos
+                                               :column (progn
+                                                         (goto-char open-pos)
+                                                         (current-column)))
+                                              open-objs)
+                                        (aset open-paren-table
+                                              (- open-pos start)
+                                              (car open-objs))))))
+                    (when (<= indent-column
+                              (fl--Open-column open-obj))
+                      (setf (fl--Open-inconsistent open-obj)
+                            (- indent-pos (fl--Open-position open-obj))))))))
+            ;; Go to next line. Since we already know line-end, use it
+            ;; instead of rescanning the line
+            (goto-char (1+ line-end))))
+        (push (current-time) timing-info)
+        ;; Process parens beginning in the JIT lock region but extending after
+        ;;
+        ;; Note: the reason we don't filter fl--Open after the JIT
+        ;; lock region, as we did for the region before it, is mostly
+        ;; because of the directionality of redisplay from BOB to EOB.
+        ;; If we allow subsequent fl-propertize-region to propertize
+        ;; the open parens in the current JIT lock region, it wouldn't
+        ;; show to the user because by then redisplay has finished
+        ;; this JIT lock region. An additional consideration is that
+        ;; the coloring of the open paren is of more interest than the
+        ;; close paren.
+        (let ((ps-opens (nth 9 (syntax-ppss end)))
+              ;; Inner to outer going towards the tail
+              (open-obj-list nil))
+          (dolist (ps-open-i ps-opens)
+            (when (<= start ps-open-i)
+              (push (or (aref open-paren-table
+                              (- ps-open-i start))
+                        ;; Open parens on the last line of the JIT
+                        ;; lock region don't have a fl--Open object
+                        ;; created yet.
+                        (progn
+                          (push (make-fl--Open
+                                 :position ps-open-i
+                                 :column (progn
+                                           (goto-char ps-open-i)
+                                           (current-column)))
+                                open-objs)
+                          (aset open-paren-table
+                                (- ps-open-i start)
+                                (car open-objs))))
+                    open-obj-list)))
+          (push (current-time) timing-info)
+          (fl--set-closes open-obj-list)
+          (push (current-time) timing-info)
+          (goto-char end)
+          (fl--region-check-opens nil open-obj-list))
+        (push (current-time) timing-info)
+        (dolist (open-i open-objs)
+          ;; Set close position
+          ;;
+          ;; Note: We do it here instead of when it was made so as
+          ;; some benefit from the fl--set-closes function's buffer
+          ;; scanning optimization. The lists processed here are
+          ;; opened and closed within JIT lock's region, so the less
+          ;; efficient buffer scanning is not a big deal.
+          (unless (fl--Open-close open-i)
+            (setf (fl--Open-close open-i)
+                  (condition-case nil
+                      (1- (scan-lists (fl--Open-position open-i) 1 0))
+                    (scan-error 'mismatched))))
+          ;; Apply the font color via text properties
+          (with-silent-modifications
+            (if (eq 'mismatched (fl--Open-close open-i))
+                (add-text-properties (fl--Open-position open-i)
+                                     (1+ (fl--Open-position open-i))
+                                     `(font-lock-face
+                                       fl-mismatched-face
+                                       rear-nonsticky
+                                       t))
+              (if (fl--Open-inconsistent open-i)
+                  (fl--colorize-inconsistent open-i)
+                (dolist (pos-i (list (fl--Open-position open-i)
+                                     (fl--Open-close open-i)))
+                  (remove-text-properties pos-i
+                                          (1+ pos-i)
+                                          '(fl-inconsistency
+                                            nil
+                                            font-lock-face
+                                            nil
+                                            rear-nonsticky
+                                            nil)))))))
+        (push (current-time) timing-info)
+        ;; (my-msg "fl-propertize-region start=%s end=%s timing: %s"
+        ;;         start end
+        ;;         (my-time-diffs (nreverse timing-info)))
+        ))))
+
+(defun fl-unpropertize-region (start end)
+  (goto-char start)
+  ;; remove-text-properties errors if (1+ (point)) is past EOB, so
+  ;; adjust end
+  (let ((end (min (1- (point-max))
+                  end)))
+    (while (< (point) end)
+      (skip-syntax-forward "^()" end)
+      (remove-text-properties (point)
+                              (1+ (point))
+                              '(fl-inconsistency nil
+                                font-lock-face nil
+                                rear-nonsticky nil))
+      (forward-char 1))))
+
+(defsubst flylisp-extend-region-after-change (start _end _old-len)
+  ;; It seems redisplay works its way from before start to after end,
+  ;; so it's more important to expand the start in order to get
+  ;; correct redisplays.
+  (save-excursion
+    (setq jit-lock-start
+          (or (syntax-ppss-toplevel-pos (syntax-ppss start))
+              start))))
+
+(define-minor-mode flylisp-mode
+  "Color unbalanced parentheses and parentheses inconsistent with
+  indentation."
+  nil nil nil
+  (if flylisp-mode
+      (progn
+        (jit-lock-register 'fl-propertize-region t)
+        (add-hook 'jit-lock-after-change-extend-region-functions
+                  #'flylisp-extend-region-after-change
+                  nil
+                  t))
+    (remove-hook 'jit-lock-after-change-extend-region-functions
+                 #'flylisp-extend-region-after-change
+                 t)
+    (jit-lock-unregister 'fl-propertize-region)
+    (save-excursion
+      (fl-unpropertize-region (point-min) (point-max)))))
+
+(provide 'flylisp)
+
+;;; flylisp.el ends here