400 lines
13 KiB
Clojure
400 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.native :as tex-native]
|
||
[net.deertopia.doerg.tex.temml :as tex-temml]
|
||
[clojure.zip :as z]
|
||
[babashka.fs :as fs]))
|
||
|
||
;;; 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 *document-info*)
|
||
|
||
(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)))))))
|
||
|
||
(defn org-document
|
||
"Recursively render an Org-mode document to Hiccup."
|
||
[doc]
|
||
(tex-temml/binding-worker
|
||
(let [rendered (-> doc gather-footnotes render-tex-snippets
|
||
org-element-recursive)]
|
||
[:html
|
||
[:head
|
||
[:title "org document"]
|
||
doerg-html/head]
|
||
[:body
|
||
[:article
|
||
rendered]]])))
|
||
|
||
(defn to-html
|
||
"Read `f` with `slurp` as an Org document and return a string of
|
||
rendered HTML."
|
||
[f]
|
||
(str (hiccup/html {} (-> f slurp element/read-string org-document))))
|
||
|
||
|
||
;;; 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- 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- read-and-patch-generated-svg [{:keys [file height depth]}]
|
||
;; dvisvgm writes standalone SVG files, to which we need to make a
|
||
;; few changes to use them inline within our HTML.
|
||
;; • XML header: Bad syntax when embedded in an HTML doc. Remove
|
||
;; it.
|
||
;; • Width and height: We override these with our own values
|
||
;; computed by `net.deertopia.doerg.tex` to ensure correct
|
||
;; positioning relative to the surrounding text. More
|
||
;; accurately, we remove the height and width attributes from
|
||
;; the SVG tag, and set the new values for height and
|
||
;; vertical-align in the style attribute
|
||
;; • Viewbox: Must be removed entirely for correct positioning.
|
||
(-> (slurp file)
|
||
(str/replace-first "<?xml version='1.0' encoding='UTF-8'?>" "")
|
||
(str/replace-first #" height=['\"][^\"']+[\"']" "")
|
||
(str/replace-first #" width=['\"][^\"']+[\"']" "")
|
||
(str/replace-first
|
||
#"viewBox=['\"][^\"']+[\"']"
|
||
(fn [s]
|
||
(format "%s style=\"%s\""
|
||
s
|
||
(format "height:%.4fem;vertical-align:%.4fem;display:inline-block"
|
||
height (- depth)))))))
|
||
|
||
(defn- render-tex-snippets [doc]
|
||
(let [promises (atom [])
|
||
r (->> doc (sp/transform
|
||
[element/postorder-walker
|
||
#(element/of-type?
|
||
% "latex-fragment" "latex-environment")]
|
||
(fn [node]
|
||
(let [p (promise)]
|
||
(swap! promises #(conj % {:promise p :node node}))
|
||
(assoc node ::rendered p)))))
|
||
f (fn []
|
||
(fs/with-temp-dir [svg-dir {:prefix "doerg-svg"}]
|
||
(let [rendered-snippets
|
||
(delay (->> @promises
|
||
(map #(-> % :node :value))
|
||
(apply tex-native/render svg-dir)))]
|
||
(doseq [{:keys [promise node]} @promises]
|
||
(try (let [{:keys [value]} node
|
||
temml (tex-temml/render value)]
|
||
(if (tex-temml/erroneous-output? temml)
|
||
(let [tex (get @rendered-snippets value)]
|
||
(if (:errors tex)
|
||
(deliver promise (hiccup/raw temml))
|
||
(->> tex
|
||
read-and-patch-generated-svg
|
||
hiccup/raw
|
||
(deliver promise))))
|
||
(deliver promise (hiccup/raw temml))))
|
||
(catch Exception e
|
||
(prn e)
|
||
(flush)
|
||
(throw e))))
|
||
(when (fs/exists? "/tmp/doerg-svgs")
|
||
(fs/delete-tree "/tmp/doerg-svgs"))
|
||
(fs/copy-tree svg-dir "/tmp/doerg-svgs"))))]
|
||
(future-call (bound-fn* f))
|
||
r))
|
||
|
||
(comment
|
||
(render-tex-snippets doc))
|
||
|
||
|
||
|
||
(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.latex-fragment
|
||
(-> e ::rendered (deref #_#_ 2000 "«timed out»"))])
|
||
|
||
(defmethod org-element "latex-environment" [{:keys [value] :as e}]
|
||
[:span.latex-fragment
|
||
(-> e ::rendered (deref #_#_ 2000 "«timed out»"))])
|
||
|
||
(defmethod org-element "example-block" [{:keys [value]}]
|
||
[:pre value])
|
||
|
||
(defmethod org-element "src-block" [{:keys [value]}]
|
||
[:pre [:code value]])
|
||
|
||
(defmethod org-element "quote-block" [{:keys [children]}]
|
||
[:blockquote children])
|
||
|
||
(defmethod org-element "comment" [_] nil)
|
||
|
||
(defmethod org-keyword "TITLE" [{:keys [value]}]
|
||
[:h1 value])
|
||
|
||
;; Completely ignore the LATEX_COMPILER keyword.
|
||
(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)]])
|