From: Don Armstrong <don@donarmstrong.com>
Date: Fri, 19 Feb 2016 16:12:27 +0000 (-0600)
Subject: add org element debug
X-Git-Url: https://git.donarmstrong.com/?p=lib.git;a=commitdiff_plain;h=99b90acfc0c370f142c3b4143a17586b0b0f36b2

add org element debug
---

diff --git a/emacs_el/org-element-debug.el b/emacs_el/org-element-debug.el
new file mode 100644
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)