597 lines
22 KiB
EmacsLisp
597 lines
22 KiB
EmacsLisp
;;; 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)))))
|
||
|
||
;; (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)))
|
||
|
||
(declare-function trace-entry-message "ext:")
|
||
(declare-function trace-exit-message "ext:")
|
||
(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
|