suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Bugfix: use (code:comment (unsyntax …)) in @chunk, and (code:comment (UNSYNTAX …)) in @CHUNK

Browse Source
This commit is contained in:
Georges Dupéron 2017-01-07 00:14:56 +01:00
parent a51bf4c1a1
commit eb586b1ddd
3 changed files with 66 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
comment-reader.rkt
View File

@ -27,18 +27,21 @@
'unsyntax))) 'unsyntax)))
(define (make-comment-readtable #:readtable [rt (current-readtable)] (define (make-comment-readtable #:readtable [rt (current-readtable)]
#:comment-wrapper [comment-wrapper 'code:comment]) #:comment-wrapper [comment-wrapper 'code:comment]
#:unsyntax [unsyntax? #t])
(make-readtable rt (make-readtable rt
#\; 'terminating-macro #\; 'terminating-macro
(case-lambda (case-lambda
[(char port) [(char port)
(do-comment port (do-comment port
(lambda () (read/recursive port #\@)) (lambda () (read/recursive port #\@))
#:comment-wrapper comment-wrapper)] #:comment-wrapper comment-wrapper
#:unsyntax unsyntax?)]
[(char port src line col pos) [(char port src line col pos)
(let ([v (do-comment port (let ([v (do-comment port
(lambda () (read-syntax/recursive src port #\@)) (lambda () (read-syntax/recursive src port #\@))
#:comment-wrapper comment-wrapper)]) #:comment-wrapper comment-wrapper
#:unsyntax unsyntax?)])
(let-values ([(eline ecol epos) (port-next-location port)]) (let-values ([(eline ecol epos) (port-next-location port)])
(datum->syntax (datum->syntax
#f #f
@ -47,7 +50,8 @@
(define (do-comment port (define (do-comment port
recur recur
#:comment-wrapper [comment-wrapper 'code:comment]) #:comment-wrapper [comment-wrapper 'code:comment]
#:unsyntax [unsyntax? #t])
#;(let loop () #;(let loop ()
(when (equal? #\; (peek-char port)) (when (equal? #\; (peek-char port))
(read-char port) (read-char port)
@ -55,20 +59,23 @@
#;(when (equal? #\space (peek-char port)) #;(when (equal? #\space (peek-char port))
(read-char port)) (read-char port))
(define comment-text (define comment-text
`(,(unsyntaxer) `(t
(t ,@(append-strings
,@(append-strings (let loop ()
(let loop () (let ([c (read-char port)])
(let ([c (read-char port)]) (cond
(cond [(or (eof-object? c)
[(or (eof-object? c) (char=? c #\newline))
(char=? c #\newline)) null]
null] [(char=? c #\@)
[(char=? c #\@) (cons (recur) (loop))]
(cons (recur) (loop))] [else
[else (cons (string c)
(cons (string c) (loop))]))))))
(loop))]))))))) (define comment-unsyntax
(if unsyntax?
`(,(unsyntaxer) ,comment-text)
comment-text))
`(,comment-wrapper ,comment-text)) `(,comment-wrapper ,comment-text))
(define (append-strings l) (define (append-strings l)

42
lang/meta-first-line.rkt
View File

@ -18,7 +18,8 @@
#:datum-readtable (λ (rt) #:datum-readtable (λ (rt)
(make-comment-readtable (make-comment-readtable
#:readtable rt #:readtable rt
#:comment-wrapper '#%comment)))) #:comment-wrapper '#%comment
#:unsyntax #f))))
(define (meta-read-inside in . args) (define (meta-read-inside in . args)
@ -128,9 +129,13 @@
(-> syntax? (or/c #f comments-after/c)) (-> syntax? (or/c #f comments-after/c))
(syntax-property stx 'comments-after)) (syntax-property stx 'comments-after))
(define (restore-#%comment stx (define/contract (restore-#%comment stx
#:replace-with (replace-with #f) #:replace-with (replace-with #f)
#:scope [scope (datum->syntax #f 'zero)]) #:scope [scope (datum->syntax #f 'zero)])
(->* (syntax?)
(#:replace-with [or/c #f syntax? (-> syntax? syntax?)]
#:scope identifier?)
syntax?)
(define (erase-props stx) (define (erase-props stx)
(define stx* (if (syntax-property stx 'first-comments) (define stx* (if (syntax-property stx 'first-comments)
(syntax-property stx 'first-comments #f) (syntax-property stx 'first-comments #f)
@ -144,15 +149,26 @@
(syntax-parse commentᵢ (syntax-parse commentᵢ
#:datum-literals (#%comment) #:datum-literals (#%comment)
[({~and c #%comment} . rest) [({~and c #%comment} . rest)
(datum->syntax commentᵢ (if (syntax? replace-with)
`(,(datum->syntax #'c replace-with #'c #'c) (datum->syntax commentᵢ
. ,((make-syntax-delta-introducer `(,(datum->syntax #'c replace-with #'c #'c)
scope . ,((make-syntax-delta-introducer
(datum->syntax #f 'zero)) scope
#'rest (datum->syntax #f 'zero))
'add)) #'rest
commentᵢ 'add))
commentᵢ)] commentᵢ
commentᵢ)
(replace-with
(datum->syntax commentᵢ
`(,#'c
. ,((make-syntax-delta-introducer
scope
(datum->syntax #f 'zero))
#'rest
'add))
commentᵢ
commentᵢ)))]
[_ [_
commentᵢ])) commentᵢ]))
(define (replace-in-after comments) (define (replace-in-after comments)

16
private/lp.rkt
View File

@ -128,7 +128,7 @@
;; TODO: hash tables ;; TODO: hash tables
[else e])) [else e]))
(define-for-syntax ((make-chunk-display racketblock) stx) (define-for-syntax ((make-chunk-display racketblock unsyntax-id) stx)
(syntax-parse stx (syntax-parse stx
;; no need for more error checking, using chunk for the code will do that ;; no need for more error checking, using chunk for the code will do that
[(_ (original-before-expr ...) [(_ (original-before-expr ...)
@ -159,7 +159,15 @@
;; and stashed away by read-syntax in "../lang/meta-first-line.rkt" ;; and stashed away by read-syntax in "../lang/meta-first-line.rkt"
(define/with-syntax (_ . expr*+comments) (define/with-syntax (_ . expr*+comments)
(restore-#%comment #'(original-before-expr ... expr ...) (restore-#%comment #'(original-before-expr ... expr ...)
#:replace-with #'code:comment #:replace-with
(λ (stx)
(syntax-parse stx
#:datum-literals (#%comment)
[({~and #%comment com} . rest)
#:with c-c (datum->syntax #'com 'code:comment #'com #'com)
(datum->syntax stx `(,#'c-c (,unsyntax-id . ,#'rest)) stx stx)]
[other
#'other]))
#:scope #'original-name)) #:scope #'original-name))
;; The (list) here could be important, to avoid the code being ;; The (list) here could be important, to avoid the code being
;; executed multiple times in weird ways, when pre-expanding. ;; executed multiple times in weird ways, when pre-expanding.
@ -256,8 +264,8 @@
(define-syntax chunk-code (make-chunk-code #t)) (define-syntax chunk-code (make-chunk-code #t))
(define-syntax CHUNK-code (make-chunk-code #f)) (define-syntax CHUNK-code (make-chunk-code #f))
(define-syntax chunk-display (make-chunk-display #'racketblock)) (define-syntax chunk-display (make-chunk-display #'racketblock #'unsyntax))
(define-syntax CHUNK-display (make-chunk-display #'RACKETBLOCK)) (define-syntax CHUNK-display (make-chunk-display #'RACKETBLOCK #'UNSYNTAX))
(define-syntax chunk (make-chunk #'chunk-code #'chunk-display)) (define-syntax chunk (make-chunk #'chunk-code #'chunk-display))
(define-syntax CHUNK (make-chunk #'CHUNK-code #'CHUNK-display)) (define-syntax CHUNK (make-chunk #'CHUNK-code #'CHUNK-display))