1cfb2b17df
Almost the same thing; it doesn't insert missing html, head and body tags, but in this case we only care about the stuff in the body.
112 lines
4.3 KiB
Clojure
112 lines
4.3 KiB
Clojure
(ns cryogen-core.toc
|
|
(:require [clojure.zip :as z]
|
|
[net.cgrand.enlive-html :as enlive]
|
|
[hiccup.core :as hiccup]))
|
|
|
|
(def _h [:h1 :h2 :h3 :h4 :h5 :h6])
|
|
|
|
(defn- compare-index [i1 i2] (- (.indexOf ^clojure.lang.APersistentVector _h i2) (.indexOf ^clojure.lang.APersistentVector _h i1)))
|
|
|
|
(defn- get-headings
|
|
"Turn a body of html content into a vector of elements whose tags are
|
|
headings."
|
|
[content]
|
|
(reduce
|
|
(fn [headings {:keys [tag attrs content] :as elm}]
|
|
(if (some #{tag} _h)
|
|
(conj headings elm)
|
|
(if-let [more-headings (get-headings content)]
|
|
(into headings more-headings)
|
|
headings)))
|
|
[] content))
|
|
|
|
(defn- zip-toc-tree-to-insertion-point
|
|
"Given a toc-tree zipper and a header level, navigate
|
|
the zipper to the appropriate parent of the level for that header
|
|
to be inserted and return the zipper."
|
|
[toctree h-tag]
|
|
(if-let [current-tag (-> toctree first :value :tag)]
|
|
(let [direction (compare-index h-tag current-tag)]
|
|
(cond (zero? direction) (z/up toctree) ; Tag belongs at current level
|
|
(neg? direction) toctree ; Tag belongs below this level
|
|
(pos? direction) (recur (z/up toctree) h-tag))) ; Keep looking up
|
|
; This level is the root list, return it
|
|
toctree))
|
|
|
|
(defn- insert-toc-tree-entry
|
|
"Inserts a toc-tree (zipper) entry for the given entry at the appropriate place.
|
|
Obeys the invariant that the toc-tree (zipper) is always moved to the inserted loc."
|
|
[tree entry]
|
|
(let [{htag :tag} entry
|
|
tree (zip-toc-tree-to-insertion-point tree htag)]
|
|
(-> tree (z/append-child {:children [] :value entry}) z/down z/rightmost)))
|
|
|
|
(defn- build-toc-tree
|
|
"Given a sequence of header nodes, build a toc tree using zippers
|
|
and return it."
|
|
[headings]
|
|
(loop [zp (z/zipper
|
|
map?
|
|
:children
|
|
(fn [node children] (assoc node :children (apply vector children)))
|
|
{:value :root :children []})
|
|
items headings]
|
|
(if-let [{tag :tag {id :id} :attrs [{{name :name} :attrs} title :as htext] :content} (first items)]
|
|
(let [anchor (or id name)]
|
|
(if (nil? anchor)
|
|
(recur zp (rest items))
|
|
(recur (insert-toc-tree-entry zp
|
|
{:tag tag
|
|
:anchor anchor
|
|
:text (or
|
|
(if (string? title) title (-> title :content first))
|
|
(first htext))})
|
|
(rest items))))
|
|
(z/root zp))))
|
|
|
|
|
|
(defn- make-toc-entry
|
|
"Given an anchor link and some text, construct a toc entry
|
|
consisting of link to the anchor using the given text, wrapped
|
|
in an <li> tag."
|
|
[anchor text]
|
|
(when (and anchor text)
|
|
[:li [:a {:href (str "#" anchor)} text]]))
|
|
|
|
|
|
(defn- build-toc
|
|
"Given the root of a toc tree and either :ol or :ul,
|
|
generate the table of contents and return it as a hiccup tree."
|
|
[toc-tree list-open & {:keys [outer-list?] :or {outer-list? true}}]
|
|
(let [{:keys [children], {:keys [anchor text]} :value} toc-tree
|
|
li (make-toc-entry anchor text)
|
|
first-list-open (if outer-list?
|
|
(keyword (str (name list-open) ".content"))
|
|
list-open)]
|
|
; Create hiccup sequence of :ol/:ul tag and sequence of :li tags
|
|
(if (seq children)
|
|
(let [sublist [first-list-open (map build-toc children
|
|
(repeat list-open)
|
|
(repeat :outer-list?)
|
|
(repeat false))]]
|
|
(if-let [li li] ; The root element has nothing so ignore it
|
|
(seq [li sublist]) ; Use seq to lazily concat the li with the sublists
|
|
sublist))
|
|
li))) ; Or just return the naked :li tag
|
|
|
|
(defn generate-toc
|
|
"Reads an HTML string and parses it for headers, then returns a list of links
|
|
to them.
|
|
|
|
Optionally, a map of :list-type can be provided with value :ul, :ol, or true.
|
|
:ol and true will result in an ordered list being generated for the table of
|
|
contents, while :ul will result in an unordered list. The default is an
|
|
ordered list."
|
|
[html & {:keys [list-type] :or {list-type :ol}}]
|
|
(let [list-type (if (true? list-type) :ol list-type)]
|
|
(-> html
|
|
(enlive/html-snippet)
|
|
(get-headings)
|
|
(build-toc-tree)
|
|
(build-toc list-type)
|
|
(hiccup/html))))
|
