-
-
Notifications
You must be signed in to change notification settings - Fork 2
/
plump-tex.lisp
182 lines (161 loc) · 6.13 KB
/
plump-tex.lisp
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
(defpackage #:plump-tex
(:nicknames #:org.tymoonnext.plump.tex)
(:use #:cl #:plump)
(:shadow
#:parse
#:serialize)
(:export
#:parse
#:serialize))
(in-package #:plump-tex)
;; This is pretty much a copy of plump/parser.lisp with changes so that it matches common TeX markup.
(defvar *tex-tag-dispatchers* ())
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *whitespace* '(#\Space #\Newline #\Tab #\Return #\Linefeed #\Page)))
(define-matcher tex-tag-start (and (is #\\)
(not (prev (is #\\)))
(next (or (in #\a #\z)
(in #\A #\Z)
(is #\@)))))
(define-matcher tex-block-start (and (is #\{)
(not (prev (is #\\)))))
(define-matcher tex-block-end (and (is #\})
(not (prev (is #\\)))))
(define-matcher tex-tag-name (or (in #\a #\z) (in #\A #\Z) (in #\0 #\9) (is #\@)))
(define-matcher tex-attribute-closing (or (find *whitespace*)
(any #\, #\])))
(defun replace-escaped (string)
(cl-ppcre:regex-replace-all "\\\\([&%$#_{}~^\\\\])" string "\\1"))
(defun read-tex-name ()
(consume-until (make-matcher (not :tex-tag-name))))
(defun read-tex-text ()
(make-text-node
*root*
(replace-escaped
(consume-until (make-matcher (or :tex-block-start
:tex-block-end
:tex-tag-start))))))
(defun read-tex-attribute-name ()
(replace-escaped
(consume-until (make-matcher (or (and (is #\=)
(not (prev (is #\\))))
:tex-attribute-closing)))))
(defun read-tex-children ()
(loop for peek = (peek)
while peek
until (char= peek #\})
do (or (read-tex-tag)
(read-tex-block)
(read-tex-text))
finally (consume)))
(defun read-tex-attribute-value ()
(case (peek)
(#\" (prog1 (replace-escaped
(consume-until (make-matcher (and (is #\") (not (prev (is #\\)))))))
(consume)))
(T (replace-escaped
(consume-until (make-matcher :tex-attribute-closing))))))
(defun read-tex-attribute ()
(let ((name (read-tex-attribute-name))
(next (consume))
(value ""))
(case next
((nil))
(#\=
(setf value (read-tex-attribute-value)))
(T
(unread)))
(cons name value)))
(defun read-tex-attributes ()
(loop with table = (make-attribute-map)
for char = (peek)
do (case char
((nil)
(return table))
(#\]
(advance)
(return table))
(#.*whitespace*
(advance))
(#\,
(advance))
(T
(let ((entry (read-tex-attribute)))
(setf (gethash (car entry) table) (cdr entry)))))))
(defun read-tex-standard-tag (name)
(let* ((closing (peek))
(attrs (if (and closing (char= closing #\[))
(prog2 (advance) (read-tex-attributes)
(setf closing (peek)))
(make-attribute-map))))
(case closing
(#\{
(advance)
(let ((*root* (make-element *root* name :attributes attrs)))
(read-tex-children)
*root*))
(T (make-element *root* name :attributes attrs)))))
(defun read-tex-tag ()
(when (funcall (make-matcher :tex-tag-start))
(consume) ; Consume backslash
(let ((name (read-tex-name)))
(or (loop for (d test func) in *tex-tag-dispatchers*
when (funcall (the function test) name)
do (return (funcall (the function func) name))
finally (return (read-tex-standard-tag name)))
(progn
(unread-n (length name))
(let ((text (read-tex-text)))
(setf (text text) (concatenate 'string "\\" (text text)))
text))))))
(defun read-tex-block ()
(when (funcall (make-matcher :tex-block-start))
(read-tex-standard-tag "div")))
(defun read-tex-root (&optional (root (make-root)))
(let ((*root* root))
(loop while (peek)
do (or (read-tex-tag)
(read-tex-block)
(read-tex-text)))
*root*))
(defgeneric parse (input &key root)
(:method ((input string) &key root)
(let ((input (typecase input
(simple-string input)
(string (copy-seq input)))))
(with-lexer-environment (input)
(if root
(read-tex-root root)
(read-tex-root)))))
(:method ((input pathname) &key root)
(with-open-file (stream input :direction :input)
(parse stream :root root)))
(:method ((input stream) &key root)
(parse (plump::slurp-stream input) :root root)))
(defgeneric serialize (node &optional stream)
(:documentation "Serialize the given node in TeX syntax and print it to the stream.")
(:method ((node text-node) &optional (stream *standard-output*))
(format stream "~a" (text node)))
(:method ((node element) &optional (stream *standard-output*))
(unless (equal (tag-name node) "div")
(format stream "\\~a" (tag-name node)))
(serialize (attributes node) stream)
(when (> (length (children node)) 0)
(format stream "{")
(loop for child across (children node)
do (serialize child stream))
(format stream "}")))
(:method ((table hash-table) &optional (stream *standard-output*))
(when (> (hash-table-count table) 0)
(format stream "[")
(let ((list (loop for key being the hash-keys of table
for val being the hash-values of table
collecting (format nil "~a~@[=~s~]" key val))))
(format stream "~{~a~#[~:;, ~]~}" list))
(format stream "]")))
(:method ((node nesting-node) &optional (stream *standard-output*))
(loop for child across (children node)
do (serialize child stream)))
(:method ((nodes vector) &optional (stream *standard-output*))
(loop for child across nodes
do (serialize child stream))))