logseq/src/main/frontend/handler/export/opml.cljs

(ns frontend.handler.export.opml
  "export blocks/pages as opml"
  (:refer-clojure :exclude [map filter mapcat concat remove newline])
  (:require ["/frontend/utils" :as utils]
            [clojure.string :as string]
            [clojure.zip :as z]
            [frontend.db :as db]
            [frontend.extensions.zip :as zip]
            [frontend.handler.export.common :as common :refer
             [*state* raw-text simple-asts->string space]]
            [frontend.handler.export.zip-helper :refer [get-level goto-last
                                                        goto-level]]
            [frontend.state :as state]
            [frontend.util :as util :refer [concatv mapcatv removev]]
            [goog.dom :as gdom]
            [hiccups.runtime :as h]
            [frontend.format.mldoc :as mldoc]
            [promesa.core :as p]
            [frontend.config :as config]))

;;; *opml-state*
(def ^:private ^:dynamic
  *opml-state*
  {:outside-em-symbol nil})

;;; utils for construct opml hiccup
;; - a
;;   - b
;;     - c
;;   - d
;; [:outline
;;  {:text "a"}
;;  [:outline {:text "b"} [:outline {:text "c"}]]
;;  [:outline {:text "d"}]]

(defn- branch? [node] (= :outline (first node)))

(defn- outline-hiccup-zip
  [root]
  (z/zipper branch?
            rest
            (fn [node children] (with-meta (apply vector :outline children) (meta node)))
            root))

(def ^:private init-opml-body-hiccup
  (z/down (outline-hiccup-zip [:outline [:placeholder]])))

(defn- goto-last-outline
  "[:outline [:outline [:outline]]]
                       ^
                   goto here"

  [loc]
  (-> loc
      goto-last
      z/up))

(defn- add-same-level-outline-at-right
  [loc attr-map]
  {:pre [(map? attr-map)]}
  (-> loc
      (z/insert-right [:outline attr-map])
      z/right))

(defn- add-next-level-outline
  [loc attr-map]
  {:pre [(map? attr-map)]}
  (-> loc
      (z/append-child [:outline attr-map])
      goto-last-outline))

