DeCarabas/Init-Files
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Non-recursive clean

Browse source
This commit is contained in:
John Doty 2017-10-28 07:58:04 -07:00
parent 073b2579a5
commit b651c98b70
1 changed files with 78 additions and 85 deletions
Download patch file Download diff file Expand all files Collapse all files

121
site-lisp/ox-quip.el
View file

@ -43,25 +43,17 @@ This is structured as a separate pass from
org-quip--clean-element-contents because we want to make sure we org-quip--clean-element-contents because we want to make sure we
get all the strings, nested or not, and that includes inside get all the strings, nested or not, and that includes inside
<spans> and the newlines from <br />." <spans> and the newlines from <br />."
(let ((new-contents nil))
(while contents
(cond (cond
((null contents) nil)
; Process strings.
((stringp (car contents)) ((stringp (car contents))
(let ((this (car contents))
(rest (cdr contents)))
(while (stringp (car rest)) (if (stringp (cadr contents))
(setq this (concat this (car rest))) (setq contents (cons (concat (car contents) (cadr contents))
(setq rest (cdr rest))) (cddr contents)))
(setq new-contents (cons (car contents) new-contents))
(setq contents (cdr contents))))
(setq this (org-quip--clean-string this tag))
(setq rest (org-quip--clean-element-strings rest tag))
(if (> (length this) 0)
(cons this rest)
rest)))
; Recurse into elements.
(t (t
(letrec ((this (car contents)) (letrec ((this (car contents))
(new-tag (car this)) (new-tag (car this))
@ -69,9 +61,10 @@ get all the strings, nested or not, and that includes inside
(new-contents (org-quip--clean-element-strings (cddr this) (new-contents (org-quip--clean-element-strings (cddr this)
new-tag)) new-tag))
(new-elem (append (list new-tag new-attrs) new-contents))) (new-elem (append (list new-tag new-attrs) new-contents)))
(cons new-elem (setq new-contents (cons new-elem new-contents))
(org-quip--clean-element-strings (cdr contents) tag)))) (setq contents (cdr contents))))))
))
(nreverse new-contents)))
(defun org-quip--clean-element-contents (contents tag strip) (defun org-quip--clean-element-contents (contents tag strip)
"Clean up the CONTENTS of element with tag TAG, optionally STRIP IDs. "Clean up the CONTENTS of element with tag TAG, optionally STRIP IDs.
@ -83,46 +76,43 @@ produced by org HTML export and get something that's roughly
comparable. We also clear all the attributes except for ID, and comparable. We also clear all the attributes except for ID, and
we only keep ID in certain cases where we know we can support the we only keep ID in certain cases where we know we can support the
correspondence." correspondence."
(let ((new-contents nil))
(while contents
(cond (cond
((null contents) nil) ;; Strings are strings.
; Ignore strings for now, we'll get
; them in another pass.
((stringp (car contents)) ((stringp (car contents))
(cons (car contents) (setq new-contents (cons (car contents) new-contents))
(org-quip--clean-element-contents (cdr contents) tag strip))) (setq contents (cdr contents)))
; <br> is "\n". ;; <br /> is "\n".
((eq (caar contents) 'br) ((eq (caar contents) 'br)
(cons "\n" (setq new-contents (cons "\n" new-contents))
(org-quip--clean-element-contents (cdr contents) tag strip))) (setq contents (cdr contents)))
; Is this an element we're unfolding? ;; This might be an element we're unfolding...
((or (member (caar contents) '(div html body span)) ((or (member (caar contents) '(div html body span))
(and (eq (caar contents) 'a) (and (eq (caar contents) 'a)
(cdar contents) (cdar contents)
(not (alist-get 'href (cdar contents))))) (not (alist-get 'href (cdar contents)))))
(org-quip--clean-element-contents (append (cddar contents) (cdr contents)) (setq contents (append (cddar contents) (cdr contents))))
tag
strip))
; This is an element we're keeping. ;; This is an element we're keeping.
(t (t
(letrec ((new-tag (caar contents)) (letrec ((el-keep (car contents))
(new-tag (car el-keep))
(new-id (org-quip--get-element-id el-keep))
(attribs (when (or (not strip) (attribs (when (or (not strip)
(member new-tag '(h1 h2 h3 h4 h5 h6))) (member new-tag '(h1 h2 h3 h4 h5 h6)))
(list `((id . ,new-id))))
(cons 'id (body (org-quip--clean-element-contents (cddr el-keep)
(org-quip--get-element-id (car contents))))))
(body (org-quip--clean-element-contents (cddar contents)
new-tag new-tag
strip)) strip))
(new-elem (append (list new-tag attribs) body))) (new-elem (append (list new-tag attribs) body)))
(cons new-elem (setq new-contents (cons new-elem new-contents))
(org-quip--clean-element-contents (cdr contents) tag strip)))) (setq contents (cdr contents))))))
)) (nreverse new-contents)))
(defun org-quip--get-cleaned-dom (html &optional strip) (defun org-quip--get-cleaned-dom (html &optional strip)
"Clean HTML as a list of cleaned DOM elements, and maybe STRIP attributes. "Clean HTML as a list of cleaned DOM elements, and maybe STRIP attributes.
@ -313,7 +303,7 @@ acceptable org, and (c) running a cleanup pass over the generated
org markup. org markup.
The end result is fairly clean 'org-mode' markup." The end result is fairly clean 'org-mode' markup."
(let ((quip-html (alist-get 'html (quip-get-thread thread-id)))) (let ((quip-html (alist-get 'html thread)))
(with-current-buffer buffer (with-current-buffer buffer
(erase-buffer) (erase-buffer)
(with-temp-buffer (with-temp-buffer
@ -333,7 +323,7 @@ The end result is fairly clean 'org-mode' markup."
;; HAX ;; HAX
(goto-char (point-min)) (goto-char (point-min))
(org-entry-put nil "QUIP_ID" thread-id) (org-entry-put nil "QUIP_ID" (alist-get 'id (alist-get 'thread thread)))
(goto-char (point-min)) (goto-char (point-min))
(insert "#+options: num:nil\n\n") (insert "#+options: num:nil\n\n")
@ -585,7 +575,7 @@ The return value is a list of commands to execute against Quip."
(new-dom (org-quip--get-cleaned-dom new-html)) (new-dom (org-quip--get-cleaned-dom new-html))
(new-id-list (mapcar #'org-quip--get-element-id new-dom)) (new-id-list (mapcar #'org-quip--get-element-id new-dom))
(new-pos-list (org-quip--get-positions-from-ids buffer (new-pos-list (org-quip--get-positions-from-ids org-buffer
new-id-list)) new-id-list))
(diff-text (org-quip--diff-org-and-quip quip-html new-html)) (diff-text (org-quip--diff-org-and-quip quip-html new-html))
@ -639,7 +629,7 @@ The return value is a list of commands to execute against Quip."
((looking-at "\\+") ((looking-at "\\+")
(letrec ((new-id (nth new-line new-id-list)) (letrec ((new-id (nth new-line new-id-list))
(new-pos (nth new-line new-pos-list)) (new-pos (nth new-line new-pos-list))
(new-html (org-quip--export-html-fragment buffer (new-html (org-quip--export-html-fragment org-buffer
(car new-pos) (car new-pos)
(cdr new-pos)))) (cdr new-pos))))
(setq insert-commands (setq insert-commands
@ -689,31 +679,34 @@ The return value is a list of commands to execute against Quip."
new-html new-html
old-html))) old-html)))
;; Invoke all of the diff commands on quip. (message "COMMANDS: %s" diff-commands)
(mapc (lambda (command)
(cond ((eq 'remove (car command))
(quip-thread-delete-section thread-id (second command)))
((eq 'replace (car command)) ;; ;; Invoke all of the diff commands on quip.
(quip-thread-replace-section thread-id ;; (mapc (lambda (command)
(second command) ;; (cond ((eq 'remove (car command))
(third command) ;; (quip-thread-delete-section thread-id (second command)))
"html"))
((eq 'insert-after (car command)) ;; ((eq 'replace (car command))
(quip-thread-append-after thread-id ;; (quip-thread-replace-section thread-id
(second command) ;; (second command)
(third command) ;; (third command)
"html")) ;; "html"))
((eq 'prepend (car command)) ;; ((eq 'insert-after (car command))
(quip-thread-prepend thread-id (second command) "html")) ;; (quip-thread-append-after thread-id
)) ;; (second command)
diff-commands) ;; (third command)
;; "html"))
;; ((eq 'prepend (car command))
;; (quip-thread-prepend thread-id (second command) "html"))
;; ))
;; diff-commands)
;; Re-fetch the HTML from quip and sync IDs. ;; Re-fetch the HTML from quip and sync IDs.
(setq old-html (alist-get 'html (quip-get-thread thread-id))) ;; (setq old-html (alist-get 'html (quip-get-thread thread-id)))
(org-quip--sync-ids-with-quip buffer new-html old-html)))) ;; (org-quip--sync-ids-with-quip buffer new-html old-html)
)))
(provide 'ox-quip) (provide 'ox-quip)
;;; ox-quip.el ends here ;;; ox-quip.el ends here