gdritter repos when-computer / d5aaa5b
Updated files except for the use of set! in telml.scm Getty Ritter 9 years ago
2 changed file(s) with 56 addition(s) and 34 deletion(s). Collapse all Expand all
1 (declare (unit libs))
1 ;; some library stuff
22
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))
48
59 (define (intercalate x xs)
610 (define (go ls)
7 (if (null? ls) '()
8 (cons (car ls) (cons x (go (cdr ls))))))
9 (apply string-append (go xs)))
11 (cond ((null? ls) '())
12 ((null? (cdr ls)) ls)
13 (else
14 (cons (car ls) (cons x (go (cdr ls)))))))
15 (apply ++ (go xs)))
1016
1117 (define (scss->css scss)
1218 (define (mk-selector selector)
13 (cond ((symbol? selector) (symbol->string selector))
19 (cond ((symbol? selector)
20 (symbol->string selector))
1421 ((and (list? selector)
1522 (eq? (car selector) '=)
1623 (eq? (cadr selector) 'class))
17 (format #f ".~a" (symbol->string (caddr selector))))
24 (++ "." (symbol->string (caddr selector))))
1825 ((and (list? selector)
1926 (eq? (car selector) '=)
2027 (eq? (cadr selector) 'id))
21 (format #f "#~a" (symbol->string (caddr selector))))
28 (++ "#" (symbol->string (caddr selector))))
2229 ((and (list? selector)
2330 (eq? (car selector) '//))
2431 (intercalate " " (map mk-selector (cdr selector))))
2734 (intercalate "," (map mk-selector (cdr selector))))
2835 (else "...")))
2936 (define (mk-line line)
30 (format #f "~a: ~a; " (car line) (cadr line)))
37 (++ (car line) ": " (cadr line) "; "))
3138 (define (mk-clause clause)
32 (string-append
39 (++
3340 (mk-selector (car clause))
3441 " { "
35 (apply string-append (map mk-line (cdr clause)))
42 (apply ++ (map mk-line (cdr clause)))
3643 "} "))
37 (apply string-append (map mk-clause scss)))
44 (apply ++ (map mk-clause scss)))
3845
3946 (define (cadr? sexp)
4047 (if (or (null? sexp)
4552 (define (serialize-sxml sxml)
4653 (define (mk-prop prop)
4754 (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))))
5059 (cond ((null? sxml) "")
5160 ((string? sxml) sxml)
5261 ((symbol? sxml) (symbol->string sxml))
5867 (cdadr sxml) '()))
5968 (vals (if (and (cadr? sxml) (eq? (caadr sxml) '@))
6069 (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 tag)))))
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 (require-extension utils)
1 (import (owl io))
2 (import (owl string))
3 (import (owl sexp))
64
75 (define (mk-stream s)
86 (let ((lst (string->list s)))
3129 (if (s 'peek) (cons (s 'next) (stream->list s)) '()))
3230
3331 (define (ident-char? c)
34 (and c (or (char-set-contains? char-set:letter c)
35 (eq? c #\-)
36 (eq? c #\_))))
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))))
3740
3841 (define (parse str)
3942 (let ((s (mk-stream str)))
4043
4144 (define (match-char c)
42 (if (eq? (s 'next) c) #t (abort c)))
45 (if (eq? (s 'next) c) #t (raise c)))
4346
4447 (define (parse-tag)
4548 (let* ((_ (match-char #\\))
6063 (list->string (go)))
6164
6265 (define (skip-whitespace)
63 (if (char-set-contains? char-set:whitespace (s 'peek))
66 (if (whitespace? (s 'peek))
6467 (begin (s 'next) (skip-whitespace))))
6568
6669 (define (parse-tag-name)
7679 (let ((f (parse-fragment-list)))
7780 (cond ((eq? (s 'peek) #\|) (begin (s 'next) (cons f (parse-args))))
7881 ((eq? (s 'peek) #\}) (list f))
79 (else (abort 'unreachable))))))
82 (else (raise 'unreachable))))))
8083
8184 (define (parse-fragment)
8285 (let ((c (s 'peek)))
121124 (cons (append (car lst) (list (car doc)))
122125 (cdr lst))))))
123126
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
124134 (define (gather-para document)
125135 (define (split-string text)
126 (let ((i (string-contains text "\n\n")))
136 (let ((i (string-ref text "\n\n")))
127137 (if (not i) (list text)
128138 (cons (string-take text i)
129139 (cons #f (split-string (string-drop text (+ i 2))))))))
144154 (func (assoc (car arg) tags)))
145155 (if func
146156 (apply (cdr func) args)
147 (abort (format #f "Unknown tag: `~a`" (car arg))))))
157 (raise "Unknown tag"))))
148158 (else
149159 (map rec arg))))
150160 (let ((meta (if (and (not (null? telml))
157167 (eq? (caar telml) 'meta))
158168 (cdr telml)
159169 telml)))
160 (cons (if meta (call-with-input-string meta read) '())
170 (cons (if meta (string->sexp meta) '())
161171 (map (lambda (x)
162172 (cons 'p (rec x)))
163173 (gather-para body)))))
164174
165175 (define (translate-file filename)
166 (telml->sxml (parse (read-all filename)) basic-tag-list))
176 (telml->sxml (parse (list->string (file->list filename))) basic-tag-list))