Commit d5aaa5b652197a151f2e99adaccd9b469874938c - when-computer

Updated files except for the use of set! in telml.scm Getty Ritter 10 years ago

2 changed file(s) with 56 addition(s) and 34 deletion(s). Collapse all Expand all

+31

-19

generator/libs.scm less more

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		~~(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)))
10	16
11	17	(define (scss->css scss)
12	18	(define (mk-selector selector)
13		(cond ((symbol? selector) ~~(symbol->string 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		(~~format #f ".~a~~" (symbol->string (caddr selector))))
	24	(++ "." (symbol->string (caddr selector))))
18	25	((and (list? selector)
19	26	(eq? (car selector) '=)
20	27	(eq? (cadr selector) 'id))
21		(~~format #f "#~a~~" (symbol->string (caddr selector))))
	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		(~~format #f "~a: ~a; " (car line) (cadr line)~~))
	37	(++ (car line) ": " (cadr line) "; "))
31	38	(define (mk-clause clause)
32		(~~string-append~~
	39	(++
33	40	(mk-selector (car clause))
34	41	" { "
35		(apply ~~string-append~~ (map mk-line (cdr clause)))
	42	(apply ++ (map mk-line (cdr clause)))
36	43	"} "))
37		(apply ~~string-append~~ (map mk-clause scss)))
	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		~~tag)))))~~
	70	(++ "<"
	71	tag
	72	(apply ++ (map mk-prop props))
	73	">"
	74	(apply ++ (map serialize-sxml vals))
	75	"</"
	76	tag
	77	">")))))

+25

-15

generator/telml.scm less more

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))
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		~~(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))))
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 (~~abort~~ c)))
	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 (~~char-set-contains? char-set:whitespace~~ (s 'peek))
	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 (~~abort~~ 'unreachable))))))
	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-~~contains~~ text "\n\n")))
	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		(~~abort (format #f "Unknown tag: `~a`" (car arg))~~))))
	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 (~~call-with-input-string meta read~~) '())
	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 (~~read-all filename~~)) basic-tag-list))
	176	(telml->sxml (parse (list->string (file->list filename))) basic-tag-list))