polymode-debug.el

;;; polymode-debug.el --- Interactive debugging utilities for polymode -*- lexical-binding: t -*-
;;
;; Copyright (C) 2016-2022  Free Software Foundation, Inc.
;; 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-relevant-variables)
    (define-key map (kbd "M-n p")       #'pm-debug-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}"
  :lighter " 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)
        ;; (add-hook 'before-save-hook #'pm-debug-beore-change -99 t)
        ;; (add-hook 'after-save-hook #'pm-debug-after-change -99)
        )
    ;; (remove-hook 'before-save-hook #'pm-debug-beore-change)
    ;; (remove-hook 'after-save-hook #'pm-debug-after-change)
    (delete-overlay pm--underline-overlay)
    (delete-overlay pm--highlight-overlay)
    (remove-hook 'post-command-hook #'pm-debug-highlight-current-span)))

;; use to track point movements (#295)
(defun pm--debug-report-point (msg &optional r)
  (when polymode-mode
    (message "%s %s buffer[%s:%s %s:%s] window[%s:%s]"
             msg (if r r "")
             (pm-base-buffer) (with-current-buffer (pm-base-buffer) (point))
             (buffer-name) (point)
             (get-buffer-window (pm-base-buffer))
             (with-current-buffer (pm-base-buffer) (window-point))
             ;; FIXME: This arg is not used.
             (window-point))))

;; (defun pm-debug-beore-change (&rest r)
;;   (pm--debug-report-point "|before|" this-command))

;; (defun pm-debug-after-change (&rest r)
;;   (pm--debug-report-point "|after|" this-command))

;;;###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
  :group 'polymode)


;;; 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 (traced even when polymode-mode is not yet installed)
    (0 (pm--common-setup
        pm--mode-setup
        pm--run-derived-mode-hooks
        pm--run-init-hooks
        pm-initialize
        hack-local-variables
        run-hooks
        run-mode-hooks))
    ;; core hooks
    (1 (polymode-pre-command
        polymode-post-command
        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
        polymode-inhibit-during-initialization
        pm-check-for-real-change-in-extend-multiline
        poly-lock-no-jit-lock-in-polymode-buffers
        pm-override-output-position))
    ;; (2.5 . "^markdown-fontify-.*")
    ;; init
    (3  (pm-map-over-spans
         pm-map-over-modes
         pm-innermost-span
         pm-next-chunk))
    ;; font-lock
    (4 . ".*\\(font\\|jit\\|poly\\)-lock.*")
    ;; syntax
    (5 (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
    (6 (pm-select-buffer
        pm-map-over-spans
        pm--get-intersected-span
        pm--cached-span))
    (6 . "^polymode-")
    (7 . "^pm-")
    (20 . "^syntax-")
    ))

(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 (15). See
`pm-traced-functions'. Default level is 4."
  (interactive "P")
  (setq level (prefix-numeric-value (or level 4)))
  (with-current-buffer (get-buffer-create "*TMessages*")
    (read-only-mode -1))
  (when pm--do-trace
    (untrace-all))
  (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"))
    (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)
             ;; waf is this?
             (with-current-buffer buff
               (save-excursion
                 (goto-char (point-max))
                 (insert "\n"))))
           (if (or (memq fn (nth 1 (car pm-traced-functions)))
                   polymode-mode
                   ;; (derived-mode-p 'markdown-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-%d) %s%s (%f)]"
            (current-buffer) (point) (window-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))
         (print-circle t)
         (sargs (format "%s" args)))
    (when (> (length sargs) 200)
      (setq 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)
      (let ((inhibit-read-only t)
            (buf (get-buffer-create "*polymode-vars*")))
        (with-current-buffer buf
          (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)))
        (pop-to-buffer buf)))
     ((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-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