macros.fnl


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

(local entity-replacements {"&" "&amp;" ; must be first!
                            "<" "&lt;"
                            ">" "&gt;"
                            "\"" "&quot;"})

(local entity-search
       (.. "[" (table.concat (icollect [k (pairs entity-replacements)] k)) "]"))

(fn escape-html [s]
  (assert (= (type s) :string))
  (s:gsub entity-search entity-replacements))

(fn compile-attributes [attributes]
  (var result [])
  (if
   (table? attributes)
    (each [name value (pairs attributes)]
      (when value
        (do
          (table.insert result " ")
          (table.insert result name)
          (when (~= value true)
            (do
              (table.insert result  "=\"")
              (table.insert result value)
              (table.insert result "\""))))))
   (list? attributes)
    (table.insert
      result
      `(accumulate [res# "" k# v# (pairs (,attributes))]
         (.. " "
          (if
           (not v#) ""
           (= v# true) (.. k#)
           (.. k# "=\"" v# "\""))
          res#))))
  result)

(fn concat [...]
  (local res [])
  (var cur 1)
  (each [_ t (pairs [...])]
   (each [_ v (pairs t)]
    (tset res cur v)
    (set cur (+ 1 cur))))
  res)

(fn compress-compiled-html [html]
  (var result [])
  (var accumulator "")
  (each [_ value (pairs html)]
    (if (= (type value) "string")
      (set accumulator (.. accumulator value))
      (do
        (when (~= "" accumulator)
          (do
            (table.insert result accumulator)
            (set accumulator "")))
        (table.insert result value))))
 (when (~= "" accumulator)
    (table.insert result accumulator))
  result)

(fn compile-html [html]
  (fn inner-compile [html]
    (var result [])
    (fn add [item] (table.insert result item))
    (let [[tag attributes & body] html]
      (add "<") (add tag)
      (set result (concat result (compile-attributes attributes)))
      (add ">")
      (each [_ item (pairs body)]
        (if
          (and (sequence? item)
               (= (. item 1) "NO-ESCAPE"))
           (each [i pair (ipairs item)]
             (when (~= i 1) (add (. item i))))
          (sequence? item)
            (set result (concat result (inner-compile item)))
          (list? item)
            ;; FIXME: add escaping to results
            (add
              (if (or (= (. item 1) `table.unpack)
                      (= (. item 1) `unpack))
                `(.. ,item)
                item))
          (= (type item) "string")
            (add (escape-html item))
          (add item)))
      (when (< 0 (# body))
        (add "</") (add tag) (add ">"))
      (add "\n"))
    result)

  `(.. ,(table.unpack (compress-compiled-html (inner-compile html)))))

{: compile-html}