WIP:Convert (pandoc generated) HTML divs to org headings with properties

html-divs-to-org-headings.1.el

;; [WIP] DISCLAIMER This is a work in progress.
;;                    Don't use unless you really know what you're doing,
;;                    and under your sole responsibility.
;;                    Again, THIS CODE IS WITHOUT WARRANTY OF ANY KIND.
;;
;; [AUTHOR]  (c) 2017 Michelle Baert , under GPL-3.0 license.
;;
;; -------------------------------------------------------------------------
;; [GLOBALS] For convenience, this code uses a few global variables, that you can define
;;           in your *scratch* buffer or any other elisp context.
;;    tmp:org-source-buffer     Name or buffer of org file to transform.
;;                              Will stay unchanged in this version.
;;    tmp:org-dest-buffer       Name or buffer to write to.
;;                              Will be erased on each run.
;;                              Will be created if it doesn't exist.
;;                              Will include some tracing/debugging information.
;;                              Example: "*my-trace*"
;;    tmp:maxloops              Limit iterations to prevent freezing
;;
;; [TODO] publish as gist
;; -------------------------------------------------------------------------
;; Quoting un-used forms instead of commenting them out: formatting, font-lock, single-char toggles evaluation
'(with-current-buffer tmp:org-source-buffer
   (save-excursion
     (search-forward-regexp "^ *#\\+BEGIN_HTML")
     ;; (search-forward "#+BEGIN_HTML")
     (setq rslts
           (list
            (line-number-at-pos)
            (org-at-drawer-p)
            (org-at-block-p)
            (org-in-block-p '("SRC" "HTML") )
            (org-current-level)
            )
           ))
   ;; potentially useful
   ;;(org-id-find ID)
   )

;; TODO based on #'org-in-block-p
'(defun rr/org-get-block (names)
  "Non-nil when point belongs to a block whose name belongs to NAMES.

NAMES is a list of strings containing names of blocks.

Return first block name matched, or nil.  Beware that in case of
nested blocks, the returned name may not belong to the closest
block from point."
  (save-match-data
    (catch 'exit
      (let ((case-fold-search t)
            (lim-up (save-excursion (outline-previous-heading)))
            (lim-down (save-excursion (outline-next-heading))))
        (dolist (name names)
          (let* ((n (regexp-quote name))
                 (blk (org-between-regexps-p
                       (concat "^[ \t]*#\\+begin_" n)
                       (concat "^[ \t]*#\\+end_" n)
                       lim-up lim-down))
                 )
            (when blk
              (throw 'exit n))
            )))
      nil)))
;; (setq debug-on-error t)
(defun tmp:trace (&rest args)
  (with-current-buffer (get-buffer-create tmp:org-dest-buffer)
    (with-selected-window (display-buffer (current-buffer) t)
      (goto-char (buffer-end 1))
      (recenter)
      ;; (insert (apply #'pp-to-string args) "\n")
      (apply #'insert args)
      (insert "\n")
      ;; (set-mark (point)) ; trying to visualize point while debugging. Doesn't work.
      (sit-for 0.1)
      ))
  nil
  )

(defun rr/html-divs-to-org-headings()
  (interactive)
  (with-current-buffer (get-buffer-create tmp:org-dest-buffer)
    (display-buffer (current-buffer))
                                        ;(kill-region (point) (point-max) )
    (erase-buffer)
    (org-mode)
    (insert "* eval at " (time-stamp-string) "\n")
    )
  (let ((rslts ())
        (div-stack nil)
        base-level ; set later when in org buffer
        (maxloops tmp:maxloops)
        (keep-going (lambda(msg)
                      (or
                       ;; (tmp:trace "." msg)
                       (<= 0 (setq maxloops (1- maxloops)))
                       (tmp:trace "Loop limit reached - " msg)
                       )))
        )
    (with-current-buffer tmp:org-source-buffer
      (org-mode)
      (save-excursion
        (widen)
        (goto-char (org-find-entry-with-id "clean-from-here"))
        (org-show-entry)
        (setq base-level (or (org-current-level) 0))
        (while
            ;; outer loop condition
            (and
             (funcall keep-going "outer loop")
             (search-forward "#+BEGIN_HTML")
             (org-at-block-p)
             )
          ;; outer loop body
          (progn
            ;; (tmp:trace "*next-block*")
            (org-narrow-to-block)
            ;; TODO : try to narrow to contents of the block: #'rr/org-get-block
            (forward-line)
            (forward-same-syntax)
            ;; (thing-at-point--end-of-sexp)
            (while
                ;; inner loop condition (fat, repeat-until style)
                (let (
                      (p (point))
                      (e (sexp-at-point))
                      ;; (e (prin1-to-string(sexp-at-point)))
                      tag ;; will hold html tag contents
                      )
                  (tmp:trace (format "  - [@%d] %S (%s)" p e (type-of e)))
                  (and
                   (funcall keep-going "inner loop")
                   ;; (setq e (sexp-at-point))
                   ;; (unless e (tmp:trace "sexp is false") t)
                   (unless ; (unless t "foo") returns nil
                       (and e
                                        ;(string-match-p "^#+END_HTML" e) ; break inner loop
                            (eq '+END_HTML e) ; break inner loop
                            (prog1 t (tmp:trace "  * end-of-block*"))
                            )
                     ;; (push e rslts)
                     (when (eq ?< (char-after (point)))
                       (tmp:trace (format "  parsing tag %S" e))
                       (html-mode)
                       (forward-symbol 1)
                       (let ((p1 (point)))
                         (goto-char p)
                         (evil-jump-item)
                         (setq tag (buffer-substring-no-properties p1 (point)))
                         (tmp:trace (format "  parsed tag %S" tag))
                         (forward-symbol 1)
                         )
                       (org-mode)
                       (pcase e
                         ('<div (let ((lvl (+ base-level (length div-stack))))
                                  (tmp:trace (make-string lvl ?*) " div" )
                                  (tmp:trace ":PROPERTIES:")
                                  (tmp:trace ":lvl:" (number-to-string lvl))
                                  (tmp:trace ":div:"
                                             (subst-char-in-string ?\n ?\  tag)
                                             ;; (replace-regexp-in-string "\n" " " tag)
                                             )
                                  (tmp:trace ":END:")
                                  '(apply #'org-entry-put-multivalued-property
                                          (cons (point)
                                                (cons "div-tag_mv"
                                                      (split-string tmp:tag))))
                                  (push tag div-stack)
                                  ))
                         ('</div> (pop div-stack))
                         (sym (tmp:trace (format "ignoring: %S" sym)))
                         )
                       )
                                        ; return true
                     )
                   )
                  )
              ;; inner loop body
              (forward-sexp)
              ;; (forward-char)
                ;; (thing-at-point--end-of-sexp)
                ;; (set-mark (point))

              )                           ;/while inner loop

            (widen)

            ))                             ; /while html block found
        ))                              ; /with org buffer
    (with-current-buffer  tmp:org-dest-buffer
      (funcall keep-going "inner loop")
      (tmp:trace (format "rslts: %S" rslts))
      (tmp:trace (format "div-stack: %S" div-stack))
      )
    rslts
    )
  )
(setq debug-on-error t)
(rr/html-divs-to-org-headings)
(setq debug-on-error nil)