gdritter repos when-computer / 7f314bf
starting to add telml support Getty Ritter 9 years ago
2 changed file(s) with 128 addition(s) and 2 deletion(s). Collapse all Expand all
+13
-2
generator/generate.scm less more
1 (require-extension scss)
12 (require-extension sxml-serializer)
2 (require-extension scss)
33 (require-extension matchable)
4
5 (load "telml.scm")
46
57 (define (pairs lst)
68 (match lst
3739
3840 ((// (= class navlist) ul)
3941 (padding-left 100px)
40 (padding-right 100px))))
42 (padding-right 100px))
43
44 ((= class sidenode)
45 (float right)
46 (clear right)
47 (margin-right -60%)
48 (width 50%))))
4149
4250 (define menu
4351 (let ((menu-item
6472 (div (@ (class "main")) ,content)
6573 (div (@ (class "footer")) "© 2015 getty ritter"))))
6674
75 (define (main title file)
76 (display (serialize-sxml (page title (translate-file file)))))
77
6778 (display (serialize-sxml (apply page (command-line-arguments))))
+115
-0
generator/telml.scm less more
1 (require-extension matchable)
2 (require-extension srfi-13)
3 (require-extension srfi-14)
4 (require-extension utils)
5
6 (define (mk-stream s)
7 (let ((lst (string->list s)))
8 (lambda (msg)
9 (match msg
10 [ 'next (match lst
11 [ (x . xs) (begin (set! lst xs) x) ]
12 [ '() #f ]) ]
13 [ 'peek (match lst
14 [ (x . xs) x ]
15 [ '() #f ]) ]
16 [ 'done (null? lst) ]))))
17
18 (define (special-char? c)
19 (or (eq? c #\\)
20 (eq? c #\{)
21 (eq? c #\})
22 (eq? c #\|)
23 (not c)))
24
25 (define (stream->list s)
26 (if (s 'peek) (cons (s 'next) (stream->list s)) '()))
27
28 (define (ident-char? c)
29 (and c (or (char-set-contains? char-set:letter c)
30 (eq? c #\-)
31 (eq? c #\_))))
32
33 (define (parse str)
34 (let ((s (mk-stream str)))
35
36 (define (match-char c)
37 (if (eq? (s 'next) c) #t (abort c)))
38
39 (define (parse-tag)
40 (let* ((_ (match-char #\\))
41 (name (parse-tag-name))
42 (_ (skip-whitespace))
43 (_ (match-char #\{))
44 (args (parse-args))
45 (_ (match-char #\})))
46 `(,(string->symbol name) ,@args)))
47
48 (define (parse-text)
49 (define (go)
50 (if (special-char? (s 'peek))
51 '()
52 (let ((c (s 'next))) (cons c (go)))))
53 (list->string (go)))
54
55 (define (skip-whitespace)
56 (if (char-set-contains? char-set:whitespace (s 'peek))
57 (begin (s 'next) (skip-whitespace))))
58
59 (define (parse-tag-name)
60 (define (go)
61 (if (ident-char? (s 'peek))
62 (cons (s 'next) (go))
63 '()))
64 (list->string (go)))
65
66 (define (parse-args)
67 (if (eq? (s 'peek) #\})
68 '()
69 (let ((f (parse-fragment-list)))
70 (match (s 'peek)
71 [ #\| (begin (s 'next) (cons f (parse-args))) ]
72 [ #\} (list f) ]
73 [ x (abort (cons 'unreachable x)) ]))))
74
75 (define (parse-fragment)
76 (let ((c (s 'peek)))
77 (cond ((not c) '())
78 ((eq? c #\\) (parse-tag))
79 (else (parse-text)))))
80
81 (define (parse-fragment-list)
82 (cond ((or (not (s 'peek))
83 (eq? (s 'peek) #\})
84 (eq? (s 'peek) #\|)) '())
85 (else (let* ((f (parse-fragment))
86 (fs (parse-fragment-list)))
87 (cons f fs)))))
88
89 (parse-fragment-list)))
90
91 (define basic-tag-list
92 (let ((simple-tag (lambda (n) (cons n (lambda (arg) (list n arg)))))
93 (list-tag (lambda (n) (cons n (lambda args (cons n args))))))
94 (list (simple-tag 'em)
95 (simple-tag 'strong)
96 (simple-tag 'li)
97 (simple-tag 'code)
98 (list-tag 'p)
99 (list-tag 'ul)
100 (cons 'link (lambda (url name)
101 `(a (@ (href ,(apply string-append url))) ,name)))
102 (cons 'sidenote (lambda (arg) `(div (@ (class sidenote)) ,arg))))))
103
104 (define (telml->sxml telml tags)
105 (let ((rec (lambda (arg) (telml->sxml arg tags))))
106 (cond ((string? telml) telml)
107 ((symbol? (car telml))
108 (let ((args (map rec (cdr telml)))
109 (func (cdr (assoc (car telml) tags))))
110 (apply func args)))
111 (else
112 (map rec telml)))))
113
114 (define (translate-file filename)
115 (telml->sxml (parse (read-all filename)) basic-tag-list))