bebefaa45c
pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/manual.scrbl * Changed parameter name to #:escape-id. pkgs/scribble-pkgs/scribble-lib/scribble/comment-reader.rkt original commit: 9907165af8009585ab5e0f4427d68acbdeadc0a0
85 lines
2.8 KiB
Racket
85 lines
2.8 KiB
Racket
(module comment-reader scheme/base
|
|
|
|
(provide (rename-out [*read read]
|
|
[*read-syntax read-syntax])
|
|
make-comment-readtable)
|
|
|
|
(define unsyntaxer (make-parameter 'unsyntax))
|
|
|
|
(define (*read [inp (current-input-port)])
|
|
(parameterize ([unsyntaxer (read-unsyntaxer inp)]
|
|
[current-readtable (make-comment-readtable)])
|
|
(read/recursive inp)))
|
|
|
|
(define (*read-syntax src [port (current-input-port)])
|
|
(parameterize ([unsyntaxer (read-unsyntaxer port)]
|
|
[current-readtable (make-comment-readtable)])
|
|
(read-syntax/recursive src port)))
|
|
|
|
(define (read-unsyntaxer port)
|
|
(let-values ([(l c p) (port-next-location port)])
|
|
(if (eq? (read port) '#:escape-id)
|
|
(read port)
|
|
(begin
|
|
(set-port-next-location! port l c p)
|
|
'unsyntax))))
|
|
|
|
(define (make-comment-readtable #:readtable [rt (current-readtable)])
|
|
(make-readtable rt
|
|
#\; 'terminating-macro
|
|
(case-lambda
|
|
[(char port)
|
|
(do-comment port (lambda () (read/recursive port #\@)))]
|
|
[(char port src line col pos)
|
|
(let ([v (do-comment port (lambda () (read-syntax/recursive src port #\@)))])
|
|
(let-values ([(eline ecol epos) (port-next-location port)])
|
|
(datum->syntax
|
|
#f
|
|
v
|
|
(list src line col pos (and pos epos (- epos pos))))))])))
|
|
|
|
(define (do-comment port recur)
|
|
(let loop ()
|
|
(when (equal? #\; (peek-char port))
|
|
(read-char port)
|
|
(loop)))
|
|
(when (equal? #\space (peek-char port))
|
|
(read-char port))
|
|
`(code:comment
|
|
(,(unsyntaxer)
|
|
(t
|
|
,@(append-strings
|
|
(let loop ()
|
|
(let ([c (read-char port)])
|
|
(cond
|
|
[(or (eof-object? c)
|
|
(char=? c #\newline))
|
|
null]
|
|
[(char=? c #\@)
|
|
(cons (recur) (loop))]
|
|
[else
|
|
(cons (string c)
|
|
(loop))]))))))))
|
|
|
|
(define (append-strings l)
|
|
(let loop ([l l][s null])
|
|
(cond
|
|
[(null? l) (if (null? s)
|
|
null
|
|
(preserve-space (apply string-append (reverse s))))]
|
|
[(string? (car l))
|
|
(loop (cdr l) (cons (car l) s))]
|
|
[else
|
|
(append (loop null s)
|
|
(cons
|
|
(car l)
|
|
(loop (cdr l) null)))])))
|
|
|
|
(define (preserve-space s)
|
|
(let ([m (regexp-match-positions #rx" +" s)])
|
|
(if m
|
|
(append (preserve-space (substring s 0 (caar m)))
|
|
(list `(hspace ,(- (cdar m) (caar m))))
|
|
(preserve-space (substring s (cdar m))))
|
|
(list s)))))
|