-
Notifications
You must be signed in to change notification settings - Fork 28
/
compiler.cljs
188 lines (162 loc) · 6.17 KB
/
compiler.cljs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
(ns crate.compiler
(:require [goog.dom :as gdom]
[goog.style :as gstyle]
[clojure.string :as string]
[crate.binding :as bind]))
(def xmlns {:xhtml "http://www.w3.org/1999/xhtml"
:svg "http://www.w3.org/2000/svg"})
;; ********************************************
;; Element creation via Hiccup-like vectors
;; ********************************************
(declare elem-factory dom-attr dom-style)
(def group-id (atom 0))
;; ********************************************
;; Data binding
;; ********************************************
(def ^:dynamic bindings (atom []))
(defn capture-binding [tag b]
(swap! bindings conj [tag b]))
(defprotocol Element
(-elem [this]))
(defn as-content [parent content]
(doseq[c content]
(let [child (cond
(satisfies? Element c) (-elem c)
(nil? c) nil
(map? c) (throw "Maps cannot be used as content")
(string? c) (gdom/createTextNode c)
(vector? c) (elem-factory c)
;;TODO: there's a bug in clojurescript that prevents seqs from
;; being considered collections
(seq? c) (as-content parent c)
(bind/binding-coll? c) (do (capture-binding :coll c) (as-content parent [(bind/value c)]))
(bind/binding? c) (do (capture-binding :text c) (as-content parent [(bind/value c)]))
(.-nodeName c) c
(.-get c) (.get c 0)
:else (gdom/createTextNode (str c)))]
(when child
(gdom/appendChild parent child)))))
(defmulti dom-binding (fn [type _ _] type))
(defmethod dom-binding :text [_ b elem]
(bind/on-change b (fn [v]
(gdom/removeChildren elem)
(as-content elem [v]))))
(defmethod dom-binding :attr [_ [k b] elem]
(bind/on-change b (fn [v]
(dom-attr elem k v))))
(defmethod dom-binding :style [_ [k b] elem]
(bind/on-change b (fn [v]
(if k
(dom-style elem k v)
(dom-style elem v)))))
(defn dom-add [bc parent elem v]
(if-let [adder (bind/opt bc :add)]
(adder parent elem v)
(gdom/appendChild parent elem)))
(defn dom-remove [bc elem]
(if-let [remover (bind/opt bc :remove)]
(remover elem)
(gdom/removeNode elem)))
(defmethod dom-binding :coll [_ bc parent]
(bind/on-change bc (fn [type elem v]
(condp = type
:add (dom-add bc parent elem v)
:remove (dom-remove bc elem)))))
(defn handle-bindings [bs elem]
(doseq [[type b] bs]
(dom-binding type b elem)))
;; ********************************************
;; element handling
;; ********************************************
(defn dom-style
([elem v]
(cond
(string? v) (. elem (setAttribute "style" v))
(map? v) (doseq [[k v] v]
(dom-style elem k v))
(bind/binding? v) (do
(capture-binding :style [nil v])
(dom-style elem (bind/value v))))
elem)
([elem k v]
(let [v (if (bind/binding? v)
(do
(capture-binding :style [k v])
(bind/value v))
v)]
(gstyle/setStyle elem (name k) v))))
(defn dom-attr
([elem attrs]
(when elem
(if-not (map? attrs)
(. elem (getAttribute (name attrs)))
(do
(doseq [[k v] attrs]
(dom-attr elem k v))
elem))))
([elem k v]
(if (= k :style)
(dom-style elem v)
(let [v (if (bind/binding? v)
(do
(capture-binding :attr [k v])
(bind/value v))
v)]
(. elem (setAttribute (name k) v))))
elem))
;; From Weavejester's Hiccup: https://github.com/weavejester/hiccup/blob/master/src/hiccup/core.clj#L57
(def ^{:doc "Regular expression that parses a CSS-style id and class from a tag name." :private true}
re-tag #"([^\s\.#]+)(?:#([^\s\.#]+))?(?:\.([^\s#]+))?")
(defn- normalize-map-attrs [map-attrs]
(into {} (map (fn [[n v]] (if (true? v) [n (name n)] [n v]))
(filter (comp boolean second)
map-attrs))))
(defn- normalize-element
"Ensure a tag vector is of the form [tag-name attrs content]."
[[tag & content]]
(when (not (or (keyword? tag) (symbol? tag) (string? tag)))
(throw (str tag " is not a valid tag name.")))
(let [[_ tag id class] (re-matches re-tag (name tag))
[nsp tag] (let [[nsp t] (string/split tag #":")
ns-xmlns (xmlns (keyword nsp))]
(if t
[(or ns-xmlns nsp) t]
[(:xhtml xmlns) nsp]))
tag-attrs (into {}
(filter #(not (nil? (second %)))
{:id (or id nil)
:class (if class (string/replace class #"\." " "))}))
map-attrs (first content)]
(if (map? map-attrs)
[nsp tag (merge tag-attrs (normalize-map-attrs map-attrs)) (next content)]
[nsp tag tag-attrs content])))
(defn parse-content [elem content]
(let [attrs (first content)]
(if (map? attrs)
(do
(dom-attr elem attrs)
(rest content))
content)))
(def create-elem (if (.-createElementNS js/document)
(fn [nsp tag]
(.createElementNS js/document nsp tag))
(fn [_ tag]
(.createElement js/document tag))))
(defn elem-factory [tag-def]
(binding [bindings (atom [])]
(let [[nsp tag attrs content] (normalize-element tag-def)
elem (create-elem nsp tag)]
(dom-attr elem attrs)
(as-content elem content)
(handle-bindings @bindings elem)
elem)))
(defn add-optional-attrs
"Add an optional attribute argument to a function that returns a vector tag."
[func]
(fn [& args]
(if (map? (first args))
(let [[tag & body] (apply func (rest args))]
(if (map? (first body))
(apply vector tag (merge (first body) (first args)) (rest body))
(apply vector tag (first args) body)))
(apply func args))))