add org element debug

diff --git a/emacs_el/org-element-debug.el b/emacs_el/org-element-debug.el
new file mode 100644 (file)
index 0000000..8de62ad
--- /dev/null
+++ b/emacs_el/org-element-debug.el
@@ -0,0 +1,89 @@
+;;; element-debug-mode by Nicolas, see:
+;;
+;; (notmuch-show "id:87d21dsvox.fsf@nicolasgoaziou.fr")
+;; <http://mid.gmane.org/87d21dsvox.fsf@nicolasgoaziou.fr>
+;;
+;; (notmuch-show "id:87ioaqsaz2.fsf@nicolasgoaziou.fr")
+;; <http://mid.gmane.org/87ioaqsaz2.fsf@nicolasgoaziou.fr>
+
+(defun element-check-cache (&rest ignore)
+  (when (org-element--cache-active-p)
+    (save-match-data
+      (let ((cache (copy-tree org-element--cache t))
+           (requests (copy-tree org-element--cache-sync-requests t))
+           (buffer-contents (org-with-wide-buffer (buffer-string)))
+           (translations (make-hash-table :test #'eq))
+           (structures (make-hash-table :test #'eq))
+           (keys (make-hash-table :test #'eq)))
+       ;; Fix parents.
+       (loop for key in (avl-tree-flatten org-element--cache)
+             for value in (avl-tree-flatten cache)
+             do (let ((struct (and (memq (org-element-type key)
+                                         '(plain-list item))
+                                   (gethash (org-element-property :structure key)
+                                            structures 'missing))))
+                  (progn
+                    (puthash key value translations)
+                    (let ((k (gethash key org-element--cache-sync-keys)))
+                      (when k (puthash value k keys)))
+                    (puthash
+                     key
+                     (org-element-put-property
+                      value :parent
+                      (gethash (org-element-property :parent key)
+                               translations))
+                     translations)
+                    (when (eq struct 'missing)
+                      (setq struct
+                            (puthash (org-element-property :structure key)
+                                     (org-element-property :structure value)
+                                     structures)))
+                    (when struct
+                      (puthash
+                       key
+                       (org-element-put-property value :structure struct)
+                       translations)))))
+       ;; Fix requests.
+       (loop for original in org-element--cache-sync-requests
+             for copy in requests
+             do (aset copy 4 (gethash (aref original 4) translations)))
+       (with-temp-buffer
+         (let ((org-element-use-cache nil)) (insert buffer-contents))
+         (let ((org-inhibit-startup t)) (org-mode))
+         (setq org-element--cache cache
+               org-element--cache-sync-requests requests
+               org-element--cache-sync-keys keys)
+         (org-element--cache-sync (current-buffer) (point-max))
+         (let ((seen '()))
+           (avl-tree-mapc
+            (lambda (element)
+              (let ((beg (org-element-property :begin element))
+                    (type (org-element-type element)))
+                (let ((real (let (org-element-use-cache)
+                              (goto-char
+                               (if (memq type '(item table-row)) (1+ beg)
+                                 beg))
+                              (org-element-at-point))))
+                  (cond
+                   ((member real seen)
+                    (message
+                     "======\nWARNING. Two entries for the same element\n\n %s"
+                     element))
+                   ((not (equal real element))
+                    (message
+                     "======\nWARNING. Corrupted element (%s) at %d\n\nReal:\
+       %s\n\nCached: %s\n\nLast request: %s"
+                     (org-element-type element) beg real element (car requests)))
+                   (t (push real seen))))))
+            org-element--cache)))))))
+
+(define-minor-mode element-debug-mode
+  "Minor mode to debug Org Element cache."
+  nil " OrgCacheD" nil
+  (if element-debug-mode
+      (progn (setq org-element-cache-sync-idle-time 3600)
+            (add-hook 'after-change-functions 'element-check-cache t t))
+    (setq org-element-cache-sync-idle-time 0.6)
+    (remove-hook 'after-change-functions 'element-check-cache t)))
+
+(provide 'org-element-debug)