42 | | (define (html-transformation-rules content) |
43 | | `(( |
44 | | (@ *preorder* . ,(lambda (tag elements) (cons tag elements))) |
| 42 | (define (html-transformation-rules _) |
| 43 | (let* ((sections '()) |
| 44 | (make-unique-id (lambda (head-word) |
| 45 | (let ((id (internal-link head-word))) |
| 46 | (if (alist-ref id sections string=?) |
| 47 | (conc id "-" (length sections)) |
| 48 | id))))) |
| 49 | `(((@ *preorder* . ,(lambda (tag elements) (cons tag elements))) |
51 | | (toc ;; Re-scan the content for "section" tags and generate |
52 | | *macro* |
53 | | . ,(lambda (tag rest) ;; the table of contents |
54 | | `(div (@ (id "toc")) |
55 | | ,rest |
56 | | (ol ,(let find-sections ((content content)) |
57 | | (cond |
58 | | ((not (pair? content)) '()) |
59 | | ((pair? (car content)) |
60 | | (append (find-sections (car content)) |
61 | | (find-sections (cdr content)))) |
62 | | ((eq? (car content) 'section) |
63 | | (let* ((level (cadr content)) |
64 | | (head-word (caddr content)) |
65 | | (href (conc "#" (internal-link head-word))) |
66 | | (subsections (find-sections (cdddr content)))) |
67 | | (cond ((and (integer? level) head-word) |
68 | | `((li (a (@ (href ,href)) ,head-word) |
69 | | ,@(if (null? subsections) |
70 | | '() |
71 | | `((ol ,subsections)))))) |
72 | | (else |
73 | | (error 'html-transformation-rules |
74 | | "section elements must be of the form (section level head-word . contents)"))))) |
75 | | (else (find-sections (cdr content))))))))) |
| 64 | (image-link |
| 65 | *macro* |
| 66 | . ,(lambda (tag elems) |
| 67 | `(img (@ (src ,(car elems)) . ,(if (null? (cdr elems)) |
| 68 | '() |
| 69 | `((alt ,(cadr elems)) |
| 70 | (title ,(cadr elems)))))))) |
77 | | (section |
78 | | *macro* |
79 | | . ,(lambda (tag elems) |
80 | | (let ((level (car elems)) |
81 | | (head-word (cadr elems)) |
82 | | (contents (cddr elems))) |
83 | | (cond ((and (integer? level) head-word) |
84 | | `((,(string->symbol (string-append "h" (number->string level))) |
85 | | (@ (id ,(internal-link head-word))) |
86 | | ,head-word ) . ,contents)) |
87 | | (else |
88 | | (error 'html-transformation-rules |
89 | | (conc "section elements must be of the form (section level head-word . contents), got " elems)))) |
90 | | ))) |
| 72 | (int-link |
| 73 | *macro* |
| 74 | . ,(lambda (tag elems) |
| 75 | `(a (@ (href ,(car elems)) (class "internal")) |
| 76 | ,(if (null? (cdr elems)) (car elems) (cadr elems))))) |
| 77 | |
| 78 | (link |
| 79 | *macro* |
| 80 | . ,(lambda (tag elems) |
| 81 | `(a (@ (href ,(car elems)) (class "external")) |
| 82 | ,(if (null? (cdr elems)) (car elems) (cadr elems))))) |
92 | | (section* |
93 | | *macro* |
94 | | . ,(lambda (tag elems) |
95 | | (let ((level (car elems)) |
96 | | (head-word (cadr elems)) |
97 | | (contents (cddr elems))) |
98 | | (cond ((and (integer? level) head-word) |
99 | | `((,(string->symbol (string-append "h" (number->string level))) |
100 | | ,head-word ) . ,contents)) |
101 | | (else |
102 | | (error 'html-transformation-rules |
103 | | (conc "section elements must be of the form (section level head-word . contents), got " elems)))) |
104 | | ))) |
| 84 | (section |
| 85 | *preorder/ss* |
| 86 | . ,(lambda (tag elems ss #!optional parent) |
106 | | (def |
107 | | ((sig . ,(lambda (tag types) |
108 | | (map (lambda (spec) |
109 | | `(span (@ (class ,(conc "definition " (car spec)))) |
110 | | (em "[" ,(symbol->string (car spec)) "]") |
111 | | " " (tt ,@(cdr spec)) (br))) |
112 | | types)))) |
113 | | . ,(lambda (tag elems) elems)) |
114 | | |
115 | | (pre |
116 | | . ,(lambda (tag elems) |
117 | | `(pre (tt . ,elems)))) |
| 88 | (let* ((level (car elems)) |
| 89 | (head-word (cadr elems)) |
| 90 | (id (make-unique-id head-word))) |
119 | | (image-link |
120 | | *macro* |
121 | | . ,(lambda (tag elems) |
122 | | `(img (@ (src ,(car elems)) . ,(if (null? (cdr elems)) |
123 | | '() |
124 | | `((alt ,(cadr elems)) |
125 | | (title ,(cadr elems)))))))) |
126 | | |
127 | | (int-link |
128 | | *macro* |
129 | | . ,(lambda (tag elems) |
130 | | `(a (@ (href ,(car elems)) (class "internal")) |
131 | | ,(if (null? (cdr elems)) (car elems) (cadr elems))))) |
132 | | |
133 | | (link |
134 | | *macro* |
135 | | . ,(lambda (tag elems) |
136 | | `(a (@ (href ,(car elems)) (class "external")) |
137 | | ,(if (null? (cdr elems)) (car elems) (cadr elems))))) |
| 92 | (set! sections (cons (list id parent head-word) sections)) |
156 | | ,@universal-conversion-rules*) |
157 | | ) |
158 | | ) |
| 120 | ((toc |
| 121 | *macro* |
| 122 | . ,(lambda (tag rest) |
| 123 | `(div (@ (id "toc")) |
| 124 | ,rest |
| 125 | ,@(let ((sections (reverse sections))) |
| 126 | (let descend ((level (filter (lambda (s) (not (cadr s))) sections))) |
| 127 | (if (null? level) |
| 128 | '() |
| 129 | `((ol ,@(map (lambda (section) |
| 130 | (let* ((id (car section)) |
| 131 | (subsections (filter (lambda (s) (equal? id (cadr s))) sections))) |
| 132 | `(li (a (@ (href ,(conc "#" id))) |
| 133 | ,(caddr section)) |
| 134 | ,@(descend subsections)))) |
| 135 | level))))))))) |
| 136 | |
| 137 | (html:begin |
| 138 | . ,(lambda (tag elems) |
| 139 | (list |
| 140 | xhtml-1.0-strict |
| 141 | "<html xmlns=\"http://www.w3.org/1999/xhtml\">" |
| 142 | elems |
| 143 | "</html>"))) |
| 144 | |
| 145 | (verbatim |
| 146 | *preorder* |
| 147 | . ,(lambda (tag elems) |
| 148 | elems)) |
| 149 | |
| 150 | ,@universal-conversion-rules*)))) |