100 lines
3.7 KiB
Racket
100 lines
3.7 KiB
Racket
;; Copied and modified from https://github.com/racket/scribble/blob/
|
|
;; 31ad440b75b189a2b0838aab011544d44d6b580/
|
|
;; scribble-lib/scribble/comment-reader.rkt
|
|
;;
|
|
;; Maybe this should use instead the 'scribble property? See
|
|
;; https://docs.racket-lang.org/scribble/
|
|
;; reader-internals.html#%28part._.Syntax_.Properties%29
|
|
(module comment-reader scheme/base
|
|
(require (only-in racket/port peeking-input-port))
|
|
|
|
(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 ([p (peeking-input-port port)])
|
|
(if (eq? (read p) '#:escape-id)
|
|
(begin (read port) (read port))
|
|
'unsyntax)))
|
|
|
|
(define (make-comment-readtable #:readtable [rt (current-readtable)]
|
|
#:comment-wrapper [comment-wrapper 'code:comment]
|
|
#:unsyntax [unsyntax? #t])
|
|
(make-readtable rt
|
|
#\; 'terminating-macro
|
|
(case-lambda
|
|
[(char port)
|
|
(do-comment port
|
|
(lambda () (read/recursive port #\@))
|
|
#:comment-wrapper comment-wrapper
|
|
#:unsyntax unsyntax?)]
|
|
[(char port src line col pos)
|
|
(let ([v (do-comment port
|
|
(lambda () (read-syntax/recursive src port #\@))
|
|
#:comment-wrapper comment-wrapper
|
|
#:unsyntax unsyntax?)])
|
|
(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
|
|
#:comment-wrapper [comment-wrapper 'code:comment]
|
|
#:unsyntax [unsyntax? #t])
|
|
(define comment-text
|
|
`(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 comment-unsyntax
|
|
(if unsyntax?
|
|
`(,(unsyntaxer) ,comment-text)
|
|
comment-text))
|
|
`(,comment-wrapper ,comment-text))
|
|
|
|
(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)))))
|