[elpa] master 274406e 55/63: Provide command line interface from yasnippet-debug.el

[Noam Postavsky]

branch: master
commit 274406ee44f76a5a3cbd420f2afcd880108c51b2
Author: Noam Postavsky <address@hidden>
Commit: Noam Postavsky <address@hidden>

    Provide command line interface from yasnippet-debug.el
    
    yasnippet-debug.el can now be used to quickly test and debug a snippet
    in a file.
    
    * Rakefile (itests): New target, runs tests interactively.
    * yasnippet-debug.el: Set lexical binding.
    (when-let): Backwards compabtility definition.
    (yas-debug-live-indicators, yas-debug-live-colors)
    (yas-debug-recently-live-indicators, yas-debug-get-live-indicator)
    (yas-debug-live-marker, yas-debug-ov-fom-start, yas-debug-ov-fom-end)
    (yas-debug-live-range, yas-debug-with-tracebuf, yas-debug-snippet)
    (yas-debug-target-buffer, yas-debug-target-snippets)
    (yas-debug-snippets, yas-debug-process-command-line): New functions
    and variables.
    (yas-debug-test): Remove.
    * yasnippet.el (yas--snippet-revive): List snippet identifier in debug
    message.
    (yas--post-command-handler): Allow the debugger to run.
---
 Rakefile           |   6 +
 yasnippet-debug.el | 359 ++++++++++++++++++++++++++++++++++++++++++-----------
 yasnippet.el       |  46 +++----
 3 files changed, 317 insertions(+), 94 deletions(-)

diff --git a/Rakefile b/Rakefile
index e2bb4f7..85133e6 100644
--- a/Rakefile
+++ b/Rakefile
@@ -20,6 +20,12 @@ task :tests do
     " --batch -f ert-run-tests-batch-and-exit"
 end
 
+desc "run test in interactive mode"
+task :itests do
+  sh "#{$EMACS} -Q -L . -l yasnippet-tests.el" +
+     " --eval \"(call-interactively 'ert)\""
+end
+
 desc "create a release package"
 task :package do
   release_dir = "pkg/yasnippet-#{$version}"
diff --git a/yasnippet-debug.el b/yasnippet-debug.el
index 92950cc..c080a11 100644
--- a/yasnippet-debug.el
+++ b/yasnippet-debug.el
@@ -1,8 +1,8 @@
-;;; yasnippet-debug.el --- debug functions for yasnippet
+;;; yasnippet-debug.el --- debug functions for yasnippet -*- lexical-binding: 
t -*-
 
 ;; Copyright (C) 2010, 2013, 2014  Free Software Foundation, Inc.
 
-;; Author: Jo�o T�vora
+;; Author: João Távora
 ;; Keywords: emulations, convenience
 
 ;; This program is free software; you can redistribute it and/or modify
@@ -20,69 +20,258 @@
 
 ;;; Commentary:
 
