This repository has been archived by the owner on Feb 2, 2019. It is now read-only.
-
Notifications
You must be signed in to change notification settings - Fork 0
/
html.cljs
244 lines (200 loc) · 8.22 KB
/
html.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
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
(ns tiltontec.webmx.html
(:require
[clojure.string :as str]
[clojure.walk :refer [stringify-keys]]
[cljs.pprint :as pp]
[tiltontec.util.base :refer [type-cljc]]
[tiltontec.util.core :refer [pln]]
[tiltontec.cell.base :refer [md-ref? ia-type unbound]]
[tiltontec.cell.observer :refer [observe observe-by-type]]
[tiltontec.cell.evaluate :refer [not-to-be not-to-be-self]]
[tiltontec.model.core
:refer-macros [the-kids mdv!]
:refer [fget <mget fasc fm! make mset!> backdoor-reset!]
:as md]
[tiltontec.webmx.style
:refer [style-string] :as tagcss]
[goog.dom :as dom]
[goog.html.SafeHtml :as safe]
[goog.dom.classlist :as classlist]
[goog.html.sanitizer.HtmlSanitizer :as sanitizer]
[goog.editor.focus :as focus]
[goog.ui.Control :as control]
[goog.dom.selection :as selection]
[goog.dom.forms :as form]
[taoensso.tufte :as tufte :refer-macros (defnp p profiled profile)]))
(def ^:dynamic *webmx-trace* false)
(defn tagfo [me]
(if (string? me)
"string"
(select-keys @me [:id :tag :class :name])))
(defn dom-has-class [dom class]
(classlist/contains dom class))
(defn dom-ancestor-by-class [dom class]
(dom/getAncestorByTagNameAndClass dom nil class))
(defn dom-ancestor-by-tag [dom tag]
(dom/getAncestorByTagNameAndClass dom tag))
(declare tag-dom-create)
(defn map-less-nils [m]
(apply dissoc m
(for [[k v] m :when (nil? v)] k)))
(defn tag-dom [me]
;; This will return nil when 'me' is being awakened and rules
;; are firing for the first time, because 'me' has not yet
;; been installed in the actual DOM, so call this only
;; from event handlers and the like.
(let [id (<mget me :id)]
(assert id)
(or (<mget me :dom-cache)
(if-let [dom (dom/getElement (str id))]
(backdoor-reset! me :dom-cache dom)
(println :no-element id :found)))))
(defn tag-attrs [mx]
(let [beef (remove nil? (for [k (:attr-keys @mx)]
(when-let [v (<mget mx k)]
[(name k) (case k
:style (tagcss/style-string v)
:class (if (coll? v)
(str/join " " v)
v)
v)])))]
(apply js-obj
(apply concat beef))))
(defn tag-dom-create
([me] (tag-dom-create me false))
([me dbg]
(cond
(string? me) (dom/safeHtmlToNode (sanitizer/sanitize me))
(coll? me) (let [frag (.createDocumentFragment js/document)]
(doseq [tag me]
(when tag ;; tolerate nils
(dom/appendChild frag (tag-dom-create tag))))
frag)
:default
(do (when-let [dbg (or dbg *webmx-trace*)]
(pln :tag-dom-create dbg (tagfo me)))
;;(pln :domcre-attrs (:attr-keys @me) (webmx-attrs me))
(let [dom (apply dom/createDom (<mget me :tag)
(tag-attrs me)
(concat ;; to-do: need this?
(map #(tag-dom-create % dbg) (<mget me :kids))
(when-let [c (<mget me :content)]
[(tag-dom-create c)])))]
dom)))))
(def +true-html+ {::type "type"})
(defn true-html [keyword]
(or (keyword +true-html+)
(name keyword)))
(defn tag [me]
(<mget me :tag))
(defn tag? [me]
(= (type-cljc me) :tiltontec.webmx.base/tag))
(defmethod observe [:kids :tiltontec.webmx.base/tag] [_ me newv oldv _]
(when (not= oldv unbound)
;; oldv unbound means initial build and this incremental add/remove
;; is needed only when kids change post initial creation
;;(println :obstagkids!!!!! (tagfo me))
(do ;; p ::observe-kids
(let [pdom (tag-dom me)
lost (clojure.set/difference (set oldv) (set newv))
gained (clojure.set/difference (set newv) (set oldv))]
(cond
(empty? gained)
;; just lose the lost
(doseq [oldk lost]
(.removeChild pdom (tag-dom oldk))
(when-not (string? oldk)
(println :obs-tag-kids-dropping (tagfo oldk))
(not-to-be oldk)))
:default (let [frag (.createDocumentFragment js/document)]
;; GC lost from matrix;
;; move retained kids from pdom into fragment,
;; add all new kids to fragment, and do so preserving
;; order dictated by newk:
(doseq [oldk lost]
(when-not (string? oldk)
;; no need to remove dom, all children replaced below.
(not-to-be oldk)))
(doseq [newk newv]
(dom/appendChild frag
(if (some #{newk} oldv)
(.removeChild pdom (tag-dom newk))
(do ;;(println :obs-tag-kids-building-new-dom (tagfo newk))
(tag-dom-create newk)))))
(dom/removeChildren pdom)
(dom/appendChild pdom frag)))))))
(def +inline-css+ (set [:display]))
(defmethod observe-by-type [:tiltontec.webmx.base/tag] [slot me newv oldv _]
(when (not= oldv unbound)
(when-let [dom (tag-dom me)]
(when *webmx-trace*
(when-not (some #{slot} [:tick])
(pln :observing-tagtype (tagfo me) slot newv oldv)))
(cond
(= slot :content)
(do ;;(pln :setting-html-content newv)
(.requestAnimationFrame js/window #(set! (.-innerHTML dom) newv)))
(some #{slot} (:attr-keys @me))
(do
;;(pln :dom-hit-attr!!!! (tagfo me) slot newv oldv)
(case slot
:style (set! (.-style dom) (style-string newv))
:hidden (set! (.-hidden dom) newv)
:disabled (if newv
(.setAttribute dom "disabled" true)
(.removeAttribute dom "disabled"))
:class (classlist/set dom (if (sequential? newv)
(str/join " " newv)
newv))
:checked (set! (.-checked dom) newv)
(do
;(pln :obs-by-type-genset slot newv)
(.setAttribute dom (name slot) newv))))
(+inline-css+ slot)
(throw (js/Error. (str "webmx obs sees oldskool style: " slot)))))))
;;; --- local storage ------------------------
(defn mxu-find-class
"Search up the matrix from node 'where' looking for element with class"
[where class]
(fget #(= (name class) (<mget % :class))
where :me? false :up? true))
(defn mxu-find-tag
"Search up the matrix from node 'where' looking for element with class"
[where tag]
(fget #(= (name tag) (<mget % :tag))
where :me? false :up? true))
(defn mxu-find-id
"Search up the matrix from node 'where' looking for element with class"
[where id]
(fget #(= (name id) (<mget % :id))
where :me? false :up? true))
;;; --- localStorage io implementation --------------------------------
(defn io-upsert [key val]
(.setItem (.-localStorage js/window) key val))
(defn io-read [key]
(.getItem (.-localStorage js/window) key))
(defn io-delete [key]
(.removeItem (.-localStorage js/window) key))
(defn io-clear-storage []
(.clear (.-localStorage js/window)))
(defn io-all-keys []
(.keys js/Object (.-localStorage js/window)))
(defn io-find [key-prefix]
(loop [keys (io-all-keys)
found []]
(if (seq keys)
(recur (rest keys)
(if (str/starts-with? (first keys) key-prefix)
(conj found (first keys))
found))
found)))
(defn io-truncate [key-prefix]
(doseq [key (io-find key-prefix)]
(io-delete key)))
;;; ---- webmx-specific utilities ----------------------------------------------
(defn input-editing-start [dom initial-value]
(form/setValue dom initial-value)
(focus/focusInputField dom)
;; a lost bit of sound U/X: select all text when starting edit of a populated field...
(selection/setStart dom 0)
(selection/setEnd dom (count initial-value)))