1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
|
(in-package #:cl-markdown)
(defparameter *markup->lml2*
(make-container
'simple-associative-container
:test #'equal
:initial-contents
'((header1) (nil :h1)
(header2) (nil :h2)
(header3) (nil :h3)
(header4) (nil :h4)
(header5) (nil :h5)
(header6) (nil :h6)
(bullet) ((:ul) :li)
(code) ((:pre :code) nil)
(number) ((:ol) :li)
(quote) ((:blockquote) nil)
(horizontal-rule) (nil :hr))))
;;; ---------------------------------------------------------------------------
(defmethod render ((document document) (style (eql :lml2)) stream)
(let ((*current-document* document))
(setf (level document) 0
(markup document) nil)
(let* ((chunks (collect-elements (chunks document)))
(result (lml2-list->tree chunks)))
(if stream
(format stream "~S" result)
result))))
;;; ---------------------------------------------------------------------------
(defun lml2-marker (chunk)
(bind ((markup (markup-class-for-lml2 chunk)))
(first markup)))
;;; ---------------------------------------------------------------------------
(defmethod render-to-lml2 ((chunk chunk))
(bind ((block (collect-elements
(lines chunk)
:transform (lambda (line)
(render-to-lml2 line))))
(markup (second (markup-class-for-lml2 chunk)))
(paragraph? (paragraph? chunk)))
(cond ((and paragraph? markup)
(values `(,markup (:P ,@block)) t))
(paragraph?
(values `(:P ,@block) t))
(markup
(values `(,markup ,@block) t))
(t
(values block nil)))))
;;; ---------------------------------------------------------------------------
(defmethod markup-class-for-lml2 ((chunk chunk))
(when (markup-class chunk)
(let ((translation (item-at-1 *markup->lml2* (markup-class chunk))))
(unless translation
(warn "No translation for '~A'" (markup-class chunk)))
translation)))
;;; ---------------------------------------------------------------------------
(defmethod render-to-lml2 ((chunk list))
(render-span-to-lml2 (first chunk) (rest chunk)))
;;; ---------------------------------------------------------------------------
(defmethod render-to-lml2 ((chunk string))
;;?? unlovely
(format nil "~A" chunk))
;;; ---------------------------------------------------------------------------
(defmethod render-span-to-lml2 ((code (eql 'strong)) body)
`(:strong ,@body))
;;; ---------------------------------------------------------------------------
(defmethod render-span-to-lml2 ((code (eql 'mail)) body)
(let ((address (first body)))
`((:a :href ,(format nil "mailto:~A" address)) ,address)))
;;; ---------------------------------------------------------------------------
(defmethod render-span-to-lml2 ((code (eql 'emphasis)) body)
`(:em ,@body))
;;; ---------------------------------------------------------------------------
(defmethod render-span-to-lml2 ((code (eql 'strong-em)) body)
`(:strong (:em ,@body)))
;;; ---------------------------------------------------------------------------
(defmethod render-span-to-lml2 ((code (eql 'code)) body)
`(:code ,(render-to-lml2 (first body))))
;;; ---------------------------------------------------------------------------
(defmethod render-span-to-lml2 ((code (eql 'entity)) body)
(first body))
;;; ---------------------------------------------------------------------------
(defmethod render-span-to-lml2 ((code (eql 'reference-link)) body)
(bind (((text &optional (id text)) body)
(link-info (item-at-1 (link-info *current-document*) id)))
(if link-info
`((:a :href ,(url link-info) ,@(awhen (title link-info) `(:title ,it)))
,text)
`,text)))
;;; ---------------------------------------------------------------------------
(defmethod render-span-to-lml2 ((code (eql 'inline-link)) body)
(bind (((text &optional (url "") title) body))
`((:a :href ,url ,@(awhen title `(:title ,it)))
,text)))
;;; ---------------------------------------------------------------------------
(defmethod render-span-to-lml2 ((code (eql 'link)) body)
(bind ((url body))
`((:a :href ,@url) ,@url)))
;;; ---------------------------------------------------------------------------
(defmethod render-span-to-lml2 ((code (eql 'html)) body)
(html-encode:encode-for-pre (first body)))
(defun lml2-list->tree (chunks &key (level nil))
(unless level
(setf level (or (and (first chunks) (level (first chunks))) 0)))
(labels ((do-it (chunks level)
;;?? rather inpenetrable... don't understand at the level I should...
(apply-mark
(lml2-marker (first chunks))
(let (output append? result)
(loop for rest = chunks then (rest rest)
for chunk = (first rest) then (first rest)
while chunk
for new-level = (level chunk)
do (setf (values output append?) (render-to-lml2 chunk))
do (format t "~%C(~D/~D): ~A, ~A" level new-level append? chunk)
when (and (= level new-level) append?) do
(setf result `(,output ,@result))
when (and (= level new-level) (not append?)) do
(setf result `(,@output ,@result))
when (< level new-level) do
(multiple-value-bind (block remaining method)
(next-block rest new-level)
(let ((inner (do-it block (1+ level))))
; (format t "~%--- ~A" method)
(setf rest remaining)
(ecase method
(:level (if (listp (first result))
(push-end inner (first result))
(push inner result)))
(:markup (push inner result))
(:none
(setf result `(,inner ,@result))))))
when (> level new-level) do
(warn "unexpected chunk level"))
(reverse result)))))
(apply #'do-it chunks level)))
;;; ---------------------------------------------------------------------------
(defun apply-mark (mark rest)
(cond ((null mark) rest)
((consp mark)
(if (length-1-list-p mark)
`(,(first mark) ,@(apply-mark (rest mark) rest))
`(,(first mark) (,@(apply-mark (rest mark) rest)))))
(t
(error "unhandled case"))))
|
