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)))
(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
#\; 'terminating-macro
(case-lambda
[(char port)
(do-comment port
(lambda () (read/recursive port #\@))
#:comment-wrapper comment-wrapper)]
#: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)])
#:comment-wrapper comment-wrapper
#:unsyntax unsyntax?)])
(let-values ([(eline ecol epos) (port-next-location port)])
(datum->syntax
#f
@ -47,7 +50,8 @@
(define (do-comment port
recur
#:comment-wrapper [comment-wrapper 'code:comment])
#:comment-wrapper [comment-wrapper 'code:comment]
#:unsyntax [unsyntax? #t])
#;(let loop ()
(when (equal? #\; (peek-char port))
(read-char port)
@ -55,20 +59,23 @@
#;(when (equal? #\space (peek-char port))
(read-char port))
(define comment-text
`(,(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))])))))))
`(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)

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

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

16
private/lp.rkt
View File

@ -128,7 +128,7 @@
;; TODO: hash tables
[else e]))
(define-for-syntax ((make-chunk-display racketblock) stx)
(define-for-syntax ((make-chunk-display racketblock unsyntax-id) stx)
(syntax-parse stx
;; no need for more error checking, using chunk for the code will do that
[(_ (original-before-expr ...)
@ -159,7 +159,15 @@
;; and stashed away by read-syntax in "../lang/meta-first-line.rkt"
(define/with-syntax (_ . expr*+comments)
(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))
;; The (list) here could be important, to avoid the code being
;; 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 #f))
(define-syntax chunk-display (make-chunk-display #'racketblock))
(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 #'UNSYNTAX))
(define-syntax chunk (make-chunk #'chunk-code #'chunk-display))
(define-syntax CHUNK (make-chunk #'CHUNK-code #'CHUNK-display))