Support for comments with the new comment-reader

This commit is contained in:
Georges Dupéron 2017-01-06 19:02:30 +01:00
parent 5145a9cb7e
commit a51bf4c1a1
6 changed files with 423 additions and 43 deletions

View File

@ -1,3 +1,6 @@
;; Copied and modified from https://github.com/racket/scribble/blob/
;; 31ad440b75b189a2b0838aab011544d44d6b580/
;; scribble-lib/scribble/comment-reader.rkt
(module comment-reader scheme/base
(require (only-in racket/port peeking-input-port))
@ -23,42 +26,50 @@
(begin (read port) (read port))
'unsyntax)))
(define (make-comment-readtable #:readtable [rt (current-readtable)])
(define (make-comment-readtable #:readtable [rt (current-readtable)]
#:comment-wrapper [comment-wrapper 'code:comment])
(make-readtable rt
#\; 'terminating-macro
(case-lambda
[(char port)
(do-comment port (lambda () (read/recursive port #\@)))]
(do-comment port
(lambda () (read/recursive port #\@))
#:comment-wrapper comment-wrapper)]
[(char port src line col pos)
(let ([v (do-comment port (lambda () (read-syntax/recursive src port #\@)))])
(let ([v (do-comment port
(lambda () (read-syntax/recursive src port #\@))
#:comment-wrapper comment-wrapper)])
(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 (do-comment port
recur
#:comment-wrapper [comment-wrapper 'code:comment])
#;(let loop ()
(when (equal? #\; (peek-char port))
(read-char port)
(loop)))
#;(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))])))))))
`(,comment-wrapper ,comment-text))
(define (append-strings l)
(let loop ([l l][s null])

View File

@ -8,7 +8,8 @@
"typed-racket-lib"
"typed-racket-more"
"typed-racket-doc"
"scribble-enhanced"))
"scribble-enhanced"
"sexp-diff"))
(define build-deps '("scribble-lib"
"racket-doc"
"rackunit-doc"
@ -16,6 +17,10 @@
(define scribblings '(("scribblings/hyper-literate.scrbl" ())
("test/test.hl.rkt" () (omit-start))
("test/test2.hl.rkt" () (omit-start))))
(define pkg-desc "Description Here")
(define version "0.1")
(define pkg-desc
(string-append "Hyper-literate programming is to literate programming exactly"
" what hypertext documents are to regular books and texts."
" For now, this is based on scribble/lp2, and only contains"
" some ε-improvements over it"))
(define version "0.2")
(define pkg-authors '(|Georges Dupéron|))

View File

@ -2,7 +2,8 @@
(require racket/port)
(provide read-syntax-whole-first-line)
(provide read-whole-first-line
read-syntax-whole-first-line)
(define (read-line-length port)
(let* ([peeking (peeking-input-port port)]
@ -14,10 +15,16 @@
(define (narrow-to-one-line port)
(make-limited-input-port port (read-line-length port)))
(define (read-syntax-whole-first-line source-name in)
(define (read-*-whole-first-line rec-read in)
(define in1 (narrow-to-one-line in))
(let loop ([res '()])
(define res+ (read-syntax source-name in1))
(define res+ (rec-read in1))
(if (eof-object? res+)
(reverse res)
(loop (cons res+ res)))))
(loop (cons res+ res)))))
(define (read-whole-first-line in)
(read-*-whole-first-line (λ (in1) (read in1)) in))
(define (read-syntax-whole-first-line source-name in)
(read-*-whole-first-line (λ (in1) (read-syntax source-name in1)) in))

View File

@ -4,15 +4,351 @@
racket/port
racket/syntax
syntax/strip-context
"first-line-utils.rkt")
"first-line-utils.rkt"
(only-in "../comment-reader.rkt" make-comment-readtable))
(provide meta-read-inside
meta-read-syntax-inside)
meta-read-syntax-inside
restore-#%comment)
(define (make-at-reader+comments #:syntax? [syntax? #t] #:inside? [inside? #f])
(make-at-reader
#:syntax? syntax?
#:inside? inside?
#:datum-readtable (λ (rt)
(make-comment-readtable
#:readtable rt
#:comment-wrapper '#%comment))))
(define (meta-read-inside in . args)
(apply read-inside args))
(define rd1 (read-whole-first-line in))
(define rd (apply (make-at-reader+comments #:syntax? #f #:inside? #t)
args))
`(,rd1 . ,rd))
(begin
(require (rename-in syntax/parse [...+ …+])
syntax/stx
racket/match
racket/set
racket/list
racket/function
racket/vector
racket/contract
sexp-diff
racket/pretty
rackunit
(only-in racket/base [... ])
(for-syntax (rename-in racket/base [... ])))
(define first-comments/c
(flat-rec-contract R (cons/c (or/c #f (cons/c (syntax/c 'saved-props+srcloc)
R)) #| nested |#
(listof syntax?) #| comments |#)))
(define comments-after/c
(listof syntax?))
(define/contract (with-first-comments e c)
(-> syntax?
(or/c #f first-comments/c)
syntax?)
(if (or (not c) (and (= (length c) 1) (not (first c))))
e
(syntax-property e 'first-comments c)))
(define/contract (with-comments e c)
(-> syntax? (or/c #f comments-after/c) syntax?)
(if (or (not c) (null? c))
e
(syntax-property e 'comments-after c)))
;; ([#%comment c1] a [#%comment c2] . ([#%comment c3] b [#%comment c4]))
;; => (aᶜ² . (bᶜ⁴)⁻ᶜ³)⁻ᶜ¹
;; (c1 a c2 . (c3 . (c4 b c5)))
;; => (aᶜ² . (bᶜ⁵)⁻ᶜ³⁻⁻ᶜ⁴)⁻ᶜ¹
;; (c1 a c2 . (c3 . (c4 c5)))
;; => (aᶜ² . ()⁻ᶜ³⁻⁻ᶜ⁴ᶜ⁵)⁻ᶜ¹
;; (c1 a (c2) b)
;; => (a ()⁻ᶜ² b)⁻ᶜ¹
;; (c1 a (c2 . b) c)
;; => (a b⁻ᶜ² c)⁻ᶜ¹
;; (c1 a (c2 . (c3 c4)) c)
;; => (a ()⁻ᶜ²⁻⁻ᶜ³ᶜ⁴ c)⁻ᶜ¹
(define (hide-#%comment stx)
(match (syntax-e stx)
[(not (? pair?))
;; TODO: recurse down vectors etc.
stx]
[(list* e* ... rest)
(syntax-parse e*
#:datum-literals (#%comment)
[({~and c₀ [#%comment . _]}
{~seq {~and eᵢ {~not [#%comment . _]}}
{~and cᵢⱼ [#%comment . _]} }
…+)
(define new-e* (map with-comments
(map hide-#%comment
(syntax->list #'(eᵢ )))
(map syntax->list
(syntax->list #'((cᵢⱼ ) )))))
(define new-rest (if (null? rest)
rest
(hide-#%comment rest)))
(with-first-comments
(datum->syntax stx (append new-e* new-rest) stx stx)
(cons #f (syntax->list #'(c₀ ))))]
[({~and c₀ [#%comment . _]} )
(define new-rest (if (null? rest)
rest
(hide-#%comment rest)))
(with-first-comments
(with-comments
(datum->syntax stx new-rest stx stx)
(if (syntax? new-rest)
(syntax-property new-rest 'comments-after)
'()))
(cons (if (syntax? new-rest)
(cons (datum->syntax new-rest
'saved-props+srcloc
new-rest
new-rest)
(or (syntax-property new-rest 'first-comments)
;; TODO: I'm dubious about this, better typecheck
;; everything…
(cons #f null)))
#f)
(syntax->list #'(c₀ ))))])]))
(define/contract (extract-first-comments stx)
(-> syntax? (or/c #f first-comments/c))
(syntax-property stx 'first-comments))
(define/contract (extract-comments-after stx)
(-> 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 (erase-props stx)
(define stx* (if (syntax-property stx 'first-comments)
(syntax-property stx 'first-comments #f)
stx))
(if (syntax-property stx* 'comments-after)
(syntax-property stx* 'comments-after #f)
stx*))
(define (recur stx)
(restore-#%comment stx #:replace-with replace-with #:scope scope))
(define (replace-in commentᵢ)
(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ᵢ)]
[_
commentᵢ]))
(define (replace-in-after comments)
(if replace-with
(if (eq? comments #f)
comments
(stx-map replace-in comments))
comments))
(define (replace-in-first first-comments)
(define (replace-in-first1 first-comments)
(if (eq? first-comments #f)
first-comments
(cons (cons (caar first-comments)
(replace-in-first1 (cdar first-comments)))
(stx-map replace-in (cdr first-comments)))))
(if replace-with
(if (eq? first-comments #f)
first-comments
(cons (replace-in-first1 (car first-comments))
(stx-map replace-in (cdr first-comments))))
first-comments))
(match (syntax-e stx)
[(list* e* ... rest)
;; TODO: when extracting the comments properties, check that they have
;; the right shape (listof syntax?) or (*list/c syntax? (list/c R))
;; Or append-map when stx is a stx-list (not in a tail position for the
;; comments-after)
(define new-e*
(append-map (λ (eᵢ)
(cons (recur eᵢ)
(or (replace-in-after (extract-comments-after eᵢ))
'())))
e*))
(define new-rest
(if (syntax? rest)
(recur rest)
;; TODO: handle vectors etc. here?
rest))
(define first-comments
(or (replace-in-first (extract-first-comments stx))
#f))
(define (nest first-comments to-nest)
(cond
[(eq? first-comments #f)
to-nest]
[(eq? (car first-comments) #f)
(append (cdr first-comments) to-nest)]
[else
(nest1 first-comments to-nest)]))
(define (nest1 first-comments to-nest)
(if (eq? first-comments #f)
to-nest
(append (cdr first-comments)
(datum->syntax (caar first-comments)
(nest (cdar first-comments) to-nest)))))
(define new-stx
(nest first-comments (append new-e* new-rest)))
(erase-props (datum->syntax stx new-stx stx stx))]
;; TODO: recurse down vectors etc.
[(? vector? v)
;; TODO: what if there is a first-comment property on the vector itself?
(erase-props
(datum->syntax stx
(vector-map (λ (vᵢ)
(recur vᵢ))
v)
stx
stx))]
[other
'TODO…
other]))
(define (annotate-syntax e #:srcloc+scopes? [srcloc+scopes? #f])
(cond
[(syntax? e)
(append
(list 'syntax
(append-map (λ (kᵢ)
(if (and (or (eq? kᵢ 'first-comments)
(eq? kᵢ 'comments-after))
(not (syntax-property e kᵢ)))
(list)
(list kᵢ (syntax-property e kᵢ))))
(syntax-property-symbol-keys e)))
(if srcloc+scopes?
(list (syntax-source e)
(syntax-line e)
(syntax-column e)
(syntax-position e)
(syntax-span e)
(syntax-source-module e)
(hash-ref (syntax-debug-info e) 'context))
(list))
(list (annotate-syntax (syntax-e e) #:srcloc+scopes? srcloc+scopes?)))]
[(null? e)
'null]
[(list? e)
(list 'list
(map (λ (eᵢ) (annotate-syntax eᵢ #:srcloc+scopes? srcloc+scopes?))
e))]
[(pair? e)
(list 'cons
(annotate-syntax (car e) #:srcloc+scopes? srcloc+scopes?)
(annotate-syntax (cdr e) #:srcloc+scopes? srcloc+scopes?))]
[(vector? e)
(list 'vector
(immutable? e)
(map (λ (eᵢ) (annotate-syntax eᵢ #:srcloc+scopes? srcloc+scopes?))
(vector->list e)))]
[(symbol? e)
e]
[(string? e)
e]
[else
(raise-argument-error
'annotate-syntax
(string-append "a syntax object containing recursively on of the"
" following: pair, null, vector, symbol, string")
0
e)]))
(define (same-syntax! a b)
(define answer (equal? (annotate-syntax a #:srcloc+scopes? #f)
(annotate-syntax b #:srcloc+scopes? #f)))
(unless answer
(pretty-write
(sexp-diff (annotate-syntax a)
(annotate-syntax b)))
(displayln a)
(displayln b))
answer)
(define-syntax (check-same-syntax stx)
(syntax-case stx ()
[(_ a b)
(datum->syntax #'here
`(check-true (same-syntax! ,#'a ,#'b))
stx)]))
(module+ test
(require rackunit)
(let ([stx #'(a b c)])
(check-same-syntax stx (hide-#%comment stx))))
(define round-trip (compose restore-#%comment hide-#%comment))
(module+ test
(define-syntax (check-round-trip stx)
(syntax-case stx ()
[(_ a)
(datum->syntax #'here
`(begin
(check-same-syntax (round-trip ,#'a) ,#'a)
(check-equal? (syntax->datum (round-trip ,#'a))
(syntax->datum ,#'a)))
stx)]))
(check-round-trip #'(a (#%comment "b") c))
(check-round-trip #'((#%comment "0") (#%comment "1")
a
(#%comment "b")
(#%comment "bb")
c
(#%comment "d")
(#%comment "dd")))
(check-round-trip #'([#%comment c1]
a
[#%comment c2]
. ([#%comment c3] b [#%comment c4])))
(check-round-trip #'([#%comment c1]
a
[#%comment c2]
. ([#%comment c3]
. ([#%comment c4] b [#%comment c5]))))
(check-round-trip #'([#%comment c1]
a
[#%comment c2]
. ([#%comment c3]
. ([#%comment c4] [#%comment c5]))))
(check-round-trip #'([#%comment c1]
a
([#%comment c2])
b))
(check-round-trip #'([#%comment c1]
a
([#%comment c2] . b)
c)))
;; TODO: test restore-comments on an expression which has an 'after-comments
)
(define (meta-read-syntax-inside source-name in . args)
(with-syntax* ([rd1 (read-syntax-whole-first-line source-name in)]
[rd (apply read-syntax-inside source-name in args)])
#'(rd1 . rd)))
[rd (apply (make-at-reader+comments #:syntax? #t #:inside? #t)
source-name
in
args)]
[rd-hide (hide-#%comment #'rd)])
#'(rd1 . rd-hide)))

View File

@ -9,7 +9,8 @@
syntax/parse
racket/syntax
racket/struct
syntax/srcloc))
syntax/srcloc
"../restore-comments.rkt"))
(begin-for-syntax
;; maps chunk identifiers to a counter, so we can distinguish multiple uses
@ -130,7 +131,11 @@
(define-for-syntax ((make-chunk-display racketblock) stx)
(syntax-parse stx
;; no need for more error checking, using chunk for the code will do that
[(_ original-name:id name:id stxn:number expr ...)
[(_ (original-before-expr ...)
original-name:id
name:id
stxn:number
expr ...)
(define n (syntax-e #'stxn))
(define original-name:n (syntax-local-introduce
(format-id #'original-name
@ -150,6 +155,12 @@
(and c (> c 2)))
#`((subscript #,(format "~a" n)))
#'()))
;; Restore comments which have been read by the modified comment-reader
;; 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
#:scope #'original-name))
;; The (list) here could be important, to avoid the code being
;; executed multiple times in weird ways, when pre-expanding.
#`(list
@ -167,13 +178,15 @@
`(elem (prefixable
,@(chunks-toc-prefix)
tag))))))
(#,racketblock . #,(strip-source #'(expr ...))
))))]))
(#,racketblock
. #,(strip-source #'expr*+comments)))))]))
(define-for-syntax (make-chunk chunk-code chunk-display)
(syntax-parser
;; no need for more error checking, using chunk for the code will do that
[(_ (~optional (~seq #:save-as save-as:id)) name:id expr ...)
[(_ (~optional (~seq #:save-as save-as:id))
{~and name:id original-before-expr}
expr ...)
(define n (get-chunk-number (syntax-local-introduce #'name)))
(define/with-syntax name:n (format-id #'name "~a:~a" #'name (or n 1)))
@ -228,13 +241,18 @@
(syntax-local-introduce
(quote-syntax #,(strip-source #'(expr ...))))])
#`(stx-chunk-display
(original-before-expr)
local-name
newname
stx-n
local-expr (... ...)))])))
;; The (list) here could be important, to avoid the code being
;; executed multiple times in weird ways, when pre-expanding.
#`(list (stx-chunk-display name name stx-n . #,(strip-source #'(expr ...))))))]))
#`(list (stx-chunk-display (original-before-expr)
name
name
stx-n
. #,(strip-source #'(expr ...))))))]))
(define-syntax chunk-code (make-chunk-code #t))
(define-syntax CHUNK-code (make-chunk-code #f))

3
restore-comments.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang racket
(require "lang/meta-first-line.rkt")
(provide restore-#%comment)