emacs.d/elpa/polymode-20200316.1314/polymode-debug.el

;;; polymode-debug.el --- Interactive debugging utilities for polymode -*- lexical-binding: t -*-
;;
;; Copyright (C) 2016-2018 Vitalie Spinu
;; Author: Vitalie Spinu
;; URL: https://github.com/polymode/polymode
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; This file is *NOT* part of GNU Emacs.
;;
;; 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, 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 GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;

;;; Commentary:
;;

;;; Code:

(require 'polymode-core)
(require 'poly-lock)
(require 'trace)


;;; MINOR MODE

(defvar pm--underline-overlay
  (let ((overlay (make-overlay (point) (point))))
    (overlay-put overlay 'face  '(:underline (:color "tomato" :style wave)))
    overlay)
  "Overlay used in function `pm-debug-mode'.")

(defvar pm--highlight-overlay
  (let ((overlay (make-overlay (point) (point))))
    (overlay-put overlay 'face  '(:inverse-video t))
    overlay)
  "Overlay used by `pm-debug-map-over-spans-and-highlight'.")

(defvar pm-debug-minor-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "M-n M-i")     #'pm-debug-info-on-current-span)
    (define-key map (kbd "M-n i")       #'pm-debug-info-on-current-span)
    (define-key map (kbd "M-n M-p")     #'pm-debug-print-relevant-variables)
    (define-key map (kbd "M-n p")       #'pm-debug-print-relevant-variables)
    (define-key map (kbd "M-n M-h")     #'pm-debug-map-over-spans-and-highlight)
    (define-key map (kbd "M-n h")       #'pm-debug-map-over-spans-and-highlight)
    (define-key map (kbd "M-n M-t t")   #'pm-toggle-tracing)
    (define-key map (kbd "M-n M-t i")   #'pm-debug-toogle-info-message)
    (define-key map (kbd "M-n M-t f")   #'pm-debug-toggle-fontification)
    (define-key map (kbd "M-n M-t p")   #'pm-debug-toggle-post-command)
    (define-key map (kbd "M-n M-t c")   #'pm-debug-toggle-after-change)
    (define-key map (kbd "M-n M-t a")   #'pm-debug-toggle-all)
    (define-key map (kbd "M-n M-t M-t")   #'pm-toggle-tracing)
    (define-key map (kbd "M-n M-t M-i")   #'pm-debug-toogle-info-message)
    (define-key map (kbd "M-n M-t M-f")   #'pm-debug-toggle-fontification)
    (define-key map (kbd "M-n M-t M-p")   #'pm-debug-toggle-post-command)
    (define-key map (kbd "M-n M-t M-c")   #'pm-debug-toggle-after-change)
    (define-key map (kbd "M-n M-t M-a")   #'pm-debug-toggle-all)
    (define-key map (kbd "M-n M-f s")   #'pm-debug-fontify-current-span)
    (define-key map (kbd "M-n M-f b")   #'pm-debug-fontify-current-buffer)
    (define-key map (kbd "M-n M-f M-t")   #'pm-debug-toggle-fontification)
    (define-key map (kbd "M-n M-f M-s")   #'pm-debug-fontify-current-span)
    (define-key map (kbd "M-n M-f M-b")   #'pm-debug-fontify-current-buffer)
    map))

;;;###autoload
(define-minor-mode pm-debug-minor-mode
  "Turns on/off useful facilities for debugging polymode.

Key bindings:
\\{pm-debug-minor-mode-map}"
  nil
  " PMDBG"
  :group 'polymode
  (if pm-debug-minor-mode
      (progn
        ;; this is global hook. No need to complicate with local hooks
        (add-hook 'post-command-hook 'pm-debug-highlight-current-span))
    (delete-overlay pm--underline-overlay)
    (delete-overlay pm--highlight-overlay)
    (remove-hook 'post-command-hook 'pm-debug-highlight-current-span)))

;;;###autoload
(defun pm-debug-minor-mode-on ()
  ;; activating everywhere (in case font-lock infloops in a polymode buffer )
  ;; this doesn't activate in fundamental mode
  (unless (eq major-mode 'minibuffer-inactive-mode)
    (pm-debug-minor-mode t)))

;;;###autoload
(define-globalized-minor-mode pm-debug-mode pm-debug-minor-mode pm-debug-minor-mode-on)


;;; INFO

(cl-defgeneric pm-debug-info (chunkmode))
(cl-defmethod pm-debug-info (chunkmode)
  (eieio-object-name chunkmode))
(cl-defmethod pm-debug-info ((chunkmode pm-inner-chunkmode))
  (format "%s head-matcher:\"%s\" tail-matcher:\"%s\""
          (cl-call-next-method)
          (eieio-oref chunkmode 'head-matcher)
          (eieio-oref chunkmode 'tail-matcher)))
(cl-defmethod pm-debug-info ((_chunkmode pm-inner-auto-chunkmode))
  (cl-call-next-method))

(defvar syntax-ppss-wide)
(defvar syntax-ppss-last)
(defun pm--debug-info (&optional span as-list)
  (let* ((span (or span (and polymode-mode (pm-innermost-span))))
         (message-log-max nil)
         (beg (nth 1 span))
         (end (nth 2 span))
         (obj (nth 3 span))
         (type (and span (or (car span) 'host))))
    (let ((out (list (current-buffer)
                     (point-min) (point) (point-max)
                     major-mode
                     type beg end
                     (and obj (pm-debug-info obj))
                     (format "lppss:%s"
                             (if pm--emacs>26
                                 (car syntax-ppss-wide)
                               syntax-ppss-last)))))
      (if as-list
          out
        (apply #'format
               "(%s) min:%d pos:%d max:%d || (%s) type:%s span:%s-%s %s %s"
               out)))))

(defun pm-debug-info-on-current-span (no-cache)
  "Show info on current span.
With NO-CACHE prefix, don't use cached values of the span."
  (interactive "P")
  (if (not polymode-mode)
      (message "not in a polymode buffer")
    (let ((span (pm-innermost-span nil no-cache)))
      (message (pm--debug-info span))
      ;; (move-overlay pm--highlight-overlay (nth 1 span) (nth 2 span) (current-buffer))
      (pm-debug-flick-region (nth 1 span) (nth 2 span)))))

(defun pm-debug-report-points (&optional where)
  (when polymode-mode
    (let* ((bufs (eieio-oref pm/polymode '-buffers))
           (poses (mapcar (lambda (b)
                            (format "%s:%d" b (with-current-buffer b (point))))
                          bufs)))
      (message "<%s> cb:%s %s" (or where "") (current-buffer) poses)))
  nil)


;;; TOGGLING

(defvar pm-debug-display-info-message nil)
(defun pm-debug-toogle-info-message ()
  "Toggle permanent info display."
  (interactive)
  (setq pm-debug-display-info-message (not pm-debug-display-info-message)))

(defvar poly-lock-allow-fontification)
(defun pm-debug-toggle-fontification ()
  "Enable or disable fontification in polymode buffers."
  (interactive)
  (if poly-lock-allow-fontification
      (progn
        (message "fontificaiton disabled")
        (dolist (b (buffer-list))
          (with-current-buffer b
            (when polymode-mode
              (setq poly-lock-allow-fontification nil
                    font-lock-mode nil
                    fontification-functions nil)))))
    (message "fontificaiton enabled")
    (dolist (b (buffer-list))
      (with-current-buffer b
        (when polymode-mode
          (setq poly-lock-allow-fontification t
                font-lock-mode t
                fontification-functions '(poly-lock-function)))))))

(defun pm-debug-toggle-after-change ()
  "Allow or disallow polymode actions in `after-change-functions'."
  (interactive)
  (if pm-allow-after-change-hook
      (progn
        (message "after-change disabled")
        (setq pm-allow-after-change-hook nil))
    (message "after-change enabled")
    (setq pm-allow-after-change-hook t)))

(defun pm-debug-toggle-post-command ()
  "Allow or disallow polymode actions in `post-command-hook'."
  (interactive)
  (if pm-allow-post-command-hook
      (progn
        (message "post-command disabled")
        (setq pm-allow-post-command-hook nil))
    (message "post-command enabled")
    (setq pm-allow-post-command-hook t)))

(defun pm-debug-toggle-all ()
  "Toggle all polymode guards back and forth."
  (interactive)
  (if poly-lock-allow-fontification
      (progn
        (message "fontificaiton, after-chnage and command-hook disabled")
        (setq poly-lock-allow-fontification nil
              pm-allow-after-change-hook nil
              pm-allow-post-command-hook nil))
    (message "fontificaiton, after-change and command-hook enabled")
    (setq poly-lock-allow-fontification t
          pm-allow-after-change-hook t
          pm-allow-post-command-hook t)))


;;; FONT-LOCK

(defun pm-debug-fontify-current-span ()
  "Fontify current span."
  (interactive)
  (let ((span (pm-innermost-span))
        (poly-lock-allow-fontification t))
    (poly-lock-flush (nth 1 span) (nth 2 span))
    (poly-lock-fontify-now (nth 1 span) (nth 2 span))))

(defun pm-debug-fontify-current-buffer ()
  "Fontify current buffer."
  (interactive)
  (let ((poly-lock-allow-fontification t))
    (font-lock-unfontify-buffer)
    (poly-lock-flush (point-min) (point-max))
    (poly-lock-fontify-now (point-min) (point-max))))


;;; TRACING

(defvar pm-traced-functions
  '(
    ;; core initialization
    (0 (pm-initialize
        pm--common-setup
        pm--mode-setup))
    ;; core hooks
    (1 (polymode-post-command-select-buffer
        polymode-after-kill-fixes
        ;; this one indicates the start of a sequence
        poly-lock-after-change))
    ;; advises
    (2 (pm-override-output-cons
        pm-around-advice
        polymode-with-current-base-buffer))
    ;; font-lock
    (3 (font-lock-default-fontify-region
        font-lock-fontify-keywords-region
        font-lock-fontify-region
        font-lock-fontify-syntactically-region
        font-lock-unfontify-region
        jit-lock--run-functions
        jit-lock-fontify-now
        poly-lock--after-change-internal
        poly-lock--extend-region
        poly-lock--extend-region-span
        poly-lock-after-change
        poly-lock-flush
        poly-lock-fontify-now
        poly-lock-function))
    ;; syntax
    (4 (syntax-ppss
        pm--call-syntax-propertize-original
        polymode-syntax-propertize
        polymode-restrict-syntax-propertize-extension
        pm-flush-syntax-ppss-cache
        pm--reset-ppss-cache))
    ;; core functions
    (5 (pm-select-buffer
        pm-map-over-spans
        pm--get-intersected-span
        pm--cached-span))
    ;; (13 . "^syntax-")
    (14 . "^polymode-")
    (15 . "^pm-")))

(defvar pm--do-trace nil)
;;;###autoload
(defun pm-toggle-tracing (level)
  "Toggle polymode tracing.
With numeric prefix toggle tracing for that LEVEL. Currently
universal argument toggles maximum level of tracing (4). Default
level is 3."
  (interactive "P")
  (setq level (prefix-numeric-value (or level 3)))
  (with-current-buffer (get-buffer-create "*Messages*")
    (read-only-mode -1))
  (setq pm--do-trace (not pm--do-trace))
  (if pm--do-trace
      (progn (dolist (kv pm-traced-functions)
               (when (<= (car kv) level)
                 (if (stringp (cdr kv))
                     (pm-trace-functions-by-regexp (cdr kv))
                   (dolist (fn (cadr kv))
                     (pm-trace fn)))))
             (message "Polymode tracing activated"))
    (untrace-all)
    (message "Polymode tracing deactivated")))


;;;###autoload
(defun pm-trace (fn)
  "Trace function FN.
Use `untrace-function' to untrace or `untrace-all' to untrace all
currently traced functions."
  (interactive (trace--read-args "Trace: "))
  (let ((buff (get-buffer "*Messages*")))
    (unless (advice-member-p trace-advice-name fn)
      (advice-add
       fn :around
       (let ((advice (trace-make-advice
                      fn buff 'background
                      #'pm-trace--tracing-context)))
         (lambda (body &rest args)
           (when (eq fn 'polymode-flush-syntax-ppss-cache)
             (with-current-buffer buff
               (save-excursion
                 (goto-char (point-max))
                 (insert "\n"))))
           (if polymode-mode
               (apply advice body args)
             (apply body args))))
       `((name . ,trace-advice-name)
         (depth . -100))))))

(defun pm-trace-functions-by-regexp (regexp)
  "Trace all functions whose name matched REGEXP."
  (interactive "sRegex: ")
  (cl-loop for sym being the symbols
           when (and (fboundp sym)
                     (not (memq sym '(pm-toggle-tracing
                                      pm-trace--tracing-context
                                      pm-format-span
                                      pm-fun-matcher
                                      pm--find-tail-from-head)))
                     (not (string-match "^pm-\\(trace\\|debug\\)" (symbol-name sym)))
                     (string-match regexp (symbol-name sym)))
           do (pm-trace sym)))

(defun pm-trace--tracing-context ()
  (let ((span (or *span*
                  (get-text-property (point) :pm-span))))
    (format " [%s pos:%d(%d-%d) %s%s (%f)]"
            (current-buffer) (point) (point-min) (point-max)
            (or (when span
                  (when (not (and (= (point-min) (nth 1 span))
                                  (= (point-max) (nth 2 span))))
                    "UNPR "))
                "")
            (when span
              (pm-format-span span))
            (float-time))))

;; fix object printing
(defun pm-trace--fix-1-arg-for-tracing (arg)
  (cond
   ((eieio-object-p arg) (eieio-object-name arg))
   ((and (listp arg) (eieio-object-p (nth 3 arg)))
    (list (nth 0 arg) (nth 1 arg) (nth 2 arg) (eieio-object-name (nth 3 arg))))
   (arg)))

(defun pm-trace--fix-args-for-tracing (orig-fn fn level args context)
  (let ((args (or (and (listp args)
                       (listp (cdr args))
                       (ignore-errors (mapcar #'pm-trace--fix-1-arg-for-tracing args)))
                  args)))
    (funcall orig-fn fn level args context)))

(advice-add #'trace-entry-message :around #'pm-trace--fix-args-for-tracing)
(advice-add #'trace-exit-message :around #'pm-trace--fix-args-for-tracing)
;; (advice-remove #'trace-entry-message #'pm-trace--fix-args-for-tracing)
;; (advice-remove #'trace-exit-message #'pm-trace--fix-args-for-tracing)


;;; RELEVANT VARIABLES

(defvar pm-debug-relevant-variables
  `(:change
    (before-change-functions after-change-functions)
    :command (pre-command-hook
              post-command-hook)
    :font-lock (fontification-functions
                font-lock-function
                font-lock-flush-function
                font-lock-ensure-function
                font-lock-fontify-region-function
                font-lock-fontify-buffer-function
                font-lock-unfontify-region-function
                font-lock-unfontify-buffer-function
                jit-lock-after-change-extend-region-functions
                jit-lock-functions
                poly-lock-defer-after-change)
    ;; If any of these are reset by host mode it can create issues with
    ;; font-lock and syntax (e.g. scala-mode in #195)
    :search (parse-sexp-lookup-properties
             parse-sexp-ignore-comments
             ;; (syntax-table)
             ;; font-lock-syntax-table
             case-fold-search)
    :indent (indent-line-function
             indent-region-function
             pm--indent-line-function-original)
    :revert (revert-buffer-function
             before-revert-hook
             after-revert-hook)
    :save (after-save-hook
           before-save-hook
           write-contents-functions
           local-write-file-hooks
           write-file-functions)
    :syntax (syntax-propertize-function
             syntax-propertize-extend-region-functions
             pm--syntax-propertize-function-original)))

;;;###autoload
(defun pm-debug-relevant-variables (&optional out-type)
  "Get the relevant polymode variables.
If OUT-TYPE is 'buffer, print the variables in the dedicated
buffer, if 'message issue a message, if nil just return a list of values."
  (interactive (list 'buffer))
  (let* ((cbuff (current-buffer))
         (vars (cl-loop for v on pm-debug-relevant-variables by #'cddr
                        collect (cons (car v)
                                      (mapcar (lambda (v)
                                                (cons v (buffer-local-value v cbuff)))
                                              (cadr v))))))
    (require 'pp)
    (cond
     ((eq out-type 'buffer)
      (with-current-buffer (get-buffer-create "*polymode-vars*")
        (erase-buffer)
        (goto-char (point-max))
        (insert (format "\n================== %s ===================\n" cbuff))
        (insert (pp-to-string vars))
        (toggle-truncate-lines -1)
        (goto-char (point-max))
        (view-mode)
        (display-buffer (current-buffer))))
     ((eq out-type 'message)
      (message "%s" (pp-to-string vars)))
     (t vars))))

(defun pm-debug-diff-local-vars (&optional buffer1 buffer2)
  "Print differences between local variables in BUFFER1 and BUFFER2."
  (interactive)
  (let* ((buffer1 (or buffer1 (read-buffer "Buffer1: " (buffer-name (current-buffer)))))
         (buffer2 (or buffer2 (read-buffer "Buffer2: " (buffer-name (nth 2 (buffer-list))))))
         (vars1 (buffer-local-variables (get-buffer buffer1)))
         (vars2 (buffer-local-variables (get-buffer buffer2)))
         (all-keys (delete-dups (append (mapcar #'car vars1)
                                        (mapcar #'car vars2))))
         (out-buf (get-buffer-create "*pm-debug-output")))
    (with-current-buffer out-buf
      (erase-buffer)
      (pp (delq nil
                (mapcar (lambda (k)
                          (let ((val1 (cdr (assoc k vars1)))
                                (val2 (cdr (assoc k vars2))))
                            (unless (equal val1 val2)
                              (list k val1 val2))))
                        all-keys))
          out-buf))
    (pop-to-buffer out-buf)))


;;; HIGHLIGHT

(defun pm-debug-highlight-current-span ()
  (when polymode-mode
    (with-silent-modifications
      (unless (memq this-command '(pm-debug-info-on-current-span
                                   pm-debug-highlight-last-font-lock-error-region))
        (delete-overlay pm--highlight-overlay))
      (condition-case-unless-debug err
          (let ((span (pm-innermost-span)))
            (when pm-debug-display-info-message
              (message (pm--debug-info span)))
            (move-overlay pm--underline-overlay (nth 1 span) (nth 2 span) (current-buffer)))
        (error (message "%s" (error-message-string err)))))))

(defun pm-debug-flick-region (start end &optional delay)
  (move-overlay pm--highlight-overlay start end (current-buffer))
  (run-with-timer (or delay 0.4) nil (lambda () (delete-overlay pm--highlight-overlay))))

(defun pm-debug-map-over-spans-and-highlight ()
  "Map over all spans in the buffer and highlight briefly."
  (interactive)
  (pm-map-over-spans (lambda (span)
                       (let ((start (nth 1 span))
                             (end (nth 2 span)))
                         (pm-debug-flick-region start end)
                         (sit-for 1)))
                     (point-min) (point-max) nil nil t))

(defun pm-debug-map-over-modes-and-highlight (&optional beg end)
  "Map over all spans between BEG and END and highlight modes."
  (interactive)
  (let ((cbuf (current-buffer)))
    (pm-fast-map-over-modes
     (lambda (beg end)
       (goto-char beg)
       ;; (dbg beg end (pm-format-span))
       (with-current-buffer cbuf
         (recenter-top-bottom)
         (pm-debug-flick-region (max beg (point-min))
                                (min end (point-max))))
       (sit-for 1))
     (or beg (point-min))
     (or end (point-max)))))

(defun pm-debug-run-over-check (no-cache)
  "Map over all spans and report the time taken.
Switch to buffer is performed on every position in the buffer.
On prefix NO-CACHE don't use cached spans."
  (interactive)
  (goto-char (point-min))
  (let ((start (current-time))
        (count 1)
        (pm-initialization-in-progress no-cache))
    (pm-switch-to-buffer)
    (while (< (point) (point-max))
      (setq count (1+ count))
      (forward-char)
      (pm-switch-to-buffer))
    (let ((elapsed  (float-time (time-subtract (current-time) start))))
      (message "Elapsed: %s  per-char: %s" elapsed (/ elapsed count)))))

(defun pm-dbg (msg &rest args)
  (let ((cbuf (current-buffer))
        (cpos (point)))
    (with-current-buffer (get-buffer-create "*pm-dbg*")
      (save-excursion
        (goto-char (point-max))
        (insert "\n")
        (insert (apply 'format (concat "%f [%s at %d]: " msg)
                       (float-time) cbuf cpos args))))))

(provide 'polymode-debug)
;;; polymode-debug.el ends here