413 lines
13 KiB
Clojure
413 lines
13 KiB
Clojure
(ns net.deertopia.doerg.render
|
||
(:require [net.deertopia.doerg.element :as element]
|
||
[clojure.stacktrace]
|
||
[clojure.string :as str]
|
||
[clojure.tools.logging :as l]
|
||
[clojure.core.match :refer [match]]
|
||
[clojure.tools.logging.readable :as lr]
|
||
[com.rpl.specter :as sp]
|
||
[net.deertopia.doerg.html :as doerg-html]
|
||
[hiccup2.core :as hiccup]
|
||
[clojure.pprint]
|
||
[net.deertopia.doerg.tex :as tex]
|
||
[net.deertopia.doerg.tex.temml :as tex-temml]
|
||
[clojure.zip :as z]
|
||
[babashka.fs :as fs]
|
||
[clojure.edn :as edn]))
|
||
|
||
;;; Top-level API
|
||
|
||
(defmulti org-element
|
||
"Render an Org element to Hiccup."
|
||
#(do (assert (element/org-element? %)
|
||
"Not an org-node!")
|
||
(:type %)))
|
||
|
||
(defmulti org-link
|
||
"Render an Org-mode link element to Hiccup. Dispatches on link
|
||
type/protocol."
|
||
#(do (assert (element/of-type? % "link"))
|
||
(:link-type %)))
|
||
|
||
(defmulti org-special-block
|
||
"Render an Org-mode special block to Hiccup. Dispatches on special
|
||
block type (as in #+begin_«type» … #+end_«type»)."
|
||
#(do (assert (element/of-type? % "special-block"))
|
||
(:block-type %)))
|
||
|
||
(defmulti org-keyword
|
||
"Render an Org-mode keyword."
|
||
#(do (assert (element/of-type? % "keyword"))
|
||
(:key %)))
|
||
|
||
(def ^:dynamic ^:private *opts*)
|
||
|
||
(declare ^:private gather-footnotes render-renderer-error
|
||
view-children-as-seq render-tex-snippets)
|
||
|
||
(defn org-element-recursive
|
||
"Recursively render an Org-mode element to Hiccup."
|
||
[e]
|
||
(->> e
|
||
(sp/transform
|
||
[element/postorder-walker view-children-as-seq]
|
||
(fn [node]
|
||
(try (org-element node)
|
||
(catch Throwable e
|
||
(lr/error e "Error in renderer" {:node node})
|
||
(render-renderer-error e)))))))
|
||
|
||
(def default-language
|
||
"Default language, used in the lang attribute of the body tag."
|
||
"en")
|
||
|
||
(defn org-document
|
||
"Recursively render an Org-mode document to Hiccup."
|
||
[doc & {:as opts :keys [postamble header]}]
|
||
(binding [*opts* opts]
|
||
(tex-temml/binding-worker
|
||
(let [rendered (-> doc gather-footnotes render-tex-snippets
|
||
org-element-recursive)]
|
||
[:html
|
||
[:head
|
||
[:title "org document"]
|
||
doerg-html/head]
|
||
[:body {:lang default-language}
|
||
(when header
|
||
[:header header])
|
||
[:article
|
||
rendered
|
||
(when postamble
|
||
[:footer
|
||
[:hr]
|
||
postamble])]]]))))
|
||
|
||
(defn to-html
|
||
"Read `f` with `slurp` as an Org document and return a string of
|
||
rendered HTML. See `org-document` for opts."
|
||
[f & {:as opts}]
|
||
(str (hiccup/html {} (-> f slurp element/read-string (org-document opts)))))
|
||
|
||
|
||
;;; Further dispatching on `org-element`
|
||
|
||
(defmethod org-element "keyword" [e]
|
||
(org-keyword e))
|
||
|
||
(defmethod org-element "link" [e]
|
||
(org-link e))
|
||
|
||
(defmethod org-element "special-block" [e]
|
||
(org-special-block e))
|
||
|
||
|
||
|
||
(def view-children-as-seq
|
||
"Specter path that converts any vectors of :children to lists so
|
||
Hiccup correctly interprets children as lists of elements rather
|
||
than a single malformed element."
|
||
(sp/if-path element/greater-element?
|
||
(sp/view #(update % :children seq))
|
||
sp/STAY))
|
||
|
||
(defn center [& es]
|
||
[:div.center es])
|
||
|
||
(defn doerg-attrs [e]
|
||
(->> e :affiliated :attr_doerg (str/join " ")
|
||
(format "{%s}") edn/read-string))
|
||
|
||
(defn em [x]
|
||
(format "%.4fem" x))
|
||
|
||
(defn wrap-if [x c f]
|
||
(if c (f x) x))
|
||
|
||
(defn- contains-footnote-refs? [node]
|
||
(some #(element/of-type? % "footnote-reference")
|
||
(:children node)))
|
||
|
||
(defn- gather-footnotes
|
||
"Traverse document and reposition footnote-definitions to
|
||
immediately follow their first references. Removes the footnotes
|
||
section from the document."
|
||
[doc]
|
||
(let [fn-defs (->> doc
|
||
(sp/select
|
||
[element/children-walker element/footnotes-section?
|
||
element/children-walker
|
||
#(element/of-type? % "footnote-definition")
|
||
(sp/view (fn [d]
|
||
{(:label d) d}))])
|
||
(apply merge))
|
||
encountered (atom #{})]
|
||
(->> doc
|
||
(sp/transform
|
||
[element/postorder-walker
|
||
contains-footnote-refs?]
|
||
(fn [node]
|
||
(assoc node :children
|
||
(->> (for [n (:children node)]
|
||
(let [label (:label n)]
|
||
(if (and (element/of-type? n "footnote-reference")
|
||
(not (@encountered label)))
|
||
(do (swap! encountered #(conj % label))
|
||
(list n (get fn-defs label)))
|
||
(list n))))
|
||
(apply concat)))))
|
||
(sp/setval [element/children-walker
|
||
element/footnotes-section?]
|
||
sp/NONE))))
|
||
|
||
(defn- collect-latex-headers [doc]
|
||
(->> doc
|
||
(sp/select
|
||
[element/postorder-walker
|
||
#(element/of-keyword-type? % "LATEX_HEADER")
|
||
(sp/view :value)])))
|
||
|
||
(defn- timeout-snippet-promises [snippet-promises fut]
|
||
;; Time out after twenty seconds. With all the LaTeX and IPC, there
|
||
;; are so many opportunities for things to go wrong </3.
|
||
(let [ms (* 20 1000)
|
||
fut-res (deref fut ms ::timed-out)]
|
||
(if (= fut-res ::timed-out)
|
||
(do (l/warnf "Giving up on rendering TeX snippets after %.3f seconds."
|
||
(/ ms 1000))
|
||
(future-cancel fut)
|
||
(doseq [[_snippet p] snippet-promises]
|
||
(deliver p ::timed-out)))
|
||
fut-res)))
|
||
|
||
(defn render-tex-snippets
|
||
"Traverse doc, adorning each LaTeX node with a promise resolving to,
|
||
optimistically, Hiccup-rendered SVG or MathML code."
|
||
[doc]
|
||
(let [snippet-promises (atom [])
|
||
r (->> doc (sp/transform
|
||
[element/postorder-walker
|
||
#(element/of-type?
|
||
% "latex-fragment" "latex-environment")]
|
||
(fn [node]
|
||
(let [p (promise)]
|
||
(swap! snippet-promises #(conj % [(:value node) p]))
|
||
(assoc node ::rendered p)))))
|
||
sp @snippet-promises
|
||
fut (-> #(tex/render-snippets sp)
|
||
bound-fn* future-call)]
|
||
(timeout-snippet-promises sp fut)
|
||
r))
|
||
|
||
|
||
|
||
(defn render-pprint
|
||
"Render the argument inline as `clojure.pprint/pprint` output."
|
||
[x & {:keys [text]
|
||
:or {text "debug!"}}]
|
||
[:details
|
||
[:summary {:style {:font-family "IBM Plex Sans"}}
|
||
(if (:type x)
|
||
(list text " (" [:code (:type x)] ")")
|
||
text)]
|
||
[:samp {:style {:overflow "scroll"
|
||
:display "block"
|
||
:white-space "pre"}}
|
||
(with-out-str
|
||
(clojure.pprint/pprint x))]])
|
||
|
||
(defn- level->tag
|
||
"Convert a number 1–5 to a hiccup :h1, :h2, :h3, … tag."
|
||
[level]
|
||
(cond (<= 1 level 5) (keyword (str \h (+ level 1)))
|
||
:else :h5))
|
||
|
||
(defn- descriptive-list-item-components
|
||
"If `e` is an Org-mode descriptive list item, return a map {:dt x
|
||
:dd y} with the corresponding dt and dd tags. Otherwise, return
|
||
nil."
|
||
[e]
|
||
(match (:children e)
|
||
([[:dt & dts] & dds] :seq) {:dt (apply vector :dt dts)
|
||
:dd (apply vector :dd dds)}
|
||
_ nil))
|
||
|
||
(defn- same-tag? [x y]
|
||
(let [x* (-> x name (str/replace #"^([^\.#]).*" "$1") keyword)]
|
||
(= x* y)))
|
||
|
||
;; In HTML5, </p> tags cannot be nested for… reasons. In fact, no
|
||
;; block-level elements are allowed within paragraphs. This stupid
|
||
;; hack works around that restriction by stripping </p> tags }:).
|
||
(defn- strip-paragraphs [elements]
|
||
(apply concat
|
||
(for [x elements]
|
||
(match x
|
||
[(_ :guard #(same-tag? % :p)) (_ :guard map?) & xs]
|
||
(seq xs)
|
||
[(_ :guard #(same-tag? % :p)) & xs]
|
||
(seq xs)
|
||
_ x))))
|
||
|
||
|
||
|
||
(defn- render-renderer-error
|
||
"Render a `Throwable` to display within the document."
|
||
[e]
|
||
[:details
|
||
[:summary {:style {:font-family "IBM Plex Sans"}}
|
||
"Renderer error!"]
|
||
[:samp {:style {:overflow "scroll"
|
||
:display "block"
|
||
:white-space "pre"}}
|
||
(with-out-str
|
||
(clojure.stacktrace/print-stack-trace e))]])
|
||
|
||
(defmethod org-element "org-data"
|
||
[{:keys [children]}]
|
||
children)
|
||
|
||
(defmethod org-element "paragraph" [{:keys [children]}]
|
||
[:p children])
|
||
|
||
(defmethod org-element "text" [{:keys [value]}]
|
||
value)
|
||
|
||
(defmethod org-element "bold" [{:keys [children]}]
|
||
[:b children])
|
||
|
||
(defmethod org-element "strike-through" [{:keys [children]}]
|
||
[:s children])
|
||
|
||
(defmethod org-element "subscript" [{:keys [children]}]
|
||
[:sub children])
|
||
|
||
(defmethod org-element "superscript" [{:keys [children]}]
|
||
[:super children])
|
||
|
||
(defmethod org-element "italic" [{:keys [children]}]
|
||
[:em children])
|
||
|
||
(defmethod org-element "verbatim" [{:keys [value]}]
|
||
value)
|
||
|
||
(defmethod org-element "code" [{:keys [value]}]
|
||
[:code value])
|
||
|
||
(defmethod org-element "section" [{:keys [children]
|
||
:as section}]
|
||
(when-not (element/footnotes-section? section)
|
||
[:section
|
||
(or (seq children)
|
||
[:div.empty-section-message "This section is empty…"])]))
|
||
|
||
(defmethod org-element "headline" [{:keys [children level]}]
|
||
[(level->tag level) children])
|
||
|
||
(defmethod org-element "footnote-reference"
|
||
[{:keys [label]}]
|
||
;; FIXME: This will break if there are multiple references to a
|
||
;; single footnote, since `label` is assumed to be unique.
|
||
(list [:label.margin-toggle.sidenote-number {:for label}]
|
||
[:input.margin-toggle {:type "checkbox"
|
||
:id label}]))
|
||
|
||
(defmethod org-element "footnote-definition" [{:keys [children]}]
|
||
[:span.sidenote (strip-paragraphs children)])
|
||
|
||
(defmethod org-element "plain-list" [{:keys [list-type children]}]
|
||
(let [tag (case list-type
|
||
"descriptive" :dl
|
||
"unordered" :ul
|
||
"ordered" :ol)]
|
||
[tag children]))
|
||
|
||
(defmethod org-element "list-item" [{:keys [children] :as e}]
|
||
(if-some [{:keys [dt dd]} (descriptive-list-item-components e)]
|
||
(list dt dd)
|
||
[:li children]))
|
||
|
||
(defmethod org-element "list-item-tag" [{:keys [children]}]
|
||
[:dt children])
|
||
|
||
(defmethod org-element "property-drawer" [{:keys [children]}]
|
||
[:table.property-drawer {:hidden true}
|
||
[:tbody children]])
|
||
|
||
(defmethod org-element "node-property" [{:keys [key value]}]
|
||
[:tr [:th key] [:td value]])
|
||
|
||
(defmethod org-element "citation" [{:keys [prefix suffix children] :as e}]
|
||
;; TODO: Real citations.
|
||
[:span "[cite:" prefix children suffix "]"])
|
||
|
||
(defmethod org-element "citation-reference" [{:keys [key]}]
|
||
(str "@" key))
|
||
|
||
(defmethod org-element "latex-fragment" [{:keys [contents value] :as e}]
|
||
[:span {:class (if (element/display-math? e)
|
||
"latex-fragment display-math"
|
||
"latex-fragment")}
|
||
(-> e ::rendered deref)])
|
||
|
||
(defmethod org-element "latex-environment" [{:keys [value] :as e}]
|
||
[:span.latex-fragment.display-math
|
||
(-> e ::rendered deref)])
|
||
|
||
(defmethod org-element "example-block" [{:keys [value] :as e}]
|
||
(let [{:keys [center? alt scale img?]} (doerg-attrs e)]
|
||
(-> [:pre (merge (and img? {:role "img"
|
||
:aria-label alt
|
||
:title alt})
|
||
(and scale {:style {:font-size (em scale)}}))
|
||
value]
|
||
(wrap-if center? center))))
|
||
|
||
(defmethod org-element "src-block" [{:keys [value]}]
|
||
[:pre [:code value]])
|
||
|
||
(defn- split-quote-block-children [children]
|
||
(match (split-with #(not= % [:hr]) children)
|
||
[x ([[:hr] & ys] :seq)] [x (strip-paragraphs ys)]
|
||
x x))
|
||
|
||
(defmethod org-element "quote-block" [{:keys [children] :as e}]
|
||
(let [{:keys [epigraph?]} (doerg-attrs e)
|
||
[content footer] (split-quote-block-children children)]
|
||
(-> [:blockquote
|
||
content
|
||
(when footer
|
||
[:footer footer])]
|
||
(wrap-if epigraph? (fn [c] [:div.epigraph c])))))
|
||
|
||
(defmethod org-element "horizontal-rule" [_]
|
||
[:hr])
|
||
|
||
(defmethod org-element "comment" [_] nil)
|
||
|
||
(defmethod org-keyword "TITLE" [{:keys [value]}]
|
||
[:h1 value])
|
||
|
||
(defmethod org-keyword "LATEX_COMPILER" [_] nil)
|
||
(defmethod org-keyword "LATEX_HEADER" [_] nil)
|
||
|
||
;; Not sure how to deal with this one yet.
|
||
(defmethod org-keyword "AUTHOR" [_] nil)
|
||
|
||
(defmethod org-element :default [x]
|
||
(render-pprint x :text "unimplemented!"))
|
||
|
||
(defmethod org-keyword :default [x]
|
||
(render-pprint x :text "unimplemented!"))
|
||
|
||
(defmethod org-special-block "margin-note" [{:keys [children]}]
|
||
[:p [:span.marginnote (strip-paragraphs children)]])
|
||
|
||
#_
|
||
(defmethod org-special-block :default [x]
|
||
(render-pprint x :text "unimplemented!"))
|
||
|
||
(defmethod org-link :default [{:keys [raw-link children]}]
|
||
[:span.org-link.external
|
||
[:a {:href raw-link}
|
||
(or (seq children) raw-link)]])
|