Specing valid hiccup dom

hiccup-dom-spec.clj

(ns hiccup-html-spec.core
  (:require [clojure.spec.alpha :as s]
            [phrase.alpha :refer [defphraser phrase-first phrase]]))

;;GOALS
;;- spec a valid dom hiccup
;;- have errors like React for
;;    . invalid descendant -> "<div> cannot appear as a descendant of <p>"
;;    . unknown tag -> "The tag <divv> is unrecognized in this browser"
;;    . void element -> "img is a void element tag and must neither have `children` nor use `dangerouslySetInnerHTML`"

(def re-tag #"([^\s\.#]+)(?:#([^\s\.#]+))?(?:\.([^\s#]+))?")

(defn parse-tag [tag]
  (re-matches re-tag (name tag)))

(defn valid-tag? [tag]
  (not (nil? (parse-tag tag))))

(def block-tags #{:p :div :table})
(def inline-tags #{:span :a :img})

(defn tag->type [tag]
  (-> tag parse-tag second keyword))

(defn known-tag? [tag]
  (contains? (clojure.set/union block-tags inline-tags) (tag->type tag)))

(comment (valid-tag? :div.test#class))

(s/def ::tag (s/and keyword? valid-tag? known-tag?))

(s/def ::attributes (s/map-of keyword? string?))

(s/def ::content (s/or :terminal string?
                       :content ::hiccup))

(s/def ::block-content (s/or :content ::block-hiccup
                             :terminal string?))

(s/def ::inline-content (s/or :content ::inline-hiccup
                              :terminal string?))

(defn one-of [tags]
  (comp tags tag->type))

(s/def ::inline-tag (s/and ::tag (one-of inline-tags)))

(s/def ::block-tag (s/and ::tag (one-of block-tags)))

(defn hiccup->type [hic]
  (-> hic first tag->type))

(s/def ::block-hiccup (s/cat :tag ::block-tag :attributes (s/? ::attributes) :content (s/* ::content)))

(s/def ::inline-hiccup (s/cat :tag ::inline-tag :attributes (s/? ::attributes) :content (s/* ::inline-content)))

(s/def ::void-hiccup (s/cat :tag ::tag :attributes (s/? ::attributes)))

(defmulti hiccup hiccup->type)

(defmethod hiccup :img [_]
  ::void-hiccup)

(defmethod hiccup :p [_]
  (s/cat :tag ::tag :attributes (s/? ::attributes) :content (s/* ::inline-content)))

(defmethod hiccup :div [_]
  (s/cat :tag ::tag :attributes (s/? ::attributes) :content (s/* ::content)))

(defmethod hiccup :default [_]
  (s/cat :tag ::tag :attributes (s/? ::attributes) :content (s/* ::content)))


(s/def ::hiccup (s/multi-spec hiccup hiccup->type))

;;valid
(s/valid? ::hiccup [:img {}])

(s/valid? ::hiccup [:img#img.logo {:href "#yoyo"}])

(s/valid? ::hiccup [:div.wrapper [:img] [:span] [:div]])

(s/valid? ::hiccup [:div [:p "yes" [:span "test"]]])

(s/valid? ::hiccup [:div [:img {}]])

;;phrases

(defphraser
  valid-tag?
  [_ explain]
  (str (:val explain) " is not a valid tag. Valid tags are :div#id.class1.class2"))

(defphraser
  known-tag?
  [_ explain]
  (str (:val explain) " is not recognized by your browser. Is this a typo ?"))

(defphraser
  (one-of inline-tags)
  [_ explain]
  (str (:val explain) " cannot be a descendant of " (first (:path explain))))

(defphraser
  (s/cat :tag ::tag :attributes (s/? attrs))
  [_ explain attrs]
  (str (:path explain) " is a void element and must not have children"))


(phrase-first {} ::hiccup [:p "Hello" [:div]])
;; ":p cannot have block element as children"

(phrase-first {} ::hiccup [:p#invalid#tag])
;; ":p#invalid#tag is not a valid tag. Valid tags are :div#id.class1.class2"

(phrase-first {} ::hiccup [:divv "hey"])
;; ":divv is not recognized by your browser. Is this a typo ?"

(phrase-first {} ::hiccup [:img {} "hello"])
;; "[:img] is a void element and can't have children"

;; Everything is fine if the error is not deep
;; in the next example, the first (s/cat ...) predicate won't pass and consider [:divv] as an "Extra Input" since it doesn't conform neither ::attributes or ::content

;; I have no idea how to make it so it's able to show the "known-tag?" phrase error
(s/explain-data ::hiccup [:div [:div [:divv "Type"]]])
;; {:problems [{:pred (clojure.spec.alpha/cat ...) :path [:div] :via ::hiccup ...}
(phrase-first {} ::hiccup [:div [:div [:divv "Type"]]]) ;;nil