-;; Just some debug functions
-
+;; Some debug functions.  When loaded from the command line, provides
+;; quick way to test out snippets in a fresh Emacs instance.
+;;
+;; emacs -Q -l yasnippet-debug [-v[v]]
+;;     [-M:<modename>] [-M.<filext>] [-S:[<snippet-file|name>]]
+;;     [-- <more-arguments-passed-to-Emacs>...]
+;;
+;; See the source in `yas-debug-process-command-line' for meaning of
+;; args.
+;;
 ;;; Code:
 
-(require 'yasnippet)
+(defconst yas--loaddir
+  (file-name-directory (or load-file-name buffer-file-name))
+  "Directory that yasnippet was loaded from.")
+
+(require 'yasnippet (expand-file-name "yasnippet" yas--loaddir))
 (require 'cl-lib)
+(eval-when-compile
+  (unless (require 'subr-x nil t)
+    (defmacro when-let (key-val &rest body)
+      (declare (indent 1) (debug ((symbolp form) body)))
+      `(let ((,(car key-val) ,(cadr key-val)))
+         (when ,(car key-val)
+           ,@body)))))
+
+(defvar yas-debug-live-indicators
+  (make-hash-table :test #'eq))
+
+(defun yas-debug-live-colors ()
+  (let ((colors ()))
+    (maphash (lambda (_k v) (push (nth 1 (car v)) colors)) 
yas-debug-live-indicators)
+    colors))
+
+(defvar yas-debug-recently-live-indicators)
+
+(defun yas-debug-get-live-indicator (location)
+  (require 'color)
+  (when (boundp 'yas-debug-recently-live-indicators)
+    (push location yas-debug-recently-live-indicators))
+  (let (beg end)
+    (if (markerp location)
+        (setq beg (setq end (marker-position location)))
+      (setq beg (yas-debug-ov-fom-start location)
+            end (yas-debug-ov-fom-end location)))
+    (or (when-let (color-ov (gethash location yas-debug-live-indicators))
+          (if (and beg end) (move-overlay (cdr color-ov) beg end)
+            (delete-overlay (cdr color-ov)))
+          color-ov)
+        (let* ((live-colors (yas-debug-live-colors))
+               (color
+                (cl-loop with best-color = nil with max-dist = -1
+                         for color = (format "#%06X" (random #x1000000))
+                         for comp = (apply #'color-rgb-to-hex 
(color-complement color))
+                         if (< (color-distance color (face-foreground 
'default))
+                               (color-distance comp (face-foreground 
'default)))
+                         do (setq color comp)
+                         for dist = (cl-loop for c in live-colors
+                                             minimize (color-distance c color))
+                         if (or (not live-colors) (> dist max-dist))
+                         do (setq best-color color) (setq max-dist dist)
+                         repeat (if live-colors 100 1)
+                         finally return `(:background ,best-color)))
+               (ov (make-overlay beg end)))
+          (if (markerp location)
+              (overlay-put ov 'before-string (propertize "↓" 'face color))
+            (overlay-put ov 'before-string (propertize "↘" 'face color))
+            (overlay-put ov 'after-string (propertize "↙" 'face color)))
+          (puthash location (cons color ov) yas-debug-live-indicators)))))
+
+(defun yas-debug-live-marker (marker)
+  (let* ((buffer (current-buffer))
+         (color-ov (yas-debug-get-live-indicator marker))
+         (color (car color-ov))
+         (ov (cdr color-ov))
+         (decorator (overlay-get ov 'before-string)))
+    (propertize (format "at %d" (marker-position marker))
+                'cursor-sensor-functions
+                `(,(lambda (window _oldpos dir)
+                     (overlay-put
+                      ov 'before-string
+                      (propertize decorator
+                                  'face (if (eq dir 'entered)
+                                            'mode-line-highlight color)))))
+                'face color)))
+
+(defun yas-debug-ov-fom-start (ovfom)
+  (if (overlayp ovfom) (overlay-start ovfom)
+    (let ((m (yas--fom-start ovfom)))
+      (when (markerp m) (marker-position m)))))
+(defun yas-debug-ov-fom-end (ovfom)
+  (if (overlayp ovfom) (overlay-end ovfom)
+    (let ((m (yas--fom-end ovfom)))
+      (when (markerp m) (marker-position m)))))
+
+(defun yas-debug-live-range (range)
+  (let* ((color-ov (yas-debug-get-live-indicator range))
+         (color (car color-ov))
+         (ov (cdr color-ov))
+         (decorator-beg (overlay-get ov 'before-string))
+         (decorator-end (overlay-get ov 'after-string))
+         (beg (yas-debug-ov-fom-start range))
+         (end (yas-debug-ov-fom-end range)))
+    (if (and beg end)
+        (propertize (format "from %d to %d" beg end)
+                    'cursor-sensor-functions
+                    `(,(lambda (window _oldpos dir)
+                         (let ((face (if (eq dir 'entered)
+                                         'mode-line-highlight color)))
+                           (overlay-put ov 'before-string
+                                        (propertize decorator-beg 'face face))
+                           (overlay-put ov 'after-string
+                                        (propertize decorator-end 'face 
face)))))
+                    'face color)
+      "<dead>")))
+
+(defmacro yas-debug-with-tracebuf (outbuf &rest body)
+  (declare (indent 1))
+  (let ((tracebuf-var (make-symbol "tracebuf")))
+    `(let ((,tracebuf-var (or ,outbuf (get-buffer-create "*YASnippet 
trace*"))))
+       (unless (eq ,tracebuf-var (current-buffer))
+         (cl-flet ((printf (fmt &rest args)
+                           (with-current-buffer ,tracebuf-var
+                             (insert (apply #'format fmt args)))))
+           (unless ,outbuf
+             (with-current-buffer ,tracebuf-var
+               (erase-buffer)
+               (when (fboundp 'cursor-sensor-mode)
+                 (cursor-sensor-mode +1))
+               (setq truncate-lines t)))
+           (setq ,outbuf ,tracebuf-var)
+           (save-restriction
+             (widen)
+             ,@body))))))
+
+
+(defun yas-debug-snippet (snippet &optional outbuf)
+  (yas-debug-with-tracebuf outbuf
+    (when-let (overlay (yas--snippet-control-overlay snippet))
+      (printf "\tsid: %d control overlay %s\n"
+              (yas--snippet-id snippet)
+              (yas-debug-live-range overlay)))
+    (when-let (active-field (yas--snippet-active-field snippet))
+      (unless (consp (yas--field-start active-field))
+        (printf "\tactive field: #%d %s covering \"%s\"\n"
+                (yas--field-number active-field)
+                (yas-debug-live-range active-field)
+                (buffer-substring-no-properties (yas--field-start 
active-field) (yas--field-end active-field)))))
+    (when-let (exit (yas--snippet-exit snippet))
+      (printf "\tsnippet-exit: %s next: %s\n"
+              (yas-debug-live-marker (yas--exit-marker exit))
+              (yas--exit-next exit)))
+    (dolist (field (yas--snippet-fields snippet))
+      (unless (consp (yas--field-start field))
+        (printf "\tfield: %d %s covering \"%s\" next: %s%s\n"
+                (yas--field-number field)
+                (yas-debug-live-range field)
+                (buffer-substring-no-properties (yas--field-start field) 
(yas--field-end field))
+                (yas--debug-format-fom-concise (yas--field-next field))
+                (if (yas--field-parent-field field) "(has a parent)" "")))
+      (dolist (mirror (yas--field-mirrors field))
+        (unless (consp (yas--mirror-start mirror))
+          (printf "\t\tmirror: %s covering \"%s\" next: %s\n"
+                  (yas-debug-live-range mirror)
+                  (buffer-substring-no-properties (yas--mirror-start mirror) 
(yas--mirror-end mirror))
+                  (yas--debug-format-fom-concise (yas--mirror-next 
mirror))))))))
+
+(defvar yas-debug-target-buffer nil)
+(defvar-local yas-debug-target-snippets nil)
+
+(defadvice yas--snippet-parse-create (before yas-debug-target-snippet 
(snippet))
+  (add-to-list 'yas-debug-target-snippets snippet))
+
+(defadvice yas--commit-snippet (after yas-debug-untarget-snippet (snippet))
+  (setq yas-debug-target-snippets
+        (remq snippet yas-debug-target-snippets))
+  (maphash (lambda (k color-ov)
+             (delete-overlay (cdr color-ov)))
+           yas-debug-live-indicators)
+  (clrhash yas-debug-live-indicators))
+
+(defun yas-debug-snippets (&optional outbuf hook)
+  (interactive (list nil t))
+  (condition-case err
+      (yas-debug-with-tracebuf outbuf
+        (unless (buffer-live-p yas-debug-target-buffer)
+          (setq yas-debug-target-buffer nil))
+        (with-current-buffer (or yas-debug-target-buffer (current-buffer))
+          (when yas-debug-target-snippets
+            (setq yas-debug-target-snippets
+                  (cl-delete-if-not #'yas--snippet-p 
yas-debug-target-snippets)))
+          (let ((yas-debug-recently-live-indicators nil))
+            (dolist (snippet (or yas-debug-target-snippets
+                                 (yas-active-snippets)))
+              (printf "snippet %d\n" (yas--snippet-id snippet))
+              (yas-debug-snippet snippet outbuf))
+            (maphash (lambda (loc color-ov)
+                       (unless (memq loc yas-debug-recently-live-indicators)
+                         (delete-overlay (cdr color-ov))
+                         (remhash loc yas-debug-live-indicators)))
+                     yas-debug-live-indicators)))
+        (when hook
+          (setq yas-debug-target-buffer (current-buffer))
+          (ad-enable-advice 'yas--snippet-parse-create 'before 
'yas-debug-target-snippet)
+          (ad-activate 'yas--snippet-parse-create)
+          (ad-enable-advice 'yas--commit-snippet 'after 
'yas-debug-untarget-snippet)
+          (ad-activate 'yas--commit-snippet)
+          (add-hook 'post-command-hook #'yas-debug-snippets)
+          ;; Window management is slapped together, it does what I
+          ;; want when the caller has a single window open.  Good
+          ;; enough for now.
+          (when (eq hook 'create)
+            (require 'edebug)
+            (edebug-instrument-function 'yas--snippet-parse-create)
+            (let ((buf-point (find-function-noselect 
'yas--snippet-parse-create)))
+              (with-current-buffer (car buf-point)
+                (goto-char (cdr buf-point)))))
+          outbuf))
+    ((debug error) (signal (car err) (cdr err)))))
+
+(defun yas-debug-snippet-create ()
+  (yas-debug-snippets nil 'create))
 
 (defun yas-debug-snippet-vars ()
   "Debug snippets, fields, mirrors and the `buffer-undo-list'."
   (interactive)
-  (with-output-to-temp-buffer "*YASnippet trace*"
-    (princ "Interesting YASnippet vars: \n\n")
-
-    (princ (format "\nPost command hook: %s\n" post-command-hook))
-    (princ (format "\nPre  command hook: %s\n" pre-command-hook))
-
-    (princ (format "%s live snippets in total\n" (length (yas-active-snippets 
'all-snippets))))
-    (princ (format "%s overlays in buffer:\n\n" (length (overlays-in 
(point-min) (point-max)))))
-    (princ (format "%s live snippets at point:\n\n" (length 
(yas-active-snippets))))
-
-
-    (dolist (snippet (yas-active-snippets))
-      (princ (format "\tsid: %d control overlay from %d to %d\n"
-                     (yas--snippet-id snippet)
-                     (overlay-start (yas--snippet-control-overlay snippet))
-                     (overlay-end (yas--snippet-control-overlay snippet))))
-      (princ (format "\tactive field: %s from %s to %s covering \"%s\"\n"
-                     (yas--field-number (yas--snippet-active-field snippet))
-                     (marker-position (yas--field-start 
(yas--snippet-active-field snippet)))
-                     (marker-position (yas--field-end 
(yas--snippet-active-field snippet)))
-                     (buffer-substring-no-properties (yas--field-start 
(yas--snippet-active-field snippet)) (yas--field-end (yas--snippet-active-field 
snippet)))))
-      (when (yas--snippet-exit snippet)
-        (princ (format "\tsnippet-exit: at %s next: %s\n"
-                       (yas--exit-marker (yas--snippet-exit snippet))
-                       (yas--exit-next (yas--snippet-exit snippet)))))
-      (dolist (field (yas--snippet-fields snippet))
-        (princ (format "\tfield: %s from %s to %s covering \"%s\" next: %s%s\n"
-                       (yas--field-number field)
-                       (marker-position (yas--field-start field))
-                       (marker-position (yas--field-end field))
-                       (buffer-substring-no-properties (yas--field-start 
field) (yas--field-end field))
-                       (yas--debug-format-fom-concise (yas--field-next field))
-                       (if (yas--field-parent-field field) "(has a parent)" 
"")))
-        (dolist (mirror (yas--field-mirrors field))
-          (princ (format "\t\tmirror: from %s to %s covering \"%s\" next: %s\n"
-                         (marker-position (yas--mirror-start mirror))
-                         (marker-position (yas--mirror-end mirror))
-                         (buffer-substring-no-properties (yas--mirror-start 
mirror) (yas--mirror-end mirror))
-                         (yas--debug-format-fom-concise (yas--mirror-next 
mirror)))))))
-
-    (princ (format "\nUndo is %s and point-max is %s.\n"
-                   (if (eq buffer-undo-list t)
-                       "DISABLED"
-                     "ENABLED")
-                   (point-max)))
+  (yas-debug-with-tracebuf ()
+    (printf "Interesting YASnippet vars: \n\n")
+
+    (printf "\nPost command hook: %s\n" post-command-hook)
+    (printf "\nPre  command hook: %s\n" pre-command-hook)
+
+    (printf "%s live snippets in total\n" (length (yas-active-snippets 
'all-snippets)))
+    (printf "%s overlays in buffer:\n\n" (length (overlays-in (point-min) 
(point-max))))
+    (printf "%s live snippets at point:\n\n" (length (yas-active-snippets)))
+
+    (yas-debug-snippets outbuf)
+
+    (printf "\nUndo is %s and point-max is %s.\n"
+            (if (eq buffer-undo-list t)
+                "DISABLED"
+              "ENABLED")
+            (point-max))
     (unless (eq buffer-undo-list t)
-      (princ (format "Undpolist has %s elements. First 10 elements follow:\n"
-                     (length buffer-undo-list)))
+      (printf "Undpolist has %s elements. First 10 elements follow:\n"
+              (length buffer-undo-list))
       (let ((first-ten (cl-subseq buffer-undo-list 0
                                   (min 19 (length buffer-undo-list)))))
         (dolist (undo-elem first-ten)
-          (princ (format "%2s:  %s\n" (cl-position undo-elem first-ten)
-                         (truncate-string-to-width (format "%s" undo-elem) 
70))))))))
+          (printf "%2s:  %s\n" (cl-position undo-elem first-ten)
+                  (truncate-string-to-width (format "%s" undo-elem) 70)))))
+    (display-buffer tracebuf)))
 
 (defun yas--debug-format-fom-concise (fom)
   (when fom
@@ -99,6 +288,50 @@
            (format "snippet exit at %d"
                    (marker-position (yas--fom-start fom)))))))
 
+(defun yas-debug-process-command-line ()
+  "Implement command line processing."
+  (setq yas-verbosity 99)
+  (setq yas-triggers-in-field t)
+  (setq debug-on-error t)
+  (let* ((snippet-file nil)
+         (snippet-mode 'fundamental-mode)
+         (options (cl-loop for opt = (pop command-line-args-left)
+                           while (and opt (not (equal opt "--"))
+                                      (string-prefix-p "-" opt))
+                           collect opt))
+         (snippet-key nil))
+    (when-let (mode (cl-member "-M:" options :test #'string-prefix-p))
+      (setq snippet-mode (intern (concat (substring (car mode) 3) "-mode"))))
+    (when-let (mode (cl-member "-M." options :test #'string-prefix-p))
+      (setq snippet-mode
+            (cdr (cl-assoc (substring (car mode) 2) auto-mode-alist
+                           :test (lambda (ext regexp) (string-match-p regexp 
ext))))))
+    (switch-to-buffer (get-buffer-create "*yas test*"))
+    (funcall snippet-mode)
+    (when-let (snippet-file (cl-member "-S:" options :test #'string-prefix-p))
+      (setq snippet-file (substring (car snippet-file) 3))
+      (if (file-exists-p snippet-file)
+          (with-temp-buffer
+            (insert-file-contents snippet-file)
+            (let ((snippet-deflist (yas--parse-template snippet-file)))
+              (yas-define-snippets snippet-mode (list snippet-deflist))
+              (setq snippet-key (car snippet-deflist))))
+        (yas-reload-all)
+        (let ((template (yas--lookup-snippet-1 snippet-file snippet-mode)))
+          (if template
+              (setq snippet-key (yas--template-key template))
+            (error "No such snippet `%s'" snippet-file)))))
+    (display-buffer (find-file-noselect
+                     (expand-file-name "yasnippet.el" yas--loaddir)))
+    (when-let (verbosity (car (or (member "-v" options) (member "-vv" 
options))))
+      (set-window-buffer
+       (split-window) (yas-debug-snippets
+                       nil (if (equal verbosity "-vv") 'create t))))
+    (yas-minor-mode +1)
+    (when snippet-key (insert snippet-key))))
+
+(when command-line-args-left
+  (yas-debug-process-command-line))
 
 (defun yas-exterminate-package ()
   (interactive)
@@ -108,24 +341,6 @@
                 (when (string-match "yas[-/]" (symbol-name atom))
                   (unintern atom obarray)))))
 
-(defun yas-debug-test (&optional quiet)
-  (interactive "P")
-  (yas-load-directory (or (car-safe yas-snippet-dirs)
-                          yas-snippet-dirs
-                          "~/Source/yasnippet/snippets/"))
-  (set-buffer (switch-to-buffer "*YAS TEST*"))
-  (mapc #'yas--commit-snippet (yas-active-snippets 'all-snippets))
-  (erase-buffer)
-  (setq buffer-undo-list nil)
-  (setq undo-in-progress nil)
-  (snippet-mode)
-  (yas-minor-mode 1)
-  (let ((abbrev))
-    (setq abbrev "$f")
-    (insert abbrev))
-  (unless quiet
-    (add-hook 'post-command-hook 'yas-debug-snippet-vars 't 'local)))
-
 (provide 'yasnippet-debug)
 ;; Local Variables:
 ;; indent-tabs-mode: nil
diff --git a/yasnippet.el b/yasnippet.el
index 69f7381..4751209 100644
--- a/yasnippet.el
+++ b/yasnippet.el
@@ -3828,7 +3828,7 @@ considered when expanding the snippet."
                (sit-for 0) ;; fix issue 125
                (yas--letenv (yas--snippet-expand-env snippet)
                  (yas--move-to-field snippet first-field))))
-           (yas--message 4 "snippet expanded.")
+           (yas--message 4 "snippet %d expanded." (yas--snippet-id snippet))
            (setq deactivate-mark nil)
            t))))
 
@@ -4601,27 +4601,29 @@ When multiple expressions are found, only the last one 
counts."
 ;;
 (defun yas--post-command-handler ()
   "Handles various yasnippet conditions after each command."
-  (yas--finish-moving-snippets)
-  (cond ((eq 'undo this-command)
-         ;;
-         ;; After undo revival the correct field is sometimes not
-         ;; restored correctly, this condition handles that
-         ;;
-         (let* ((snippet (car (yas-active-snippets)))
-                (target-field
-                 (and snippet
-                      (cl-find-if-not
-                       (lambda (field)
-                         (yas--field-probably-deleted-p snippet field))
-                       (remq nil
-                             (cons (yas--snippet-active-field snippet)
-                                   (yas--snippet-fields snippet)))))))
-           (when target-field
-             (yas--move-to-field snippet target-field))))
-        ((not (yas--undo-in-progress))
-         ;; When not in an undo, check if we must commit the snippet
-         ;; (user exited it).
-         (yas--check-commit-snippet))))
+  (condition-case err
+      (progn (yas--finish-moving-snippets)
+             (cond ((eq 'undo this-command)
+                    ;;
+                    ;; After undo revival the correct field is sometimes not
+                    ;; restored correctly, this condition handles that
+                    ;;
+                    (let* ((snippet (car (yas-active-snippets)))
+                           (target-field
+                            (and snippet
+                                 (cl-find-if-not
+                                  (lambda (field)
+                                    (yas--field-probably-deleted-p snippet 
field))
+                                  (remq nil
+                                        (cons (yas--snippet-active-field 
snippet)
+                                              (yas--snippet-fields 
snippet)))))))
+                      (when target-field
+                        (yas--move-to-field snippet target-field))))
+                   ((not (yas--undo-in-progress))
+                    ;; When not in an undo, check if we must commit the snippet
+                    ;; (user exited it).
+                    (yas--check-commit-snippet))))
+    ((debug error) (signal (car err) (cdr err)))))
 
 ;;; Fancy docs:
 ;;