Copied comment-reader.rkt from 531ad440b7/scribble-lib/scribble/comment-reader.rkt

2017-01-04 19:59:40 +01:00 · 2017-01-04 19:59:40 +01:00 · 5145a9cb7e
commit 5145a9cb7e
parent 66551c6901
1 changed files with 83 additions and 0 deletions
--- a/comment-reader.rkt
+++ b/comment-reader.rkt
@ -0,0 +1,83 @@
+(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)])
+    (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)))))