;;; fleuron.el --- emacs lisp tools for org-fleuron -*- lexical-binding: t; -*-

;; Copyright (C) 2022  David O'Toole

;; Author: David O'Toole <dto@thexder>
;; Keywords: 

;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the "Software"), to deal in the Software without
;; restriction, including without limitation the rights to use, copy,
;; modify, merge, publish, distribute, sublicense, and;or sell copies
;; of the Software, and to permit persons to whom the Software is
;; furnished to do so, subject to the following conditions:

;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.

;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

;;; Commentary:

;;

;;; Code:

(eval-when-compile (require 'cl))
(require 'cl-lib)

(defvar fleuron-directory "~/notebook")
(defvar fleuron-files '("fleuron.org" "critical.org" "apriori.org"))
(defvar fleuron-output-file "~/notebook/search.js")

;;; Creating the database for client-side search

(defun fleuron-escape-newlines (string)
  (with-temp-buffer
    (insert string)
    (goto-char (point-min))
    (replace-string "\n" (string ?\\ ?n))
    (buffer-substring-no-properties (point-min) (point-max))))

(defun fleuron-stringify-for-js (string)
  (if (null string) ""
    (let ((cleaned-string
           (with-temp-buffer
             (insert string)
             (goto-char (point-min))
             (replace-string "\\" "\\\\")
             (goto-char (point-min))
             (replace-string "'" "\\'")
             (goto-char (point-min))
             (buffer-substring-no-properties (point-min) (point-max)))))
      (concat "'" cleaned-string "'"))))

(defun fleuron-extract-dom (file)
  (with-temp-buffer
    (insert-file-contents-literally file)
    (libxml-parse-html-region (point-min) (point-max))))

(defun fleuron-render-dom (dom)
  (with-temp-buffer
    (dom-print dom t t)
    (buffer-substring-no-properties (point-min) (point-max))))

(defun fleuron-find-heading (dom div page)
  (let* ((parent (dom-parent dom div))
         (siblings (dom-non-text-children parent))
         (pos (cl-position div siblings :test 'eq)))
    (let ((heading (nth (1- pos) siblings)))
      (prog1 heading
        (message "HEADING: %S"
                 (list page
                       (dom-attr heading 'class)
                       (dom-attr heading 'id)
                       (dom-texts heading)))))))

(defun fleuron-cmp (a b)
  (cond
   ((or (eq 'footnotes (cl-first a))
        (eq 'footnotes (cl-first b)))
    nil)
   ((and (null a) (null b)) t)
   ((and (cl-first a) (null (cl-first b))) nil)
   ((and (null (cl-first a)) (cl-first b)) t)
   ((< (cl-first a) (cl-first b)) t)
   ((= (cl-first a) (cl-first b)) (fleuron-cmp (cl-rest a) (cl-rest b)))))

(defun myread (s) (read-from-string s))

(defun fleuron-sort-divs-cmp (a b)
  (let ((integers-a (mapcar #'car (mapcar #'myread (split-string (substring (dom-attr a 'id) 5) "\\-"))))
        (integers-b (mapcar #'car (mapcar #'myread (split-string (substring (dom-attr b 'id) 5) "\\-")))))
    (fleuron-cmp integers-a integers-b)))
    
(defun fleuron-remove-non-ascii ()
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (while (re-search-forward "[^\x00-\x7F]" nil t)
      (replace-match ""))))

(defun fleuron-preprocess-files (filespecs)
  (let ((arrays ()) 
        (output-file fleuron-output-file)
        (outputs ()))
    (dolist (filespec filespecs)
      (let ((file filespec))
        (let ((output ())
              (page 1))
          (with-temp-buffer
            (insert-file-contents-literally
             (expand-file-name (concat (file-name-sans-extension file) ".html")
                               fleuron-directory))
            (goto-char (point-min))
            (let* ((dom (libxml-parse-html-region (point-min) (point-max)))
                   (divs (dom-by-id dom (rx "text-" (one-or-more any))))
                   (sorted-divs (sort (cl-rest divs) #'fleuron-sort-divs-cmp)))
              (message "Found %d divs..." (length divs))
              (mapc #'(lambda (div)
                        (let* ((id (dom-attr div 'id))
                               (class (dom-attr div 'class)))
                          (when class
                            (let* ((heading (fleuron-find-heading dom div page))
                                   (content (dom-texts div))
                                   (title (dom-texts heading)))
                              (push
                               (list (concat (file-name-sans-extension file) ".html")
                                     title
                                     content
                                     page)
                               output))
                            (cl-incf page))
                             ))
                    sorted-divs)))
          (push output outputs))))
    (message "Processing...")
    (with-temp-buffer
      (insert "FleuronSearchData = [")
      (dolist (output outputs)
        (when output
          (dolist (tuple (reverse output))
            (cl-destructuring-bind (file title content page) tuple
              (insert (concat "['" file "', "
                              (fleuron-escape-newlines
                               (fleuron-stringify-for-js title))
                              ", "
                              (fleuron-escape-newlines
                               (fleuron-stringify-for-js title))
                              ", "
                              ))
              (insert (concat (fleuron-escape-newlines
                               (fleuron-stringify-for-js content))
                              ", "))
              (insert (concat (format "%d" page) ", "))
              (insert "''],")))))
      (insert "[]];")
      (fleuron-remove-non-ascii)
      (write-file output-file))))

(defun fleuron-make-index (&optional ignore)
  (interactive)
  (fleuron-preprocess-files fleuron-files))

;;; Processing Agenda data

(defun fleuron-capture-agenda-csv ()
  (save-excursion 
    (with-output-to-string "*csv*"
                           (org-batch-agenda-csv "a"
                                                 org-agenda-span
                                                 10
                                                 org-agenda-include-inactive-timestamps
                                                 t
                                                 org-agenda-skip-timestamp-if-done
                                                 nil
                                                 org-agenda-show-all-dates
                                                 t
                                                 org-agenda-skip-scheduled-if-done
                                                 nil
                                                 ))))

(defun fleuron-capture-agenda ()
  (interactive)
  (save-window-excursion
    (let ((csv (fleuron-capture-agenda-csv)))
      (with-temp-buffer
        (insert csv)
        (write-file (expand-file-name "agenda.csv" fleuron-directory))
        csv))))
  
(defun fleuron-parse-csv (csv)
  (with-temp-buffer
    (insert csv)
    (goto-char (point-min))
    (let (lines)
      (while (not (eobp))
        (push (split-string (buffer-substring-no-properties (point-at-bol) (point-at-eol)) ",")
              lines)
        (next-line 1)
        (beginning-of-line))
      (reverse lines))))

(defun fleuron-csv-index (field)
  (cl-position field '("category" "head" "type" "todo" "tags" "date" "time" "extra" "priority-letter" "priority-number" "agenda-day") :test 'equal))

(defun fleuron-repair-time-string (string)
  (let ((tuple (split-string string "-")))
    (let ((integers (mapcar #'car (mapcar #'read-from-string tuple))))
      (apply #'format "%04d-%02d-%02d" integers))))

;; FIXME this function needs to be broken up.
(defun fleuron-csv-to-org (csv)
  (switch-to-buffer (get-buffer-create "agenda.org"))
  (delete-region (point-min) (point-max))
  ;; The below #'insert doesn't work because Org already inserts a
  ;; <title> no matter what.  So we change the title in JavaScript
  ;; instead.  (insert "#+TITLE: Org Agenda\n")
  (insert "#+OPTIONS: html-postamble:nil\n")
  (insert "
#+begin_export html
<script type=\"text/javascript\" src=\"fleuron.js\"></script>
<script type=\"text/javascript\">
document.title = \"Agenda | "
          (format-time-string "%4Y-%02m-%02d")
          "\";
window.onload = FleuronAgendaOnLoad;
</script>
#+end_export
")
  (insert "#+ATTR_HTML: :class fleuron-agenda-table :id FleuronAgendaTable\n")
  (insert "| Day | Date | Time | Task | Type | Category |\n|- \n")
  (cl-labels ((index (c f)
                (nth (fleuron-csv-index f)
                     c)))
    (let ((lines (fleuron-parse-csv csv))
          (line-history (make-hash-table :test 'equal))
          (last-date "")
          (flag nil)
          (today (format-time-string "%4Y-%02m-%02d")))
      (cl-labels ((todayp (date) (string= today date))
                  (already-seen-p (line)
                    (or (gethash line line-history)
                        (prog1 nil (setf (gethash line line-history) t)))))
        (dolist (line lines)
          (cl-labels ((ix (f) (index line f)))
            (let ((agenda-day (fleuron-repair-time-string (ix "agenda-day"))))
              (let ((day-of-week (let ((date (date-to-time agenda-day)))
                                 (format-time-string "%A" date))))
              (when (and (< 0 (length (ix "head")))
                         (not (string= (ix "type") "upcoming-deadline"))
                         (not (already-seen-p line)))
                (if (zerop (length last-date))
                    (setf last-date agenda-day flag t)
                  (if (string= last-date agenda-day)
                      (setf flag nil)
                    (setf flag t last-date agenda-day)))
                (let* ((raw-heading (ix "head"))
                       (heading (if (not (= 0 (length raw-heading)))
                                    (if (not (cl-every #'(lambda (x)
                                                           (= x ? ))
                                                       (coerce raw-heading 'list)))
                                        raw-heading
                                      "")
                                  "")))
                  (progn (insert "|")
                         (insert (mapconcat #'identity (list
                                                        (if (not flag) "" day-of-week)
                                                        (if (not flag) "" agenda-day)
                                                        (ix "time")

                                                        (if (not (= 0 (length (ix "type"))))
                                                            (if (or (string= (ix "type") "timestamp")
                                                                    (string= (ix "todo") "DONE"))
                                                                (concatenate 'string "☑ " heading)
                                                              (concatenate 'string "☐ " heading))
                                                          "")
                                                        (if (string= (ix "type") "deadline")
                                                            (concatenate 'string "=" (ix "type") "=")
                                                          (if (string= (ix "type") "timestamp")
                                                              (concatenate 'string "_timestamp_")
                                                            (ix "type")))
                                                        (ix "category")
                                                        )
                                            " | ")
                                 "|\n"))))))))
        ;;
        (goto-char (point-min))
        ;; remove funny characters from org lines
        (while (re-search-forward "┄" nil t)
          (replace-match ""))
        (write-file (expand-file-name "agenda.org" fleuron-directory))))))

(provide 'fleuron)
;;; fleuron.el ends here