comment-reader.rkt (3833B)
1 ;; Copied and modified from https://github.com/racket/scribble/blob/ 2 ;; 31ad440b75b189a2b0838aab011544d44d6b580/ 3 ;; scribble-lib/scribble/comment-reader.rkt 4 ;; 5 ;; Maybe this should use instead the 'scribble property? See 6 ;; https://docs.racket-lang.org/scribble/ 7 ;; reader-internals.html#%28part._.Syntax_.Properties%29 8 (module comment-reader scheme/base 9 (require (only-in racket/port peeking-input-port)) 10 11 (provide (rename-out [*read read] 12 [*read-syntax read-syntax]) 13 make-comment-readtable) 14 15 (define unsyntaxer (make-parameter 'unsyntax)) 16 17 (define (*read [inp (current-input-port)]) 18 (parameterize ([unsyntaxer (read-unsyntaxer inp)] 19 [current-readtable (make-comment-readtable)]) 20 (read/recursive inp))) 21 22 (define (*read-syntax src [port (current-input-port)]) 23 (parameterize ([unsyntaxer (read-unsyntaxer port)] 24 [current-readtable (make-comment-readtable)]) 25 (read-syntax/recursive src port))) 26 27 (define (read-unsyntaxer port) 28 (let ([p (peeking-input-port port)]) 29 (if (eq? (read p) '#:escape-id) 30 (begin (read port) (read port)) 31 'unsyntax))) 32 33 (define (make-comment-readtable #:readtable [rt (current-readtable)] 34 #:comment-wrapper [comment-wrapper 'code:comment] 35 #:unsyntax [unsyntax? #t]) 36 (make-readtable rt 37 #\; 'terminating-macro 38 (case-lambda 39 [(char port) 40 (do-comment port 41 (lambda () (read/recursive port #\@)) 42 #:comment-wrapper comment-wrapper 43 #:unsyntax unsyntax?)] 44 [(char port src line col pos) 45 (let ([v (do-comment port 46 (lambda () (read-syntax/recursive src port #\@)) 47 #:comment-wrapper comment-wrapper 48 #:unsyntax unsyntax?)]) 49 (let-values ([(eline ecol epos) (port-next-location port)]) 50 (datum->syntax 51 #f 52 v 53 (list src line col pos (and pos epos (- epos pos))))))]))) 54 55 (define (do-comment port 56 recur 57 #:comment-wrapper [comment-wrapper 'code:comment] 58 #:unsyntax [unsyntax? #t]) 59 (define comment-text 60 `(t 61 ,@(append-strings 62 (let loop () 63 (let ([c (read-char port)]) 64 (cond 65 [(or (eof-object? c) 66 (char=? c #\newline)) 67 null] 68 [(char=? c #\@) 69 (cons (recur) (loop))] 70 [else 71 (cons (string c) 72 (loop))])))))) 73 (define comment-unsyntax 74 (if unsyntax? 75 `(,(unsyntaxer) ,comment-text) 76 comment-text)) 77 `(,comment-wrapper ,comment-text)) 78 79 (define (append-strings l) 80 (let loop ([l l][s null]) 81 (cond 82 [(null? l) (if (null? s) 83 null 84 (preserve-space (apply string-append (reverse s))))] 85 [(string? (car l)) 86 (loop (cdr l) (cons (car l) s))] 87 [else 88 (append (loop null s) 89 (cons 90 (car l) 91 (loop (cdr l) null)))]))) 92 93 (define (preserve-space s) 94 (let ([m (regexp-match-positions #rx" +" s)]) 95 (if m 96 (append (preserve-space (substring s 0 (caar m))) 97 (list `(hspace ,(- (cdar m) (caar m)))) 98 (preserve-space (substring s (cdar m)))) 99 (list s)))))