Updated files except for the use of set! in telml.scm
Getty Ritter
9 years ago
1 | (declare (unit libs)) | |
1 | ;; some library stuff | |
2 | 2 | |
3 | ;; some library stuff | |
3 | (define (++ . args) | |
4 | (define (go ls) | |
5 | (if (null? ls) "" | |
6 | (string-append (car ls) (go (cdr ls))))) | |
7 | (go args)) | |
4 | 8 | |
5 | 9 | (define (intercalate x xs) |
6 | 10 | (define (go ls) |
7 | (if (null? ls) '() | |
8 | (cons (car ls) (cons x (go (cdr ls)))))) | |
9 |
|
|
11 | (cond ((null? ls) '()) | |
12 | ((null? (cdr ls)) ls) | |
13 | (else | |
14 | (cons (car ls) (cons x (go (cdr ls))))))) | |
15 | (apply ++ (go xs))) | |
10 | 16 | |
11 | 17 | (define (scss->css scss) |
12 | 18 | (define (mk-selector selector) |
13 |
(cond ((symbol? selector) |
|
19 | (cond ((symbol? selector) | |
20 | (symbol->string selector)) | |
14 | 21 | ((and (list? selector) |
15 | 22 | (eq? (car selector) '=) |
16 | 23 | (eq? (cadr selector) 'class)) |
17 |
( |
|
24 | (++ "." (symbol->string (caddr selector)))) | |
18 | 25 | ((and (list? selector) |
19 | 26 | (eq? (car selector) '=) |
20 | 27 | (eq? (cadr selector) 'id)) |
21 |
( |
|
28 | (++ "#" (symbol->string (caddr selector)))) | |
22 | 29 | ((and (list? selector) |
23 | 30 | (eq? (car selector) '//)) |
24 | 31 | (intercalate " " (map mk-selector (cdr selector)))) |
27 | 34 | (intercalate "," (map mk-selector (cdr selector)))) |
28 | 35 | (else "..."))) |
29 | 36 | (define (mk-line line) |
30 |
( |
|
37 | (++ (car line) ": " (cadr line) "; ")) | |
31 | 38 | (define (mk-clause clause) |
32 |
( |
|
39 | (++ | |
33 | 40 | (mk-selector (car clause)) |
34 | 41 | " { " |
35 |
(apply |
|
42 | (apply ++ (map mk-line (cdr clause))) | |
36 | 43 | "} ")) |
37 |
(apply |
|
44 | (apply ++ (map mk-clause scss))) | |
38 | 45 | |
39 | 46 | (define (cadr? sexp) |
40 | 47 | (if (or (null? sexp) |
45 | 52 | (define (serialize-sxml sxml) |
46 | 53 | (define (mk-prop prop) |
47 | 54 | (let ((key (car prop)) (val (cadr prop))) |
48 | (format #f " ~a=~a" key | |
49 | (if (string? val) (format #f "\"~a\"" val) val)))) | |
55 | (++ " " | |
56 | key | |
57 | "=" | |
58 | (if (string? val) (++ "\"" val "\"") val)))) | |
50 | 59 | (cond ((null? sxml) "") |
51 | 60 | ((string? sxml) sxml) |
52 | 61 | ((symbol? sxml) (symbol->string sxml)) |
58 | 67 | (cdadr sxml) '())) |
59 | 68 | (vals (if (and (cadr? sxml) (eq? (caadr sxml) '@)) |
60 | 69 | (cddr sxml) (cdr sxml)))) |
61 | (format #f "<~a~a>~a</~a>" | |
62 | tag | |
63 | (apply string-append (map mk-prop props)) | |
64 | (apply string-append (map serialize-sxml vals)) | |
65 |
|
|
70 | (++ "<" | |
71 | tag | |
72 | (apply ++ (map mk-prop props)) | |
73 | ">" | |
74 | (apply ++ (map serialize-sxml vals)) | |
75 | "</" | |
76 | tag | |
77 | ">"))))) |
1 | (declare (unit telml)) | |
2 | ||
3 | (require-extension srfi-13) | |
4 | (require-extension srfi-14) | |
5 |
( |
|
1 | (import (owl io)) | |
2 | (import (owl string)) | |
3 | (import (owl sexp)) | |
6 | 4 | |
7 | 5 | (define (mk-stream s) |
8 | 6 | (let ((lst (string->list s))) |
31 | 29 | (if (s 'peek) (cons (s 'next) (stream->list s)) '())) |
32 | 30 | |
33 | 31 | (define (ident-char? c) |
34 | (and c (or (char-set-contains? char-set:letter c) | |
35 | (eq? c #\-) | |
36 |
|
|
32 | (let ((i (char->integer c))) | |
33 | (or (= i 45) (= i 95) | |
34 | (and (>= i 64) (<= i 90)) | |
35 | (and (>= i 97) (<= i 122))))) | |
36 | ||
37 | (define (whitespace? c) | |
38 | (let ((i (char->integer c))) | |
39 | (or (= i 9) (= i 10) (= i 13) (= i 32)))) | |
37 | 40 | |
38 | 41 | (define (parse str) |
39 | 42 | (let ((s (mk-stream str))) |
40 | 43 | |
41 | 44 | (define (match-char c) |
42 |
(if (eq? (s 'next) c) #t ( |
|
45 | (if (eq? (s 'next) c) #t (raise c))) | |
43 | 46 | |
44 | 47 | (define (parse-tag) |
45 | 48 | (let* ((_ (match-char #\\)) |
60 | 63 | (list->string (go))) |
61 | 64 | |
62 | 65 | (define (skip-whitespace) |
63 |
(if ( |
|
66 | (if (whitespace? (s 'peek)) | |
64 | 67 | (begin (s 'next) (skip-whitespace)))) |
65 | 68 | |
66 | 69 | (define (parse-tag-name) |
76 | 79 | (let ((f (parse-fragment-list))) |
77 | 80 | (cond ((eq? (s 'peek) #\|) (begin (s 'next) (cons f (parse-args)))) |
78 | 81 | ((eq? (s 'peek) #\}) (list f)) |
79 |
(else ( |
|
82 | (else (raise 'unreachable)))))) | |
80 | 83 | |
81 | 84 | (define (parse-fragment) |
82 | 85 | (let ((c (s 'peek))) |
121 | 124 | (cons (append (car lst) (list (car doc))) |
122 | 125 | (cdr lst)))))) |
123 | 126 | |
127 | (define (string-take str i) | |
128 | (substring str 0 i)) | |
129 | ||
130 | (define (string-drop str i) | |
131 | (let ((l (string-length str))) | |
132 | (substring str i (- l i)))) | |
133 | ||
124 | 134 | (define (gather-para document) |
125 | 135 | (define (split-string text) |
126 |
(let ((i (string- |
|
136 | (let ((i (string-ref text "\n\n"))) | |
127 | 137 | (if (not i) (list text) |
128 | 138 | (cons (string-take text i) |
129 | 139 | (cons #f (split-string (string-drop text (+ i 2)))))))) |
144 | 154 | (func (assoc (car arg) tags))) |
145 | 155 | (if func |
146 | 156 | (apply (cdr func) args) |
147 |
( |
|
157 | (raise "Unknown tag")))) | |
148 | 158 | (else |
149 | 159 | (map rec arg)))) |
150 | 160 | (let ((meta (if (and (not (null? telml)) |
157 | 167 | (eq? (caar telml) 'meta)) |
158 | 168 | (cdr telml) |
159 | 169 | telml))) |
160 |
(cons (if meta ( |
|
170 | (cons (if meta (string->sexp meta) '()) | |
161 | 171 | (map (lambda (x) |
162 | 172 | (cons 'p (rec x))) |
163 | 173 | (gather-para body))))) |
164 | 174 | |
165 | 175 | (define (translate-file filename) |
166 |
(telml->sxml (parse ( |
|
176 | (telml->sxml (parse (list->string (file->list filename))) basic-tag-list)) |