diff options
Diffstat (limited to 'prototypes/c3b2/web/html.scm')
-rw-r--r-- | prototypes/c3b2/web/html.scm | 133 |
1 files changed, 133 insertions, 0 deletions
diff --git a/prototypes/c3b2/web/html.scm b/prototypes/c3b2/web/html.scm new file mode 100644 index 0000000..9190316 --- /dev/null +++ b/prototypes/c3b2/web/html.scm | |||
@@ -0,0 +1,133 @@ | |||
1 | ;;; Copyright © 2015 David Thompson <davet@gnu.org> | ||
2 | ;;; Copyright © 2016-2017 Amirouche Boubekki <amirouche@hypermove.net> | ||
3 | ;;; | ||
4 | ;;; This program is free software: you can redistribute it and/or modify | ||
5 | ;;; it under the terms of the GNU General Public License as published by | ||
6 | ;;; the Free Software Foundation, either version 3 of the License, or | ||
7 | ;;; (at your option) any later version. | ||
8 | ;;; | ||
9 | ;;; This program is distributed in the hope that it will be useful, | ||
10 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
12 | ;;; GNU General Public License for more details. | ||
13 | ;;; | ||
14 | ;;; You should have received a copy of the GNU General Public License | ||
15 | ;;; along with this program. If not, see <http://www.gnu.org/licenses/>. | ||
16 | |||
17 | ;; ChangeLog: | ||
18 | ;; | ||
19 | ;; - 2017-XX-XX: add support for script tags | ||
20 | ;; | ||
21 | |||
22 | (define-module (web html)) | ||
23 | |||
24 | (use-modules (ice-9 rdelim)) | ||
25 | (use-modules (sxml simple)) | ||
26 | (use-modules (srfi srfi-26)) | ||
27 | (use-modules (ice-9 match)) | ||
28 | (use-modules (ice-9 format)) | ||
29 | (use-modules (ice-9 hash-table)) | ||
30 | (use-modules (srfi srfi-1)) | ||
31 | |||
32 | (use-modules (web uri)) | ||
33 | (use-modules ((sxml xpath) #:renamer (symbol-prefix-proc 'sxml:))) | ||
34 | |||
35 | ;;; | ||
36 | ;;; sxml->html | ||
37 | ;;; | ||
38 | |||
39 | (define %void-elements | ||
40 | '(area | ||
41 | base | ||
42 | br | ||
43 | col | ||
44 | command | ||
45 | embed | ||
46 | hr | ||
47 | img | ||
48 | input | ||
49 | keygen | ||
50 | link | ||
51 | meta | ||
52 | param | ||
53 | source | ||
54 | track | ||
55 | wbr)) | ||
56 | |||
57 | (define (void-element? tag) | ||
58 | "Return #t if TAG is a void element." | ||
59 | (pair? (memq tag %void-elements))) | ||
60 | |||
61 | (define %escape-chars | ||
62 | (alist->hash-table | ||
63 | '((#\" . "quot") | ||
64 | (#\& . "amp") | ||
65 | (#\' . "apos") | ||
66 | (#\< . "lt") | ||
67 | (#\> . "gt")))) | ||
68 | |||
69 | (define (string->escaped-html s port) | ||
70 | "Write the HTML escaped form of S to PORT." | ||
71 | (define (escape c) | ||
72 | (let ((escaped (hash-ref %escape-chars c))) | ||
73 | (if escaped | ||
74 | (format port "&~a;" escaped) | ||
75 | (display c port)))) | ||
76 | (string-for-each escape s)) | ||
77 | |||
78 | (define (object->escaped-html obj port) | ||
79 | "Write the HTML escaped form of OBJ to PORT." | ||
80 | (string->escaped-html | ||
81 | (call-with-output-string (cut display obj <>)) | ||
82 | port)) | ||
83 | |||
84 | (define (attribute-value->html value port) | ||
85 | "Write the HTML escaped form of VALUE to PORT." | ||
86 | (if (string? value) | ||
87 | (string->escaped-html value port) | ||
88 | (object->escaped-html value port))) | ||
89 | |||
90 | (define (attribute->html attr value port) | ||
91 | "Write ATTR and VALUE to PORT." | ||
92 | (format port "~a=\"" attr) | ||
93 | (attribute-value->html value port) | ||
94 | (display #\" port)) | ||
95 | |||
96 | (define (element->html tag attrs body port) | ||
97 | "Write the HTML TAG to PORT, where TAG has the attributes in the | ||
98 | list ATTRS and the child nodes in BODY." | ||
99 | (format port "<~a" tag) | ||
100 | (for-each (match-lambda | ||
101 | ((attr value) | ||
102 | (display #\space port) | ||
103 | (attribute->html attr value port))) | ||
104 | attrs) | ||
105 | (cond | ||
106 | ((and (null? body) (void-element? tag)) (display " />" port)) | ||
107 | ((eqv? tag 'script) (display #\> port) (unless (null? body) (display (car body) port)) (display "</script>" port)) | ||
108 | (else (begin | ||
109 | (display #\> port) | ||
110 | (for-each (cut sxml->html <> port) body) | ||
111 | (format port "</~a>" tag))))) | ||
112 | |||
113 | (define (doctype->html doctype port) | ||
114 | (format port "<!DOCTYPE ~a>" doctype)) | ||
115 | |||
116 | (define* (sxml->html tree #:optional (port (current-output-port))) | ||
117 | "Write the serialized HTML form of TREE to PORT." | ||
118 | (match tree | ||
119 | (() *unspecified*) | ||
120 | (('doctype type) | ||
121 | (doctype->html type port)) | ||
122 | (((? symbol? tag) ('@ attrs ...) body ...) | ||
123 | (element->html tag attrs body port)) | ||
124 | (((? symbol? tag) body ...) | ||
125 | (element->html tag '() body port)) | ||
126 | ((nodes ...) | ||
127 | (for-each (cut sxml->html <> port) nodes)) | ||
128 | ((? string? text) | ||
129 | (string->escaped-html text port)) | ||
130 | ;; Render arbitrary Scheme objects, too. | ||
131 | (obj (object->escaped-html obj port)))) | ||
132 | |||
133 | (export sxml->html) | ||