@@ -0,0 +1,407 @@
|
||||
(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]}]
|
||||
(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}
|
||||
[: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 "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)]])
|
||||
Reference in New Issue
Block a user