(defn- append-text-to-current-outline
  [loc text]
  (-> loc
      z/down
      (z/edit #(update % :text str text))
      z/up))

(defn- append-text-to-current-outline*
  "if current-level = 0(it's just `init-opml-body-hiccup`), need to add a new outline item."
  [loc text]
  (if (pos? (get-level loc))
    (append-text-to-current-outline loc text)
    ;; at root
    (-> loc
        z/down
        (add-same-level-outline-at-right {:text nil})
        (append-text-to-current-outline text))))

(defn- zip-loc->opml
  [hiccup title]
  (let [[_ _ & body] hiccup]
    (str
     "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"
     (utils/prettifyXml
      (h/render-html
       [:opml {:version "2.0"}
        [:head [:title title]]
        (concatv [:body] body)])))))

;;; utils for construct opml hiccup (ends)

;;; block/inline-ast -> hiccup & simple-ast

(declare inline-ast->simple-ast
         block-ast->hiccup)

(defn- emphasis-wrap-with
  [inline-coll em-symbol]
  (binding [*opml-state* (assoc *opml-state* :outside-em-symbol (first em-symbol))]
    (concatv [(raw-text em-symbol)]
             (mapcatv inline-ast->simple-ast inline-coll)
             [(raw-text em-symbol)])))

(defn- inline-emphasis
  [[[type] inline-coll]]
  (let [outside-em-symbol (:outside-em-symbol *opml-state*)]
    (case type
      "Bold"
      (emphasis-wrap-with
       inline-coll (if (= outside-em-symbol "*") "__" "**"))
      "Italic"
      (emphasis-wrap-with
       inline-coll (if (= outside-em-symbol "*") "_" "*"))
      "Underline"
      (binding [*opml-state* (assoc *opml-state* :outside-em-symbol outside-em-symbol)]
        (mapcatv (fn [inline] (cons space (inline-ast->simple-ast inline))) inline-coll))
      "Strike_through"
      (emphasis-wrap-with inline-coll "~~")
      "Highlight"
      (emphasis-wrap-with inline-coll "^^")
      ;; else
      (assert false (print-str :inline-emphasis type "is invalid")))))

;; FIXME: how to add newlines to opml text attr?
(defn- inline-break-line
  []
  [space])

(defn- inline-link
  [{full-text :full_text}]
  [(raw-text full-text)])

(defn- inline-nested-link
  [{content :content}]
  [(raw-text content)])

(defn- inline-subscript
  [inline-coll]
  (concatv [(raw-text "_{")]
           (mapcatv (fn [inline] (cons space (inline-ast->simple-ast inline))) inline-coll)
           [(raw-text "}")]))


(defn- inline-superscript
  [inline-coll]
  (concatv [(raw-text "^{")]
           (mapcatv (fn [inline] (cons space (inline-ast->simple-ast inline))) inline-coll)
           [(raw-text "}")]))

(defn- inline-footnote-reference
  [{name :name}]
  [(raw-text  "[" name "]")])

(defn- inline-cookie
  [ast-content]
  [(raw-text
    (case (first ast-content)
      "Absolute"
      (let [[_ current total] ast-content]
        (str "[" current "/" total "]"))
      "Percent"
      (str "[" (second ast-content) "%]")))])

(defn- inline-latex-fragment
  [ast-content]
  (let [[type content] ast-content
        wrapper (case type
                  "Inline" "$"
                  "Displayed" "$$")]
    [space (raw-text (str wrapper content wrapper)) space]))

(defn- inline-macro
  [{:keys [name arguments]}]
  (->
   (if (= name "cloze")
     (string/join "," arguments)
     (let [l (cond-> ["{{" name]
               (pos? (count arguments)) (conj "(" (string/join "," arguments) ")")
               true (conj "}}"))]
       (string/join l)))
   raw-text
   vector))

(defn- inline-entity
  [{unicode :unicode}]
  [(raw-text unicode)])

(defn- inline-timestamp
  [ast-content]
  (let [[type timestamp-content] ast-content]
    (-> (case type
          "Scheduled" ["SCHEDULED: " (common/timestamp-to-string timestamp-content)]
          "Deadline" ["DEADLINE: " (common/timestamp-to-string timestamp-content)]
          "Date" [(common/timestamp-to-string timestamp-content)]
          "Closed" ["CLOSED: " (common/timestamp-to-string timestamp-content)]
          "Clock" ["CLOCK: " (common/timestamp-to-string (second timestamp-content))]
          "Range" (let [{:keys [start stop]} timestamp-content]
                    [(str (common/timestamp-to-string start) "--" (common/timestamp-to-string stop))]))
        string/join
        raw-text
        vector)))

(defn- inline-email
  [{:keys [local_part domain]}]
  [(raw-text (str "<" local_part "@" domain ">"))])


(defn- inline-ast->simple-ast
  [inline]
  (let [[ast-type ast-content] inline]
    (case ast-type
      "Emphasis"
      (inline-emphasis ast-content)
      ("Break_Line" "Hard_Break_Line")
      (inline-break-line)
      "Verbatim"
      [(raw-text ast-content)]
      "Code"
      [(raw-text "`" ast-content "`")]
      "Tag"
      [(raw-text "#" (common/hashtag-value->string ast-content))]
      "Spaces"                          ; what's this ast-type for ?
      nil
      "Plain"
      [(raw-text ast-content)]
      "Link"
      (inline-link ast-content)
      "Nested_link"
      (inline-nested-link ast-content)
      "Target"
      [(raw-text (str "<<" ast-content ">>"))]
      "Subscript"
      (inline-subscript ast-content)
      "Superscript"
      (inline-superscript ast-content)
      "Footnote_Reference"
      (inline-footnote-reference ast-content)
      "Cookie"
      (inline-cookie ast-content)
      "Latex_Fragment"
      (inline-latex-fragment ast-content)
      "Macro"
      (inline-macro ast-content)
      "Entity"
      (inline-entity ast-content)
      "Timestamp"
      (inline-timestamp ast-content)
      "Radio_Target"
      [(raw-text (str "<<<" ast-content ">>>"))]
      "Email"
      (inline-email ast-content)
      "Inline_Hiccup"
      [(raw-text ast-content)]
      "Inline_Html"
      [(raw-text ast-content)]
      ("Export_Snippet" "Inline_Source_Block")
      nil
      (assert false (print-str :inline-ast->simple-ast ast-type "not implemented yet")))))

(defn- block-paragraph
  [loc inline-coll]
  (-> loc
      goto-last-outline
      (append-text-to-current-outline*
       (simple-asts->string
        (cons space (mapcatv inline-ast->simple-ast inline-coll))))))

(defn- block-heading
  [loc {:keys [title _tags marker level _numbering priority _anchor _meta _unordered _size]}]
  (let [loc (goto-last-outline loc)
        current-level (get-level loc)
        title* (mapcatv inline-ast->simple-ast title)
        marker* (and marker (raw-text marker))
        priority* (and priority (raw-text (common/priority->string priority)))
        simple-asts (removev nil? (concatv [marker* space priority* space] title*))
        ;; remove leading spaces
        simple-asts (drop-while #(= % space) simple-asts)
        s (simple-asts->string simple-asts)]
    (if (> level current-level)
      (add-next-level-outline loc {:text s})
      (-> loc
          (goto-level level)
          z/rightmost
          (add-same-level-outline-at-right {:text s})))))

(declare block-list)
(defn- block-list-item
  [loc {:keys [content items]}]
  (let [current-level (get-level loc)
        ;; if current loc node is empty(= {}),
        ;; the outline node is already created.
        loc (if (empty? (second (z/node loc)))
              loc
              (add-same-level-outline-at-right loc {:text nil}))
        loc* (reduce block-ast->hiccup loc content)
        loc** (if (seq items) (block-list loc* items) loc*)]
    (-> loc**
        (goto-level current-level)
        z/rightmost)))

(defn- block-list
  [loc list-items]
  (reduce block-list-item (add-next-level-outline loc {}) list-items))

(defn- block-example
  [loc str-coll]
  (append-text-to-current-outline* loc (string/join " " str-coll)))

(defn- block-src
  [loc {:keys [_language lines]}]
  (append-text-to-current-outline* loc (string/join " " lines)))

(defn- block-quote
  [loc block-ast-coll]
  (reduce block-ast->hiccup loc block-ast-coll))

(defn- block-latex-env
  [loc [name options content]]
  (append-text-to-current-outline*
   loc
   (str "\\begin{" name "}" options "\n"
        content "\n"
        "\\end{" name "}")))

(defn- block-displayed-math
  [loc s]
  (append-text-to-current-outline* loc s))

(defn- block-footnote-definition
  [loc [name inline-coll]]
  (let [inline-simple-asts (mapcatv inline-ast->simple-ast inline-coll)]
    (append-text-to-current-outline*
     loc
     (str "[^" name "]: " (simple-asts->string inline-simple-asts)))))

(defn- block-ast->hiccup
  [loc block-ast]
  (let [[ast-type ast-content] block-ast]
    (case ast-type
      "Paragraph"
      (block-paragraph loc ast-content)
      "Paragraph_line"
      (assert false "Paragraph_line is mldoc internal ast")
      "Paragraph_Sep"
      loc
      "Heading"
      (block-heading loc ast-content)
      "List"
      (block-list loc ast-content)
      ("Directive" "Results" "Property_Drawer" "Export" "CommentBlock" "Custom")
      loc
      "Example"
      (block-example loc ast-content)
      "Src"
      (block-src loc ast-content)
      "Quote"
      (block-quote loc ast-content)
      "Latex_Fragment"
      (append-text-to-current-outline* loc (simple-asts->string (inline-latex-fragment ast-content)))
      "Latex_Environment"
      (block-latex-env loc (rest block-ast))
      "Displayed_Math"
      (block-displayed-math loc ast-content)
      "Drawer"
      loc
      "Footnote_Definition"
      (block-footnote-definition loc (rest block-ast))
      "Horizontal_Rule"
      loc
      "Table"
      loc
      "Comment"
      loc
      "Raw_Html"
      loc
      "Hiccup"
      loc
      (assert false (print-str :block-ast->simple-ast ast-type "not implemented yet")))))

;;; block/inline-ast -> hiccup (ends)

;;; export fns
(defn- export-helper
  [content format options & {:keys [title] :or {title "untitled"}}]
  (let [remove-options (set (:remove-options options))
        other-options (:other-options options)]
    (binding [*state* (merge *state*
                             {:export-options
                              {:remove-emphasis? (contains? remove-options :emphasis)
                               :remove-page-ref-brackets? (contains? remove-options :page-ref)
                               :remove-tags? (contains? remove-options :tag)
                               :keep-only-level<=N (:keep-only-level<=N other-options)}})
              *opml-state* *opml-state*]
      (let [ast (mldoc/->edn content format)
            ast (mapv common/remove-block-ast-pos ast)
            ast (removev common/Properties-block-ast? ast)
            keep-level<=n (get-in *state* [:export-options :keep-only-level<=N])
            ast (if (pos? keep-level<=n)
                  (common/keep-only-level<=n ast keep-level<=n)
                  ast)
            ast* (common/replace-block&page-reference&embed ast)
            ast** (if (= "no-indent" (get-in *state* [:export-options :indent-style]))
                    (mapv common/replace-Heading-with-Paragraph ast*)
                    ast*)
            config-for-walk-block-ast (cond-> {}
                                        (get-in *state* [:export-options :remove-emphasis?])
                                        (update :mapcat-fns-on-inline-ast conj common/remove-emphasis)

                                        (get-in *state* [:export-options :remove-page-ref-brackets?])
                                        (update :map-fns-on-inline-ast conj common/remove-page-ref-brackets)

                                        (get-in *state* [:export-options :remove-tags?])
                                        (update :mapcat-fns-on-inline-ast conj common/remove-tags)

                                        (= "no-indent" (get-in *state* [:export-options :indent-style]))
                                        (update :mapcat-fns-on-inline-ast conj common/remove-prefix-spaces-in-Plain))
            ast*** (if-not (empty? config-for-walk-block-ast)
                     (mapv (partial common/walk-block-ast config-for-walk-block-ast) ast**)
                     ast**)
            hiccup (z/root (reduce block-ast->hiccup init-opml-body-hiccup ast***))]
        (zip-loc->opml hiccup title)))))

(defn export-blocks-as-opml
  "options: see also `export-blocks-as-markdown`"
  [repo root-block-uuids-or-page-uuid options]
  {:pre [(or (coll? root-block-uuids-or-page-uuid)
             (uuid? root-block-uuids-or-page-uuid))]}
  (util/profile
   :export-blocks-as-opml
   (let [content
         (if (uuid? root-block-uuids-or-page-uuid)
           ;; page
           (common/get-page-content root-block-uuids-or-page-uuid)
           (common/root-block-uuids->content repo root-block-uuids-or-page-uuid))
         title (if (uuid? root-block-uuids-or-page-uuid)
                 (:block/title (db/entity [:block/uuid root-block-uuids-or-page-uuid]))
                 "untitled")
         first-block (and (coll? root-block-uuids-or-page-uuid)
                          (db/entity [:block/uuid (first root-block-uuids-or-page-uuid)]))
         format (or (:block/format first-block) (state/get-preferred-format))]
     (export-helper content format options :title title))))

(defn- export-files-as-opml
  "options see also `export-blocks-as-opml`"
  [files options]
  (mapv
   (fn [{:keys [path content title format]}]
     (when (and title (not (string/blank? content)))
       (util/profile (print-str :export-files-as-opml path)
                     [path (export-helper content format options :title title)])))
   files))

(defn export-repo-as-opml!
  [repo]
  (p/let [files (common/<get-file-contents repo "opml")]
    (when (seq files)
      (let [repo (-> repo
                     (string/replace config/db-version-prefix "")
                     (string/replace config/local-db-prefix ""))
            files (->> (export-files-as-opml files nil)
                       (clojure.core/remove nil?))
            zip-file-name (str repo "_opml_" (quot (util/time-ms) 1000))]
        (p/let [zipfile (zip/make-zip zip-file-name files repo)]
          (when-let [anchor (gdom/getElement "export-as-opml")]
            (.setAttribute anchor "href" (js/window.URL.createObjectURL zipfile))
            (.setAttribute anchor "download" (.-name zipfile))
            (.click anchor)))))))

;;; export fns (ends)