sort of readable html to hiccup conversion janet script

html-to-hiccup-janet.clj

; based on sogaiu's PEG https://gist.github.com/sogaiu/63efde6daabbdccb2297a9c2a65368ae

(def xmlish-peg
  ~{:main (sequence (opt (drop :xml-declaration))
                    (some (sequence :s* :element :s*)))
    #
    :xml-declaration (sequence
                      "<?xml"
                      (any :attribute)
                      "?>")
    # XXX: not accurate
    :attribute (sequence
                (capture (to (set " /<=>\""))) :s*
                "=" :s*
                "\"" (capture (to (set "\""))) "\"" :s*)
    # section 2.5 of xml spec
    :comment (sequence
              "<!--"
              (any (choice
                    (if-not (set "-") 1)
                    (sequence "-" (if-not (set "-") 1))))
              "-->" :s*)
    #
    :element (choice :empty-element :non-empty-element)
    #
    :empty-element (cmt (sequence
                         "<" :s* (capture :tag-name) :s*
                         (any :attribute)
                         :s* "/>")
                        ,|(let [args $&
                                elt-name (first args)
                                attrs (drop 1 args)
                                attrs (if (= (length attrs) 0)
                                        nil
                                        (table ;attrs))]
                            {:attrs (table ;(mapcat (fn [[k v]] [(keyword k) v]) (pairs attrs)))
                             :tag elt-name}))
    # XXX: not accurate
    :tag-name (to (set " -/<>"))
    #
    :non-empty-element (cmt (sequence
                             :open-tag
                             (any
                              (choice :comment :element (capture :pcdata)))
                             :close-tag)
                            ,|(let [args $&
                                    open-name (first (first args))
                                    attrs (drop 1 (first args))
                                    close-name (last args)]
                                (when (= open-name close-name)
                                  (let [elt-name open-name
                                        content (filter (fn [c-item]
                                                          (not= "" c-item))
                                                        (tuple/slice args 1 -2))
                                        content (if (= (length content) 0)
                                                  nil
                                                  content)
                                        attrs (if (= (length attrs) 0)
                                                nil
                                                (table ;attrs))]
                                    {:attrs (table ;(mapcat (fn [[k v]] [(keyword k) v]) (pairs attrs)))
                                     :content content
                                     :tag elt-name}))))
    #
    :open-tag (group
               (sequence
                "<" (capture :tag-name) :s*
                (any :attribute)
                ">"))
    # XXX: not accurate
    :pcdata (to (set "<>"))
    #
    :close-tag (sequence
                "</" (capture :tag-name) :s* ">")})

(printf "%j"
  (peg/match xmlish-peg `
   <?xml version="1.0" encoding="UTF-8" standalone="no" ?>
   <hi>hello</hi>
   `))
#
# (printf "%j"
#   (peg/match xmlish-peg `<hi /> <hello />`))

(printf "%j"
  (peg/match xmlish-peg `
    <hi a="1" b="2"/>
    `))

(printf "%j"
  (peg/match xmlish-peg `
    <hi a="smile" b="breath" >hello</hi>
    `))

# (printf "%j"
#   (peg/match xmlish-peg `
#     <ho></ho>
#     `))

# (printf "%j"
#   (peg/match xmlish-peg `
#     <bye><hi>there</hi></bye>
#     `))

# (printf "%j"
#   (peg/match xmlish-peg `
#     <bye><hi>the<smile id="1"></smile>re</hi></bye>
#     `))

# (printf "%j"
#   (peg/match xmlish-peg `
#     <hi>hello<bye></bye></hi>
#     `))

# (printf "%j"
#   (peg/match xmlish-peg `
#     <a><a></a></a>
#     `))
#
(printf "%j"
  (peg/match xmlish-peg `
    <a b="0"><a c="8"></a></a>
    `))

(printf "%j"
  (peg/match xmlish-peg `
    <?xml version="1.0" encoding="UTF-8" standalone="no" ?>
    <a><!-- b --><c><!-- d --><e/></c></a>
    `))

(printf "%j"
  (peg/match xmlish-peg `
    <?xml version="1.0" encoding="UTF-8" standalone="no" ?>
    <oops>💩</oops>
    `))

(printf "%j"
  (peg/match xmlish-peg `
    <?xml version="1.0" encoding="UTF-8" standalone="no" ?>
    <rss version="2.0">
    <channel>
    <title>RSS Title</title>
    <description>This is an example of an RSS feed</description>
    <link>http://www.example.com/main.html</link>
    <lastBuildDate>Mon, 06 Sep 2010 00:01:00 +0000 </lastBuildDate>
    <pubDate>Sun, 06 Sep 2009 16:20:00 +0000</pubDate>
    <ttl>1800</ttl>
    <item>
    <title>Example entry</title>
    <description>Here is some text containing an interesting description.</description>
    <link>http://www.example.com/blog/post/1</link>
    <guid isPermaLink="false">7bd204c6-1655-4c27-aeee-53f933c5395f</guid>
    <pubDate>Sun, 06 Sep 2009 16:20:00 +0000</pubDate>
    </item>
    </channel>
    </rss>
    `))


(defn element-to-hiccup [to-hiccup val]
  (let [el (array/concat @[(keyword (get val :tag))] (get val :attrs))]
    (if (get val :content)
      (array/concat el
        (filter |(not (empty? $)) (map |(to-hiccup $) (get val :content))))
      el)))

(defn to-hiccup [val]
  (cond (dictionary? val) (element-to-hiccup to-hiccup val)
        (indexed? val) (map |(element-to-hiccup to-hiccup $) val)
        (string? val) @[]))


(defn remove-empty-arrays [val]
  (if (array? val)
    (filter |(not (empty? $)) val)
    val))


(defn hiccup [val]
  (walk remove-empty-arrays (first (to-hiccup val))))


(def result (peg/match xmlish-peg `
                <svg width="1em" height="1em" viewBox="0 0 16 16" class="bi bi-alarm" fill="currentColor" xmlns="http://www.w3.org/2000/svg">
                  <path fill-rule="evenodd" d="M8 15A6 6 0 1 0 8 3a6 6 0 0 0 0 12zm0 1A7 7 0 1 0 8 2a7 7 0 0 0 0 14z"/>
                  <path fill-rule="evenodd" d="M8 4.5a.5.5 0 0 1 .5.5v4a.5.5 0 0 1-.053.224l-1.5 3a.5.5 0 1 1-.894-.448L7.5 8.882V5a.5.5 0 0 1 .5-.5z"/>
                  <path d="M.86 5.387A2.5 2.5 0 1 1 4.387 1.86 8.035 8.035 0 0 0 .86 5.387zM11.613 1.86a2.5 2.5 0 1 1 3.527 3.527 8.035 8.035 0 0 0-3.527-3.527z"/>
                  <path fill-rule="evenodd" d="M11.646 14.146a.5.5 0 0 1 .708 0l1 1a.5.5 0 0 1-.708.708l-1-1a.5.5 0 0 1 0-.708zm-7.292 0a.5.5 0 0 0-.708 0l-1 1a.5.5 0 0 0 .708.708l1-1a.5.5 0 0 0 0-.708zM5.5.5A.5.5 0 0 1 6 0h4a.5.5 0 0 1 0 1H6a.5.5 0 0 1-.5-.5z"/>
                  <path d="M7 1h2v2H7V1z"/>
                </svg>
              `))


(print (string/replace-all "@[" "\n ["
         (string/replace "@[" "["
           (string/format "%j" (hiccup result)))))