Newer
Older
;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;; Scribble: Racket-like scribble reader extension for Common Lisp
#+xcvb (module (:depends-on ("package")))
(in-package :scribble)
(defun parse-at-syntax (i)
;; Parse an @ expression.
(let* ((o (make-string-output-stream)) ; buffered output of "current stuff"
(cmdonly nil)
(col 0)
(line ())
(lines ())
(mrof '())) ; current form (reversed)
((?@1 () ; what to do after a @
(cond
((expect-char i #.(coerce '(#\space #\tab #\return #\newline) 'base-string))
(simple-parse-error "Unexpected whitespace after @"))
((expect-char i #\;)
(?at-comment))
(t
(?punctuation))))
(?at-comment ()
(cond
((expect-char i #\{) (?{text}))
(t (read-line i)))
(read-preserving-whitespace i t nil nil))
(?punctuation ()
(let ((char (expect-char i "'`,")))
(ecase char
((#\') (?quote))
((#\`) (?backquote))
((#\,) (cond
((expect-char i #\@)
(?comma-at))
((expect-char i #\.)
(?comma-dot))
(t
(?comma))))
((nil) (?cmd)))))
(?quote ()
(kwote (?punctuation)))
(?backquote ()
(call-with-quasiquote-reader #'?punctuation))
(?comma-at ()
(call-with-unquote-splicing-reader #'?punctuation))
(?comma-dot ()
(call-with-unquote-nsplicing-reader #'?punctuation))
(?comma ()
(call-with-unquote-reader #'?punctuation))
(?cmd ()
(let ((char (expect-char i "|[{")))
(case char
((#\|)
(maybe-alttext #'at-pipe))
((#\[ #\{)
(?datatext char))
(t
(?cmd1)))))
(maybe-alttext (cont)
(unread-char #\| i)
(let ((k (?newkey)))
(cond
(k
(setf cmdonly nil)
(?{alttext} k))
(t
(funcall cont)))))
(at-pipe ()
(read-char i)
(let ((r (read-to-char #\| i))
(eof '#:eof))
(multiple-value-bind (s n) (read-from-string r)
(unless (eq eof (ignore-errors (read-from-string r nil eof :start n)))
(simple-parse-error "Unexpected characters in ~S after position ~D" r n))
(setf cmdonly t)
(form! s)
(?end))))
(?cmd1 ()
(setf cmdonly t)
(form! (read-preserving-whitespace i t nil nil))
(?cmd2))
(?cmd2 ()
(let ((char (expect-char i "[{|")))
(if char
(?datatext char)
(?end))))
(form! (x)
(push x mrof))
(?datatext (char)
(ecase char
(#\[ (?[data]))
((#\{ #\|) (unread-char char i) (?{text}0))))
(?[data] ()
(setf cmdonly nil)
(map () #'form! (read-delimited-list #\] i t))
(?{text}0))
(?{text}0 ()
(cond
((expect-char i #\{)
(setf cmdonly nil)
(?{text}))
((expect-char i #\|)
(maybe-alttext #'?end))
(t (?end))))
(?newkey ()
(loop
:with p = (file-position i)
:with nil = (expect-char i #\|)
:for c = (expect-char i)
:while (and (ascii-char-p c) (not (alphanumericp c)) (not (find c "@|{")))
:collect c :into l
:finally (cond
((eql c #\{) (return (coerce l 'base-string)))
(t (file-position i p) (return nil)))))
(char! (c)
(write-char c o))
(flush! ()
(let* ((s (get-output-stream-string o)))
(when (plusp (length s))
(push s line))))
(eol! (eol)
(let* ((s (get-output-stream-string o))
(s (if eol (trim-ending-spaces s) s)))
(when (plusp (length s))
(push s line))
(push (cons col (reverse line)) lines))
(when eol
(setf col (skip-whitespace-return-column i 0)
line ()))
t)
(?{text} (&aux (brace-level 1))
(setf col (stream-line-column-harder i)
line ())
(loop :for c = (expect-char i) :do
((#\return)
(expect-char i #\newline)
(eol! t))
((#\newline)
(eol! t))
((#\{)
(incf brace-level)
(char! c))
((#\@)
((#\})
(decf brace-level)
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
(cond
((zerop brace-level)
(eol! nil)
(flush-text!)
(return (?end)))
(t
(char! c))))
(otherwise
(char! c)))))
(?inside-at ()
(let ((c (expect-char i ";\"|")))
(case c
((#\;)
(cond
((expect-char i #\{)
(let ((m mrof) (l line) (ls lines) (c col) (co cmdonly) (oo o))
(setf o (make-string-output-stream))
(?{text})
(setf mrof m line l lines ls col c cmdonly co o oo)))
(t
(read-line i)
(skip-whitespace-return-column i))))
((#\")
(unread-char #\" i)
(write-string (read-preserving-whitespace i t nil nil) o))
((#\|)
(flush!)
(let ((r (read-to-char #\| i)))
(with-input-from-string (s r)
(loop :for x = (read-preserving-whitespace s nil s nil)
:until (eq x s) :do (push x line)))))
(flush!)
(push (parse-at-syntax i) line)))))
(flush-text! ()
(let* ((mincol (loop :for (col . strings) :in lines
:when strings
:minimize col))
(text (loop :for (col . strings) :in (reverse lines)
:for first = t :then nil
:append
`(,@(when (and strings (> col mincol) (not first))
(list (n-spaces (- col mincol))))
,@strings ,*lf*))))
(when (eq *lf* (first text))
(pop text))
(let ((e (every (lambda (x) (eq x *lf*)) text))
(r (reverse text)))
(unless e
(loop :repeat 2 :when (eq *lf* (first r)) :do (pop r)))
(setf mrof (append r mrof))))
t)
(?{alttext} (key)
(let ((brace-level 1)
(rkey (mirror-string key)))
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
(setf col (stream-line-column-harder i)
line ())
(loop :for c = (expect-char i) :do
(case c
((#\return)
(expect-char i #\newline)
(eol! t))
((#\newline)
(eol! t))
(#\|
(let* ((p (file-position i))
(c (and (expect-string i key) (expect-char i "@{"))))
(case c
((#\{)
(incf brace-level)
(char! #\|)
(map () #'char! key)
(char! c))
((#\@)
(?inside-at))
(otherwise
(file-position i p)
(char! #\|)))))
((#\})
(let* ((p (file-position i)))
(cond
((and (expect-string i rkey) (expect-char i #\|))
(decf brace-level)
(cond
((zerop brace-level)
(eol! nil)
(flush-text!)
(return (?end)))
(t
(char! #\})
(map () #'char! rkey)
(char! #\|))))
(t
(file-position i p)
(char! #\})))))
(otherwise
(char! c))))))
(?end ()
(if (and cmdonly (length=n-p mrof 1))
(car mrof)
(reverse mrof))))
(defun read-at-syntax (stream &optional char)
(declare (ignore char))
(parse-at-syntax stream))
(defun forbidden-pipe-macro (stream char)
(declare (ignore stream char))
(simple-parse-error "| not allowed when at syntax enabled"))
(defun do-enable-scribble-at-syntax (&key (readtable *readtable*) scribe skribe)
(enable-quasiquote :readtable readtable)
(flet ((s (char fun) (set-macro-character char fun nil readtable)))
(s #\[ #'read-paren-list)
(s #\] #'unbalanced-paren)
(s #\{ #'read-paren-list)
(s #\} #'unbalanced-paren)
(s #\@ #'read-at-syntax)
(when (or scribe skribe) ;; backward compatibility with former scribble?
(do-enable-scribble-syntax readtable))
(s #\| #'forbidden-pipe-macro))
(defvar *scribble-at-readtable* nil)
(defun enable-scribble-at-syntax (&key (readtable *readtable*) (scribe nil))
(setf *scribble-at-readtable* (push-readtable readtable))
(do-enable-scribble-at-syntax :readtable *scribble-at-readtable* :scribe scribe)
*scribble-at-readtable*)
(pop-readtable))
(defun reenable-scribble-at-syntax (&key scribe)
(if (readtablep *scribble-at-readtable*)
(enable-scribble-at-syntax :scribe scribe)
(push-readtable *scribble-at-readtable*))
*scribble-at-readtable*)
(defun parse-at-string (x)
(with-input-from-string (i x)
(let ((*readtable* *scribble-at-readtable*))
(scribble::parse-at-syntax i))))