emacs_el/org-element-debug.el

   1 ;;; element-debug-mode by Nicolas, see:
   2 ;;
   3 ;; (notmuch-show "id:87d21dsvox.fsf@nicolasgoaziou.fr")
   4 ;; <http://mid.gmane.org/87d21dsvox.fsf@nicolasgoaziou.fr>
   5 ;;
   6 ;; (notmuch-show "id:87ioaqsaz2.fsf@nicolasgoaziou.fr")
   7 ;; <http://mid.gmane.org/87ioaqsaz2.fsf@nicolasgoaziou.fr>
   8
   9 (defun element-check-cache (&rest ignore)
  10   (when (org-element--cache-active-p)
  11     (save-match-data
  12       (let ((cache (copy-tree org-element--cache t))
  13             (requests (copy-tree org-element--cache-sync-requests t))
  14             (buffer-contents (org-with-wide-buffer (buffer-string)))
  15             (translations (make-hash-table :test #'eq))
  16             (structures (make-hash-table :test #'eq))
  17             (keys (make-hash-table :test #'eq)))
  18         ;; Fix parents.
  19         (loop for key in (avl-tree-flatten org-element--cache)
  20               for value in (avl-tree-flatten cache)
  21               do (let ((struct (and (memq (org-element-type key)
  22                                           '(plain-list item))
  23                                     (gethash (org-element-property :structure key)
  24                                              structures 'missing))))
  25                    (progn
  26                      (puthash key value translations)
  27                      (let ((k (gethash key org-element--cache-sync-keys)))
  28                        (when k (puthash value k keys)))
  29                      (puthash
  30                       key
  31                       (org-element-put-property
  32                        value :parent
  33                        (gethash (org-element-property :parent key)
  34                                 translations))
  35                       translations)
  36                      (when (eq struct 'missing)
  37                        (setq struct
  38                              (puthash (org-element-property :structure key)
  39                                       (org-element-property :structure value)
  40                                       structures)))
  41                      (when struct
  42                        (puthash
  43                         key
  44                         (org-element-put-property value :structure struct)
  45                         translations)))))
  46         ;; Fix requests.
  47         (loop for original in org-element--cache-sync-requests
  48               for copy in requests
  49               do (aset copy 4 (gethash (aref original 4) translations)))
  50         (with-temp-buffer
  51           (let ((org-element-use-cache nil)) (insert buffer-contents))
  52           (let ((org-inhibit-startup t)) (org-mode))
  53           (setq org-element--cache cache
  54                 org-element--cache-sync-requests requests
  55                 org-element--cache-sync-keys keys)
  56           (org-element--cache-sync (current-buffer) (point-max))
  57           (let ((seen '()))
  58             (avl-tree-mapc
  59              (lambda (element)
  60                (let ((beg (org-element-property :begin element))
  61                      (type (org-element-type element)))
  62                  (let ((real (let (org-element-use-cache)
  63                                (goto-char
  64                                 (if (memq type '(item table-row)) (1+ beg)
  65                                   beg))
  66                                (org-element-at-point))))
  67                    (cond
  68                     ((member real seen)
  69                      (message
  70                       "======\nWARNING. Two entries for the same element\n\n %s"
  71                       element))
  72                     ((not (equal real element))
  73                      (message
  74                       "======\nWARNING. Corrupted element (%s) at %d\n\nReal:\
  75         %s\n\nCached: %s\n\nLast request: %s"
  76                       (org-element-type element) beg real element (car requests)))
  77                     (t (push real seen))))))
  78              org-element--cache)))))))
  79
  80 (define-minor-mode element-debug-mode
  81   "Minor mode to debug Org Element cache."
  82   nil " OrgCacheD" nil
  83   (if element-debug-mode
  84       (progn (setq org-element-cache-sync-idle-time 3600)
  85              (add-hook 'after-change-functions 'element-check-cache t t))
  86     (setq org-element-cache-sync-idle-time 0.6)
  87     (remove-hook 'after-change-functions 'element-check-cache t)))
  88
  89 (provide 'org-element-debug)