PageRenderTime 25ms CodeModel.GetById 14ms app.highlight 4ms RepoModel.GetById 2ms app.codeStats 0ms

/html.arc

http://github.com/alimoeeny/arc
Unknown | 443 lines | 361 code | 82 blank | 0 comment | 0 complexity | eb97075d185b8095f4aace69c7f82f48 MD5 | raw file
  1; HTML Utils. 
  2
  3
  4(def color (r g b)
  5  (with (c (table) 
  6         f (fn (x) (if (< x 0) 0 (> x 255) 255 x)))
  7    (= (c 'r) (f r) (c 'g) (f g) (c 'b) (f b))
  8    c))
  9
 10(def dehex (str) (errsafe (coerce str 'int 16)))
 11
 12(defmemo hex>color (str)
 13  (and (is (len str) 6)
 14       (with (r (dehex (cut str 0 2))
 15              g (dehex (cut str 2 4))
 16              b (dehex (cut str 4 6)))
 17         (and r g b
 18              (color r g b)))))
 19
 20(defmemo gray (n) (color n n n))
 21
 22(= white    (gray 255) 
 23   black    (gray 0)
 24   linkblue (color 0 0 190)
 25   orange   (color 255 102 0)
 26   darkred  (color 180 0 0)
 27   darkblue (color 0 0 120)
 28   )
 29
 30(= opmeths* (table))
 31
 32(mac opmeth args
 33  `(opmeths* (list ,@args)))
 34
 35(mac attribute (tag opt f)
 36  `(= (opmeths* (list ',tag ',opt)) ,f))
 37
 38(= hexreps (table))
 39
 40(for i 0 255 (= (hexreps i)
 41                (let s (coerce i 'string 16)
 42                  (if (is (len s) 1) (+ "0" s) s))))
 43
 44(defmemo hexrep (col)
 45  (+ (hexreps (col 'r)) (hexreps (col 'g)) (hexreps (col 'b))))
 46
 47(def opcolor (key val) 
 48  (w/uniq gv
 49    `(whenlet ,gv ,val
 50       (pr ,(string " " key "=#") (hexrep ,gv)))))
 51
 52(def opstring (key val)
 53  `(aif ,val (pr ,(+ " " key "=\"") it #\")))
 54
 55(def opnum (key val)
 56  `(aif ,val (pr ,(+ " " key "=") it)))
 57
 58(def opsym (key val)
 59  `(pr ,(+ " " key "=") ,val))
 60
 61(def opsel (key val)
 62  `(if ,val (pr " selected")))
 63
 64(def opcheck (key val)
 65  `(if ,val (pr " checked")))
 66
 67(def opesc (key val)
 68  `(awhen ,val
 69     (pr ,(string " " key "=\""))
 70     (if (isa it 'string) (pr-escaped it) (pr it))
 71     (pr  #\")))
 72
 73; need to escape more?  =?
 74
 75(def pr-escaped (x)
 76  (each c x 
 77    (pr (case c #\<  "&#60;"  
 78                #\>  "&#62;"  
 79                #\"  "&#34;"  
 80                #\&  "&#38;"
 81                c))))
 82
 83(attribute a          href           opstring)
 84(attribute a          rel            opstring)
 85(attribute a          class          opstring)
 86(attribute a          id             opsym)
 87(attribute a          onclick        opstring)
 88(attribute a          onmouseout     opstring)
 89(attribute a          onmouseover    opstring)
 90(attribute body       alink          opcolor)
 91(attribute body       bgcolor        opcolor)
 92(attribute body       leftmargin     opnum)
 93(attribute body       link           opcolor)
 94(attribute body       marginheight   opnum)
 95(attribute body       marginwidth    opnum)
 96(attribute body       topmargin      opnum)
 97(attribute body       vlink          opcolor)
 98(attribute div        id             opstring)
 99(attribute div        name           opstring)
100(attribute div        class          opstring)
101(attribute div        onclick        opstring)
102(attribute div        onmouseout     opstring)
103(attribute div        onmouseover    opstring)
104(attribute font       color          opcolor)
105(attribute font       face           opstring)
106(attribute font       size           opnum)
107(attribute form       action         opstring)
108(attribute form       method         opsym)
109(attribute form       id             opstring)
110(attribute form       name           opstring)
111(attribute form       onsubmit       opstring)
112(attribute form       enctype        opstring)
113(attribute img        align          opsym)
114(attribute img        border         opnum)
115(attribute img        height         opnum)
116(attribute img        width          opnum)
117(attribute img        vspace         opnum)
118(attribute img        hspace         opnum)
119(attribute img        src            opstring)
120(attribute img        id             opsym)
121(attribute img        alt            opstring)
122(attribute input      name           opstring)
123(attribute input      id             opstring)
124(attribute input      size           opnum)
125(attribute input      type           opsym)
126(attribute input      value          opesc)
127(attribute input      checked        opcheck)
128(attribute input      onclick        opstring)
129(attribute input      onblur         opstring)
130(attribute input      class          opstring)
131(attribute select     name           opstring)
132(attribute option     selected       opsel)
133(attribute table      bgcolor        opcolor)
134(attribute table      border         opnum)
135(attribute table      cellpadding    opnum)
136(attribute table      cellspacing    opnum)
137(attribute table      width          opstring)
138(attribute table      id             opstring)
139(attribute textarea   cols           opnum)
140(attribute textarea   id             opstring)
141(attribute textarea   name           opstring)
142(attribute textarea   rows           opnum)
143(attribute textarea   wrap           opsym)
144(attribute td         align          opsym)
145(attribute td         bgcolor        opcolor)
146(attribute td         colspan        opnum)
147(attribute td         rowspan        opnum)
148(attribute td         width          opnum)
149(attribute td         height         opnum)
150(attribute td         valign         opsym)
151(attribute td         class          opstring)
152(attribute tr         bgcolor        opcolor)
153(attribute tr         valign         opsym)
154(attribute tr         height         opnum)
155(attribute tr         class          opstring)
156(attribute tr         onclick        opstring)
157(attribute tr         id             opstring)
158(attribute hr         color          opcolor)
159(attribute script     type           opstring)
160(attribute span       class          opstring)
161(attribute span       align          opstring)
162(attribute span       id             opsym)
163(attribute rss        version        opstring)
164
165
166(mac gentag args (start-tag args))
167     
168(mac tag (spec . body)
169  `(do ,(start-tag spec)
170       ,@body
171       ,(end-tag spec)))
172     
173(mac tag-if (test spec . body)
174  `(if ,test
175       (tag ,spec ,@body)
176       (do ,@body)))
177
178(def start-tag (spec)
179  (if (atom spec)
180      `(pr ,(string "<" spec ">"))
181      (let opts (tag-options (car spec) (pair (cdr spec)))
182        (if (all [isa _ 'string] opts)
183            `(pr ,(string "<" (car spec) (apply string opts) ">"))
184            `(do (pr ,(string "<" (car spec)))
185                 ,@(map (fn (opt)
186                          (if (isa opt 'string)
187                              `(pr ,opt)
188                              opt))
189                        opts)
190                 (pr ">"))))))
191
192(def end-tag (spec)
193  `(pr ,(string "</" (carif spec) ">")))
194
195(def literal (x) 
196  (case (type x)
197    sym   (in x nil t)
198    cons  (caris x 'quote)
199          t))
200
201; Returns a list whose elements are either strings, which can 
202; simply be printed out, or expressions, which when evaluated
203; generate output.
204
205(def tag-options (spec options)
206  (if (no options)
207      '()
208      (let ((opt val) . rest) options
209        (let meth (if (is opt 'style) opstring (opmeth spec opt))
210          (if meth
211              (if val
212                  (cons (if (precomputable-tagopt val)
213                            (tostring (eval (meth opt val)))
214                            (meth opt val))
215                        (tag-options spec rest))
216                  (tag-options spec rest))
217              (do
218                (pr "<!-- ignoring " opt " for " spec "-->")
219                (tag-options spec rest)))))))
220
221(def precomputable-tagopt (val)
222  (and (literal val) 
223       (no (and (is (type val) 'string) (find #\@ val)))))
224
225(def br ((o n 1)) 
226  (repeat n (pr "<br>")) 
227  (prn))
228
229(def br2 () (prn "<br><br>"))
230
231(mac center    body         `(tag center ,@body))
232(mac underline body         `(tag u ,@body))
233(mac tab       body         `(tag (table border 0) ,@body))
234(mac tr        body         `(tag tr ,@body))
235
236(let pratoms (fn (body)
237               (if (or (no body) 
238                       (all [and (acons _) (isnt (car _) 'quote)]
239                            body))
240                   body
241                   `((pr ,@body))))
242
243  (mac td       body         `(tag td ,@(pratoms body)))
244  (mac trtd     body         `(tr (td ,@(pratoms body))))
245  (mac tdr      body         `(tag (td align 'right) ,@(pratoms body)))
246  (mac tdcolor  (col . body) `(tag (td bgcolor ,col) ,@(pratoms body)))
247)
248
249(mac row args
250  `(tr ,@(map [list 'td _] args)))
251
252(mac prrow args
253  (w/uniq g
254    `(tr ,@(map (fn (a) 
255                  `(let ,g ,a
256                     (if (number ,g)
257                         (tdr (pr ,g))
258                         (td (pr ,g)))))
259                 args))))
260
261(mac prbold body `(tag b (pr ,@body)))
262
263(def para args 
264  (gentag p)
265  (when args (apply pr args)))
266
267(def menu (name items (o sel nil))
268  (tag (select name name)
269    (each i items
270      (tag (option selected (is i sel))
271        (pr i)))))
272
273(mac whitepage body
274  `(tag html 
275     (tag (body bgcolor white alink linkblue) ,@body)))
276
277(def errpage args (whitepage (apply prn args)))
278
279(def blank-url () "s.gif")
280
281; Could memoize these.
282
283; If h = 0, doesn't affect table column widths in some Netscapes.
284
285(def hspace (n)    (gentag img src (blank-url) height 1 width n))
286(def vspace (n)    (gentag img src (blank-url) height n width 0))
287(def vhspace (h w) (gentag img src (blank-url) height h width w))
288
289(mac new-hspace (n)    
290  (if (number n)
291      `(pr ,(string "<span style=\"padding-left:" n "px\" />"))
292      `(pr "<span style=\"padding-left:" ,n "px\" />")))
293
294;(def spacerow (h) (tr (td (vspace h))))
295
296(def spacerow (h) (pr "<tr style=\"height:" h "px\"></tr>"))
297
298; For use as nested table.
299
300(mac zerotable body
301  `(tag (table border 0 cellpadding 0 cellspacing 0)
302     ,@body))
303
304; was `(tag (table border 0 cellpadding 0 cellspacing 7) ,@body)
305
306(mac sptab body
307  `(tag (table style "border-spacing: 7px 0px;") ,@body))
308
309(mac widtable (w . body)
310  `(tag (table width ,w) (tr (td ,@body))))
311
312(def cellpr (x) (pr (or x "&nbsp;")))
313
314(def but ((o text "submit") (o name nil))
315  (gentag input type 'submit name name value text))
316
317(def submit ((o val "submit"))
318  (gentag input type 'submit value val))
319
320(def buts (name . texts)
321  (if (no texts)
322      (but)
323      (do (but (car texts) name)
324          (each text (cdr texts)
325            (pr " ")
326            (but text name)))))
327
328(mac spanrow (n . body)
329  `(tr (tag (td colspan ,n) ,@body)))
330
331(mac form (action . body)
332  `(tag (form method "post" action ,action) ,@body))
333
334(mac textarea (name rows cols . body)
335  `(tag (textarea name ,name rows ,rows cols ,cols) ,@body))
336
337(def input (name (o val "") (o size 10))
338  (gentag input type 'text name name value val size size))
339
340(mac inputs args
341  `(tag (table border 0)
342     ,@(map (fn ((name label len text))
343              (w/uniq (gl gt)
344                `(let ,gl ,len
345                   (tr (td (pr ',label ":"))
346                       (if (isa ,gl 'cons)
347                           (td (textarea ',name (car ,gl) (cadr ,gl)
348                                 (let ,gt ,text (if ,gt (pr ,gt)))))
349                           (td (gentag input type ',(if (is label 'password) 
350                                                    'password 
351                                                    'text)
352                                         name ',name 
353                                         size ,len 
354                                         value ,text)))))))
355            (tuples args 4))))
356
357(def single-input (label name chars btext (o pwd))
358  (pr label)
359  (gentag input type (if pwd 'password 'text) name name size chars)
360  (sp)
361  (submit btext))
362
363(mac cdata body
364  `(do (pr "<![CDATA[") 
365       ,@body
366       (pr "]]>")))
367
368(def eschtml (str)
369  (tostring 
370    (each c str
371      (pr (case c #\<  "&#60;" 
372                  #\>  "&#62;"
373                  #\"  "&#34;"
374                  #\'  "&#39;"
375                  #\&  "&#38;"
376                        c)))))
377
378(def esc-tags (str)
379  (tostring 
380    (each c str
381      (pr (case c #\<  "&#60;" 
382                  #\>  "&#62;"
383                  #\&  "&#38;"
384                        c)))))
385
386(def nbsp () (pr "&nbsp;"))
387
388(def link (text (o dest text) (o color))
389  (tag (a href dest) 
390    (tag-if color (font color color)
391      (pr text))))
392
393(def underlink (text (o dest text))
394  (tag (a href dest) (tag u (pr text))))
395
396(def striptags (s)
397  (let intag nil
398    (tostring
399      (each c s
400        (if (is c #\<) (set intag)
401            (is c #\>) (wipe intag)
402            (no intag) (pr c))))))
403
404(def clean-url (u)
405  (rem [in _ #\" #\' #\< #\>] u))
406
407(def shortlink (url)
408  (unless (or (no url) (< (len url) 7))
409    (link (cut url 7) url)))
410
411; this should be one regexp
412
413(def parafy (str)
414  (let ink nil
415    (tostring
416      (each c str
417        (pr c)
418        (unless (whitec c) (set ink))
419        (when (is c #\newline)
420          (unless ink (pr "<p>"))
421          (wipe ink))))))
422
423(mac spanclass (name . body)
424  `(tag (span class ',name) ,@body))
425
426(def pagemessage (text)
427  (when text (prn text) (br2)))
428
429; Could be stricter.  Memoized because looking for chars in Unicode
430; strings is terribly inefficient in Mzscheme.
431
432(defmemo valid-url (url)
433  (and (len> url 10)
434       (or (begins url "http://")
435           (begins url "https://"))
436       (~find [in _ #\< #\> #\" #\'] url)))
437
438(mac fontcolor (c . body)
439  (w/uniq g
440    `(let ,g ,c
441       (if ,g
442           (tag (font color ,g) ,@body)
443           (do ,@body)))))