transformers.cljc

(ns markdown.transformers
  (:require [clojure.string :as string]
            [clojure.edn :as edn]
            [markdown.links
             :refer [link
                     image
                     reference-link
                     image-reference-link
                     implicit-reference-link
                     footnote-link]]
            [markdown.lists :refer [li]]
            [markdown.tables :refer [table]]
            [markdown.common
             :refer
             [escape-code
              escaped-chars
              freeze-string
              thaw-strings
              strong
              bold
              bold-italic
              em
              italics
              strikethrough
              inline-code
              escape-inhibit-separator
              inhibit
              make-heading
              dashes]]
            #?(:clj [clj-yaml.core :as yaml])))

(def ^:dynamic *formatter*)

(defn heading? [text type]
  (when-not (every? #{\space} (take 4 text))
    (let [trimmed (some-> text string/trim)]
      (and (not-empty trimmed) (every? #{type} trimmed)))))

(defn h1? [text]
  (heading? text \=))

(defn h2? [text]
  (heading? text \-))

(defn empty-line [text {:keys [code codeblock] :as state}]
  (if (or code codeblock)
    [text state]
    [(if (or (h1? text) (h2? text)) "" text)
     (if (string/blank? text) (dissoc state :hr :heading) state)]))

(defn superscript [text state]
  (if (:code state)
    [text state]
    (let [tokens (partition-by (partial contains? #{\^ \space}) text)]
      (loop [buf       []
             remaining tokens]
        (cond
          (empty? remaining)
          [(string/join buf) state]

          (= (first remaining) [\^])
          (recur (into buf (concat (seq "<sup>") (second remaining) (seq "</sup>")))
                 (drop 2 remaining))

          :default
          (recur (into buf (first remaining)) (rest remaining)))))))

(defn heading [text {:keys [buf next-line code codeblock heading-anchors] :as state}]
  (cond
    (or codeblock code)
    [text state]

    (h1? (or buf next-line))
    [(str "<h1>" text "</h1>") (assoc state :heading true)]

    (h2? (or buf next-line))
    [(str "<h2>" text "</h2>") (assoc state :heading true)]

    :else
    (if-let [heading (make-heading text heading-anchors)]
      [heading (assoc state :inline-heading true)]
      [text state])))

(defn br [text {:keys [code lists] :as state}]
  [(if (and (= [\space \space] (take-last 2 text))
            (not (or code lists)))
     (str (apply str (drop-last 2 text)) "<br />")
     text)
   state])

(defn autourl-transformer [text {:keys [code frozen-strings] :as state}]
  (if code
    [text state]
    (let [currently-frozen (volatile! {:frozen-strings frozen-strings})]
      [(string/replace
         text
         #"<https?://[-A-Za-z0-9+&@#/%?=~_()|!:,.;]*[-A-Za-z0-9+&@#/%=~_()|]>"
         #(let [[url frozen-strings] (freeze-string (subs % 1 (dec (count %))) @currently-frozen)]
            (vreset! currently-frozen frozen-strings)
            (str "<a href=\"" url "\">" url "</a>")))
       (merge state @currently-frozen)])))

(defn autoemail-transformer [text state]
  (let [left-pad (fn [s]
                   (cond->> s
                            (= 1 (count s)) (str "0")))
        encoder  (if (:clojurescript state)
                   (fn [c] (str "&#x" (-> c (.charCodeAt 0) (.toString 16) left-pad) ";"))
                   (fn [c] (*formatter* "&#x%02x;" (int c))))]
    [(if (or (:code state) (:codeblock state))
       text
       (string/replace
         text
         #"<[\w._%+-]+@[\w.-]+\.[\w]{2,4}>"
         #(let [encoded (->> (subs % 1 (dec (count %)))
                             (map encoder)
                             (apply str))]
            (str "<a href=\"mailto:" encoded "\">" encoded "</a>"))))
     state]))

(defn set-line-state [text {:keys [inline-heading] :as state}]
  [text
   (-> state
       (dissoc :inline-heading)
       (assoc-in [:temp :inline-heading] inline-heading))])

(defn clear-line-state [text state]
  [text (dissoc state :temp)])

(defn paragraph-text [last-line-empty? text]
  (if (and (not last-line-empty?) (not-empty text))
    (str " " text)
    text))

(defn open-paragraph
  [text {:keys [eof heading inline-heading temp hr code lists blockquote paragraph last-line-empty?] :as state}]
  (cond
    (and paragraph lists)
    [(str "</p>" text) (dissoc state :paragraph)]

    (or heading inline-heading hr code lists blockquote)
    [text state]

    paragraph
    (if (or eof (empty? (string/trim text)))
      [(str (paragraph-text last-line-empty? text) "</p>") (dissoc state :paragraph)]
      [(paragraph-text last-line-empty? text) state])

    (and (not eof) (not (string/blank? text)) (or (:inline-heading temp) last-line-empty?))
    [(str "<p>" text) (assoc state :paragraph true :last-line-empty? false)]

    :default
    [text state]))

(defn close-paragraph [text {:keys [next-line paragraph] :as state}]
  (if (and paragraph (some-> next-line string/trim (string/ends-with? "```")))
    [(str text "</p>") (dissoc state :paragraph)]
    [text state]))

(defn paragraph [text state]
  (apply close-paragraph (open-paragraph text state)))

(defn code [text {:keys [eof indent-code-end next-line lists code codeblock paragraph] :as state}]
  (let [should-close? (or eof
                          (not (or (string/blank? next-line)
                                   (string/starts-with? next-line "    "))))]
    (cond
      (or lists codeblock)
      [text state]

      indent-code-end
      [text (-> state
                (dissoc :code :indent-code-end :indented-code)
                (assoc :last-line-empty? true))]

      code
      [(str (escape-code (string/replace-first text #"    " "\n"))
            (when should-close? "</code></pre>"))
       (cond-> state
         should-close? (assoc :indent-code-end true))]

      paragraph
      [text state]

      (empty? (string/trim text))
      [text state]

      :default
      (let [num-spaces (count (take-while (partial = \space) text))]
        (if (>= num-spaces 4)
          [(str "<pre><code>"
                (escape-code (string/replace-first text #"    " ""))
                (when should-close? "</code></pre>"))
           (cond-> (assoc state :code true :indented-code true)
             should-close? (assoc :indent-code-end true))]
          [text state])))))

(defn codeblock [text {:keys [codeblock-buf codeblock-lang codeblock-callback codeblock codeblock-end indented-code next-line lists] :as state}]
  (let [trimmed           (string/trim text)
        next-line-closes? (some-> next-line string/trim (string/ends-with? "```"))]
    (cond
      (and lists codeblock-end)
      ["" (dissoc state :code :codeblock :codeblock-end :codeblock-lang :codeblock-buf)]

      codeblock-end
      [text (-> state
                (assoc :last-line-empty? true)
                (dissoc :code :codeblock :codeblock-end :codeblock-lang :codeblock-buf))]

      (and next-line-closes? codeblock)
      (let [buffered-code (str codeblock-buf text \newline (apply str (first (string/split next-line #"```"))))]
        [(str (escape-code (str (if codeblock-callback (codeblock-callback buffered-code codeblock-lang) buffered-code))) "</code></pre>")
         (assoc state :skip-next-line? (not lists)
                      :codeblock-end true
                      :last-line-empty? (not lists))])

      (and
        (not indented-code)
        (string/starts-with? trimmed "```"))
      (let [[lang code] (split-with (partial not= \newline) (drop 3 trimmed))
            lang      (string/trim (string/join lang))
            s         (apply str (rest code))
            formatter (:code-style state)]
        [(str "<pre><code" (when (seq lang)
                             (str " "
                                  (if formatter
                                    (formatter lang)
                                    (str "class=\"" (string/join lang) "\"")))) ">"
              (escape-code (if (empty? s) s (str s "\n")))
              (when next-line-closes? "</code></pre>"))
         (if next-line-closes?
           (assoc state :codeblock-end true :skip-next-line? true)
           (assoc state :code true
                        :codeblock true
                        :codeblock-lang lang
                        :codeblock-buf ""))])

      codeblock
      ["" (assoc state :codeblock-buf (str codeblock-buf text \newline))] 

      :default
      [text state])))

(defn hr [text state]
  (if (:code state)
    [text state]
    (if (and
          (or (empty? (drop-while #{\* \space} text))
              (empty? (drop-while #{\- \space} text))
              (empty? (drop-while #{\_ \space} text)))
          (> (count (remove #{\space} text)) 2))
      [(str "<hr/>") (assoc state :hr true)]
      [text state])))

(defn blockquote-1
  "Check for blockquotes and signal to blockquote-2 function with
  states blockquote-start and blockquote-end so that tags can be added.
  This approach enables lists to be included in blockquotes."
  [text {:keys [eof code codeblock] :as state}]
  (let [trimmed (string/trim text)]
    (cond
      (or code codeblock)
      [text state]

      (:blockquote state)
      (cond (or eof (empty? trimmed))
            [text (assoc state :blockquote-end true :blockquote false)]

            (= ">" trimmed)
            [(str (when (:blockquote-paragraph state) "</p>") "<p>") (assoc state :blockquote-paragraph true)]

            (and (>= (count trimmed) 2) (= ">-" (subs trimmed 0 2)))
            [(str (when (:blockquote-paragraph state) "</p>") "<footer>" (subs text 2) "</footer>") (assoc state :blockquote-paragraph false)]

            (= ">" (subs trimmed 0 1))
            [(str (when-not (:blockquote-paragraph state) "<p>") (subs text 1) " ") (assoc state :blockquote-paragraph true)]

            :default
            [(str (when-not (:blockquote-paragraph state) "<p>") text " ") (assoc state :blockquote-paragraph true)])

      :default
      (if (= \> (first text))
        [(str (string/join (rest text)) " ")
         (assoc state :blockquote-start true :blockquote true :blockquote-paragraph true)]
        [text state]))))

(defn blockquote-2
  "Check for change in blockquote states and add start or end tags.
  Closing a blockquote with a list in it is a bit more complex,
  as the list is not closed until the following blank line."
  [text {:keys [blockquote-start blockquote-end blockquote-paragraph lists] :as state}]
  (let [not-in-list (or (not lists) (empty? lists))]
    (cond blockquote-start
          [(str "<blockquote><p>" text)
           (dissoc state :blockquote-start)]

          (and blockquote-end not-in-list)
          [(str text (when blockquote-paragraph "</p>") "</blockquote>")
           (dissoc state :blockquote :blockquote-paragraph :blockquote-end)]

          :default
          [text state])))

(defn footer [footnotes]
  (if (empty? (:processed footnotes))
    ""
    (->> (:processed footnotes)
         (into (sorted-map))
         (reduce
           (fn [footnotes [id label]]
             (str footnotes
                  "<li id='fn-" id "'>"
                  (apply str (interpose " " label))
                  "<a href='#fnref" id "'>&#8617;</a></li>"))
           "")
         (#(str "<ol class='footnotes'>" % "</ol>")))))

(defn parse-metadata-line
  "Given a line of metadata header text return either a list containing a parsed
  and normalizd key and the original text of the value, or if no header is found
  (this is a continuation or new value from a pervious header key) simply
  return the text. If a blank or invalid line is found return nil."
  [line]
  (when line
    (let [[_ key val] (re-matches #"^([0-9A-Za-z_-]*):(.*)$" line)
          [_ next-val] (re-matches #"^    (.*)$" line)]
      (when (not= (string/trim line) "")
        (cond
          key [(keyword (string/lower-case key)) val]
          next-val line)))))

(defn flatten-metadata
  "Given a list of maps which contain a single key/value, flatten them all into
  a single map with all the leading spaces removed. If an empty list is provided
  then return nil."
  [metadata]
  (when (pos? (count metadata))
    (loop [acc      {}
           remain   metadata
           prev-key nil]
      (if (seq remain)
        (let [data     (first remain)
              [key val] (if (sequential? data) data [prev-key data])
              prev-val (get acc key [])
              postfix  (if (= [\space \space] (take-last 2 val)) "\n" "")
              norm-val (str (string/trim val) postfix)
              new-val  (if-not (empty? norm-val)
                         (conj prev-val norm-val)
                         prev-val)]
          (recur (merge acc {key new-val}) (rest remain) key))
        acc))))


(defn parse-wiki-metadata-headers
  [lines-seq]
  (reduce
    (fn [acc line]
      (if-let [parsed (parse-metadata-line line)]
        (conj acc parsed)
        (reduced [(flatten-metadata acc) (count acc)])))
    [] lines-seq))

(defn parse-yaml-metadata-headers
  [lines-seq]
  #?(:clj
     (let [yaml-lines (->> lines-seq
                           ;; leave off opening ---
                           (drop 1)
                           ;; take lines until we see the closing ---
                           (take-while (comp not (partial re-matches #"---\s*"))))]
       [(->> yaml-lines
             ;; join together and parse
             (string/join "\n")
             yaml/parse-string)
        ;; number of lines consumed must consider opening and closing ---
        (+ (count yaml-lines) 2)])
     :cljs
     (throw (js/Error. "YAML is unsupported in ClojureScript mode"))))

(defn parse-edn-metadata-headers
  [lines-seq]
  ;; take sequences until you hit an empty line
  (let [meta-lines (take-while (comp not (partial re-matches #"\s*"))
                               lines-seq)]
    [(->> meta-lines
          ;; join together and parse
          (string/join "\n")
          edn/read-string)
     ;; count the trailing empty line
     (inc (count meta-lines))]))

(defn parse-metadata-headers
  "Given a sequence of lines from a markdown document, attempt to parse a
  metadata header if it exists. Accepts wiki, yaml, and edn formats.
   
  Returns the parsed headers number of lines the metadata spans"
  [lines-seq]
  {:pre [(sequential? lines-seq)
         (every? string? lines-seq)]}
  (cond
    ;; Treat as yaml
    (re-matches #"---\s*" (first lines-seq))
    (parse-yaml-metadata-headers lines-seq)
    ;; Treat as wiki
    (re-matches #"\w+: .*" (first lines-seq))
    (parse-wiki-metadata-headers lines-seq)
    ;; Treat as edn
    (re-matches #"\{.*" (first lines-seq))
    (parse-edn-metadata-headers lines-seq)))

(def transformer-vector
  [set-line-state
   empty-line
   inhibit
   escape-inhibit-separator
   code
   codeblock
   escaped-chars
   inline-code
   autoemail-transformer
   autourl-transformer
   image
   image-reference-link
   link
   implicit-reference-link
   reference-link
   footnote-link
   hr
   blockquote-1
   li
   heading
   blockquote-2
   italics
   bold-italic
   em
   strong
   bold
   strikethrough
   superscript
   table
   paragraph
   br
   thaw-strings
   dashes
   clear-line-state])