Button text carousel.

ui09.cljs

(ns app.renderer.ui09
  (:require
   [clojure.string :as string]
   [meander.epsilon :as m]
   [cljs.pprint :refer [pprint]]
   [goog.dom :as gdom]
   [goog.Timer :as gtimer]
   [missionary.core :as mi]
   [cljs.spec.alpha :as s])
  (:require-macros [clojure.core.strint :refer [<<]]))

(enable-console-print!)

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

(defn conform
  [spec x]
  (let [r (s/conform spec x)]
    (when (= r ::s/invalid) (s/explain spec x))
    r))

(s/def ::hiccup-leader
  (s/and keyword?
         (s/conformer #(if (namespace %)
                         ::s/invalid
                         (let [[match tag id class] (re-matches re-tag (name %))]
                           (if-not match
                             ::s/invalid
                             (into {}
                                   [(when (seq tag) [:tag tag])
                                    (when (seq id) [:id id])
                                    (when (seq class)
                                      [:class (string/replace class #"\." " ")])]))))
                      #(let [{:keys [tag id class]} %]
                         (keyword
                          (str tag
                               (when (seq id) (str "#" id))
                               (when (seq class) (str "." (string/replace class #" " ".")))))))))

(s/def ::hiccup-attributes
  (s/map-of (s/or :keyword keyword? :string string?)
            (s/or :fn fn? :string string? :number number? :boolean boolean?)
            :conform-keys true))

(s/def ::hiccup
  (s/or :text string?
        :number number?
        :flow fn?
        :hiccup (s/cat :leader ::hiccup-leader
                       :attributes (s/? ::hiccup-attributes)
                       :children (s/* ::hiccup))))
(defn set-property!
  [node k v]
  (if (and *in-reactor* (fn? v))
    (mi/stream!
     (mi/ap
      (gdom/setProperties node (clj->js {k (mi/?< v)}))))
    (do
      (println "setting " {k v})
      (gdom/setProperties node (clj->js {k v})))))

(defn help-attributes
  [node attributes]
  (doseq [[k v] (s/unform ::hiccup-attributes attributes)]
    (let [k (if (keyword? k) (name k) k)]
      (when (or (= "click" k) (= "onclick" k)) (println (<< "Stetting _attribute_ '~{k}'. Did you mean 'on-click'?")))
      (if (= "on-" (subs k 0 3))
        (when v (.addEventListener node (subs k 3) v))
        (set-property! node k v)))))

(defn as-element
  [form]
  (when-not (s/valid? ::hiccup form)
    (throw (ex-info (s/explain ::hiccup form) (s/explain-data ::hiccup form))))
  (let [conformed (s/conform ::hiccup form)]
    (m/match conformed
             [:text ?text]
             (gdom/createTextNode ?text)

             [:number ?number]
             (gdom/createTextNode (str ?number))

             (m/and (m/guard *in-reactor*) [:flow ?flow])
             #_(let [old (volatile! nil)]
                 (mi/stream! (mi/ap (let [elem (as-element (mi/?< ?flow))]
                                      (do (when @old
                                            (.replaceChild (.-parentNode @old) elem @old))
                                          (vreset! old elem)))))
                 @old)
             (let [old (volatile! nil)]
               (mi/stream! (mi/ap (let [elem (as-element (mi/?< ?flow))]
                                    (do (when @old
                                          (gdom/replaceNode elem @old))
                                        (vreset! old elem)))))
               @old)

             [:hiccup {:leader {:tag ?tag
                                :id ?id
                                :class ?class}
                       :attributes ?attributes
                       :children (m/seqable (m/cata !children) ...)}]
             (doto (gdom/createDom ?tag)
               (as-> node (do
                            (when ?id (set-property! node "id" ?id))
                            (when ?class (set-property! node "class" ?class))
                            (help-attributes node ?attributes)
                            (doseq [child !children]
                              (.appendChild node child)))))

             ?x (throw (ex-info "non exhaustive pattern match" {:value ?x})))))

(def ^:dynamic *in-reactor* false)

(defn observe
  [a]
  (with-meta
    (mi/observe (fn mount [send!]
                  (let [id (random-uuid)]
                    (add-watch a id
                               (fn [k r o n]
                                 (send! n)))
                    (send! @a)
                    (fn unmount []
                      (remove-watch a id)))))
    {:type :flow}))

(defn rot
  [s]
  (let [[c & cs] s]
    (apply str (concat cs [c]))))

(defn sg1
  []
  (let [count (atom 0)]
    (as-element [:div
                 [:input {:type "text"
                          :readOnly true
                          :value (observe count)}
                  (observe count)]
                 [:button {:on-click #(swap! count inc)} "Count"]])))

(defn sg2
  []
  (let [celsius (atom 0)
        c-to-f (fn [c] (+ 32 (* c (/ 9 5))))
        f-to-c (fn [f] (* (- f 32) (/ 5 9)))
        <celsius (observe celsius)
        <fahrenheit (mi/ap (c-to-f (mi/?< (observe celsius))))
        store-f (fn [f] (reset! celsius (f-to-c f)))
        store-c (fn [c] (reset! celsius c))]
    (as-element [:div#app-container
                 [:input {:type "number"
                          :on-input #(store-c (.. % -target -value))
                          :value <celsius}]
                 " Celsius = "
                 [:input {:type "number"
                          :on-input #(store-f (.. % -target -value))
                          :value <fahrenheit}]
                 " Fahrenheit"])))

(binding [*in-reactor* true]
  ((mi/reactor
    (gdom/replaceNode
     (sg2)
     (gdom/getElement "app-container")))
   prn prn))