/lib/sml.arc

 1;;
 2;; Routines for manipulating sml
 3;;
 4;; sml is an S-Expression Meta Language for XML that looks like:
 5;;
 6;; (tagname attr "value" attr2 "value2"
 7;;   (tagname2)
 8;;   (tagname3 "data"))
 9;;
10
11;; Convert S-Expression Meta Language to XML
12(def sml-pr-xml (tag (o indent 0))
13  (with (name (sml-tag-name tag)
14	 elements (sml-elements tag))
15    (repeat indent (pr " "))
16    (pr "<" name)
17    (sml-pr-attrs (sml-attrs tag))
18    (if (is (len elements) 0)
19	(prn "/>")
20        (do
21	  (prn ">")
22	  (map [sml-pr-element _ (+ 2 indent)] elements)
23	  (repeat indent (pr " "))
24	  (prn "</" name ">")))
25    nil))
26
27(def sml-tag-name (tag)
28  (car tag))
29
30(def sml-attrs (tag)
31  (let rest (cdr tag)
32    (if (no rest) nil
33        (caris (car rest) '@) (cdr:car rest) ;; old format
34        (no (isa (car rest) 'sym)) nil
35        (cons (car rest) (cons (cadr rest) (sml-attrs (cdr rest)))))))
36
37(def sml-elements (tag)
38  (let rest (cdr tag)
39    (if (no rest) nil
40        (caris (car rest) '@) (cdr rest) ;; old format
41        (no (isa (car rest) 'sym)) rest
42        (sml-elements (cdr rest)))))
43
44(def sml-pr-attrs (attrs)
45  (when attrs
46    (pr " " (car attrs) "=\"")
47    (each c (string (cadr attrs))
48      (pr (case c #\\ "&#x5c;"
49		  #\" "&#x22;"
50		  #\& "&amp;"
51		  c)))
52    (pr "\"")
53    (sml-pr-attrs (cddr attrs))))
54
55(def sml-pr-element (el indent)
56  (if (is (type el) 'cons) (sml-pr-xml el indent)
57      (pr-escaped el)))
58
59(def sml-get-attr (tag name)
60  (sml-get-attr-from-attrs (sml-attrs tag) name))
61
62(def sml-get-attr-from-attrs (attrs name)
63  (when attrs
64    (if (is (car attrs) name) (cadr attrs)
65	    (sml-get-attr-from-attrs (cddr attrs) name))))
66
67;; Pretty-print the S-Expression ML
68(def sml-ppr (tag (o indent 0))
69  (prn)
70  (repeat indent (pr " "))
71  (if (is (type tag) 'cons)
72      (with (name (car tag)
73             attrs (sml-attrs tag)
74             elements (sml-elements tag))
75        (pr "(" name)
76	(each attr attrs (pr " ") (write attr))
77        (each el elements (sml-ppr el (+ indent 2)))
78        (pr ")"))
79      (is (type tag) 'string) (write tag)
80      (is tag nil) (pr nil)
81      (err "Unrecognized type in sml:" (type tag)))
82  (if (is indent 0) (prn)))