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

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

@ -43,35 +43,28 @@ 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 />."
(cond (let ((new-contents nil))
((null contents) nil) (while contents
(cond
((stringp (car contents))
; Process strings. (if (stringp (cadr contents))
((stringp (car contents)) (setq contents (cons (concat (car contents) (cadr contents))
(let ((this (car contents)) (cddr contents)))
(rest (cdr contents))) (setq new-contents (cons (car contents) new-contents))
(setq contents (cdr contents))))
(while (stringp (car rest)) (t
(setq this (concat this (car rest))) (letrec ((this (car contents))
(setq rest (cdr rest))) (new-tag (car this))
(new-attrs (cadr this))
(new-contents (org-quip--clean-element-strings (cddr this)
new-tag))
(new-elem (append (list new-tag new-attrs) new-contents)))
(setq new-contents (cons new-elem new-contents))
(setq contents (cdr contents))))))
(setq this (org-quip--clean-string this tag)) (nreverse new-contents)))
(setq rest (org-quip--clean-element-strings rest tag))
(if (> (length this) 0)
(cons this rest)
rest)))
; Recurse into elements.
(t
(letrec ((this (car contents))
(new-tag (car this))
(new-attrs (cadr this))
(new-contents (org-quip--clean-element-strings (cddr this)
new-tag))
(new-elem (append (list new-tag new-attrs) new-contents)))
(cons new-elem
(org-quip--clean-element-strings (cdr contents) tag))))
))
(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."
(cond (let ((new-contents nil))
((null contents) nil) (while contents
(cond
;; Strings are strings.
((stringp (car contents))
(setq new-contents (cons (car contents) new-contents))
(setq contents (cdr contents)))
; Ignore strings for now, we'll get ;; <br /> is "\n".
; them in another pass. ((eq (caar contents) 'br)
((stringp (car contents)) (setq new-contents (cons "\n" new-contents))
(cons (car contents) (setq contents (cdr contents)))
(org-quip--clean-element-contents (cdr contents) tag strip)))
; <br> is "\n". ;; This might be an element we're unfolding...
((eq (caar contents) 'br) ((or (member (caar contents) '(div html body span))
(cons "\n" (and (eq (caar contents) 'a)
(org-quip--clean-element-contents (cdr contents) tag strip))) (cdar contents)
(not (alist-get 'href (cdar contents)))))
(setq contents (append (cddar contents) (cdr contents))))
; Is this an element we're unfolding? ;; This is an element we're keeping.
((or (member (caar contents) '(div html body span)) (t
(and (eq (caar contents) 'a) (letrec ((el-keep (car contents))
(cdar contents) (new-tag (car el-keep))
(not (alist-get 'href (cdar contents))))) (new-id (org-quip--get-element-id el-keep))
(org-quip--clean-element-contents (append (cddar contents) (cdr contents)) (attribs (when (or (not strip)
tag (member new-tag '(h1 h2 h3 h4 h5 h6)))
strip)) `((id . ,new-id))))
(body (org-quip--clean-element-contents (cddr el-keep)
new-tag
strip))
(new-elem (append (list new-tag attribs) body)))
; This is an element we're keeping. (setq new-contents (cons new-elem new-contents))
(t (setq contents (cdr contents))))))
(letrec ((new-tag (caar contents))
(attribs (when (or (not strip)
(member new-tag '(h1 h2 h3 h4 h5 h6)))
(list
(cons 'id
(org-quip--get-element-id (car contents))))))
(body (org-quip--clean-element-contents (cddar contents)
new-tag
strip))
(new-elem (append (list new-tag attribs) body)))
(cons new-elem (nreverse new-contents)))
(org-quip--clean-element-contents (cdr contents) tag strip))))
))
(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