Cleaned up hiding/restoring comments, partially typed
This commit is contained in:
Georges Dupéron
parent
eb586b1ddd
commit
10a5663ddf
|
|
@ -52,12 +52,6 @@
|
|||
recur
|
||||
#:comment-wrapper [comment-wrapper 'code:comment]
|
||||
#:unsyntax [unsyntax? #t])
|
||||
#;(let loop ()
|
||||
(when (equal? #\; (peek-char port))
|
||||
(read-char port)
|
||||
(loop)))
|
||||
#;(when (equal? #\space (peek-char port))
|
||||
(read-char port))
|
||||
(define comment-text
|
||||
`(t
|
||||
,@(append-strings
|
||||
|
|
|
|||
75
comments/hide-comments.rkt
Normal file
75
comments/hide-comments.rkt
Normal file
|
|
@ -0,0 +1,75 @@
|
|||
#lang racket
|
||||
|
||||
(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 [... …]))
|
||||
"syntax-properties.rkt")
|
||||
|
||||
(provide hide-#%comment)
|
||||
|
||||
;; ([#%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-after
|
||||
(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-after
|
||||
(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₀ …))))])]))
|
||||
130
comments/restore-comments.rkt
Normal file
130
comments/restore-comments.rkt
Normal file
|
|
@ -0,0 +1,130 @@
|
|||
#lang racket
|
||||
|
||||
(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 [... …]))
|
||||
"syntax-properties.rkt")
|
||||
|
||||
(provide restore-#%comment)
|
||||
|
||||
(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)
|
||||
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)
|
||||
(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)
|
||||
(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]))
|
||||
47
comments/syntax-properties-typed.rkt
Normal file
47
comments/syntax-properties-typed.rkt
Normal file
|
|
@ -0,0 +1,47 @@
|
|||
#lang typed/racket
|
||||
|
||||
(provide First-Comments
|
||||
Comments-After
|
||||
with-first-comments
|
||||
with-comments-after
|
||||
extract-first-comments
|
||||
extract-comments-after)
|
||||
|
||||
(define-type First-Comments
|
||||
(Rec R (Pairof (U #f (Pairof (Syntaxof 'saved-props+srcloc)
|
||||
R))
|
||||
(Listof (Syntaxof Any)))))
|
||||
|
||||
(define-type Comments-After
|
||||
(Listof (Syntaxof Any)))
|
||||
|
||||
(: with-first-comments (∀ (A) (→ (Syntaxof A)
|
||||
(U #f First-Comments)
|
||||
(Syntaxof A))))
|
||||
(define (with-first-comments e c)
|
||||
|
||||
(if (or (not c) (and (= (length c) 1) (not (first c))))
|
||||
e
|
||||
(syntax-property e 'first-comments c)))
|
||||
|
||||
(: with-comments-after (∀ (A) (→ (Syntaxof A)
|
||||
(U #f Comments-After)
|
||||
(Syntaxof A))))
|
||||
(define (with-comments-after e c)
|
||||
(if (or (not c) (null? c))
|
||||
e
|
||||
(syntax-property e 'comments-after c)))
|
||||
|
||||
(: extract-first-comments (-> (Syntaxof Any) (U #f First-Comments)))
|
||||
(define (extract-first-comments stx)
|
||||
(define c (syntax-property stx 'first-comments))
|
||||
(if ((make-predicate First-Comments) c)
|
||||
c
|
||||
#f))
|
||||
|
||||
(: extract-comments-after (-> (Syntaxof Any) (U #f Comments-After)))
|
||||
(define (extract-comments-after stx)
|
||||
(define c (syntax-property stx 'comments-after))
|
||||
(if ((make-predicate Comments-After) c)
|
||||
c
|
||||
#f))
|
||||
37
comments/syntax-properties.rkt
Normal file
37
comments/syntax-properties.rkt
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
#lang racket
|
||||
|
||||
(provide first-comments/c
|
||||
comments-after/c
|
||||
with-first-comments
|
||||
with-comments-after
|
||||
extract-first-comments
|
||||
extract-comments-after)
|
||||
|
||||
(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-after e c)
|
||||
(-> syntax? (or/c #f comments-after/c) syntax?)
|
||||
(if (or (not c) (null? c))
|
||||
e
|
||||
(syntax-property e 'comments-after 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))
|
||||
216
comments/typed-syntax-convert.rkt
Normal file
216
comments/typed-syntax-convert.rkt
Normal file
|
|
@ -0,0 +1,216 @@
|
|||
#lang typed/racket
|
||||
|
||||
(require typed-map
|
||||
typed/racket/unsafe)
|
||||
|
||||
(provide try-any->isexp*
|
||||
try-any->isexp
|
||||
any->isexp+non-sexp
|
||||
NonSexpOf)
|
||||
|
||||
(unsafe-require/typed racket/function
|
||||
[[identity unsafe-cast-function] (∀ (A) (→ Any A))])
|
||||
(unsafe-require/typed racket/base
|
||||
[[datum->syntax datum->syntax*]
|
||||
(∀ (A) (→ (Syntaxof Any)
|
||||
A
|
||||
(Syntaxof Any)
|
||||
(Syntaxof Any)
|
||||
(Syntaxof A)))])
|
||||
|
||||
(define-syntax-rule (unsafe-cast v t)
|
||||
((inst unsafe-cast-function t) v))
|
||||
|
||||
(define-type (non-sexp-handler A)
|
||||
(→ Any
|
||||
(Values (U (Sexpof A) #f)
|
||||
(U 'unmodified 'modified #f))))
|
||||
|
||||
(: try-listof-any->isexp* (∀ (A) (→ (Listof Any)
|
||||
(non-sexp-handler A)
|
||||
(U (Pairof (Listof (Sexpof A))
|
||||
(U 'unmodified 'modified))
|
||||
(Pairof #f #f)))))
|
||||
|
||||
(define (try-listof-any->isexp* e non-sexp)
|
||||
(define e+status*
|
||||
(map (λ ([eᵢ : Any])
|
||||
(let-values ([(eᵢ* status) (try-any->isexp* eᵢ non-sexp)])
|
||||
(cons eᵢ* status)))
|
||||
e))
|
||||
(define e* (map car e+status*))
|
||||
(define status* (map cdr e+status*))
|
||||
(cond
|
||||
[(andmap (curry eq? 'unmodified) status*)
|
||||
(cons (unsafe-cast e (Listof (Sexpof A))) 'unmodified)]
|
||||
[(ormap (curry eq? #f) status*)
|
||||
(cons #f #f)]
|
||||
[else
|
||||
(cons e* 'modified)]))
|
||||
|
||||
(: try-any->isexp* (∀ (A) (→ Any
|
||||
(non-sexp-handler A)
|
||||
(Values (U (Sexpof A) #f)
|
||||
(U 'unmodified 'modified #f)))))
|
||||
(define (try-any->isexp* e non-sexp)
|
||||
(cond
|
||||
[(boolean? e) (values e 'unmodified)]
|
||||
[(char? e) (values e 'unmodified)]
|
||||
[(number? e) (values e 'unmodified)]
|
||||
[(keyword? e) (values e 'unmodified)]
|
||||
[(null? e) (values e 'unmodified)]
|
||||
[(string? e) (if (immutable? e)
|
||||
(values e 'unmodified)
|
||||
(values (string->immutable-string e) 'modified))]
|
||||
[(symbol? e) (values e 'unmodified)]
|
||||
[(box? e) (let*-values ([(u) (unbox e)]
|
||||
[(u* status) (try-any->isexp* e non-sexp)])
|
||||
(case status
|
||||
[(unmodified)
|
||||
(if (immutable? e)
|
||||
(values (unsafe-cast e (Sexpof A)) 'unmodified)
|
||||
(values (box-immutable u*) 'modified))]
|
||||
[(modified)
|
||||
(values (box-immutable u*) 'modified)]
|
||||
[(#f)
|
||||
(values #f #f)]))]
|
||||
[(pair? e) (let*-values ([(car* status-car)
|
||||
(try-any->isexp* (car e) non-sexp)]
|
||||
[(cdr* status-cdr)
|
||||
(try-any->isexp* (cdr e) non-sexp)])
|
||||
(cond
|
||||
[(and (eq? status-car 'unmodified)
|
||||
(eq? status-cdr 'unmodified))
|
||||
(values (unsafe-cast e (Sexpof A)) 'unmodified)]
|
||||
[(or (eq? status-car #f)
|
||||
(eq? status-cdr #f))
|
||||
(values #f #f)]
|
||||
[else
|
||||
(values (cons car* cdr*) 'modified)]))]
|
||||
[(vector? e) (match-let ([(cons vs* status)
|
||||
(try-listof-any->isexp* (vector->list e) non-sexp)])
|
||||
(case status
|
||||
[(unmodified)
|
||||
(if (immutable? e)
|
||||
(values (unsafe-cast e (Sexpof A)) 'unmodified)
|
||||
(values (apply vector-immutable vs*) 'modified))]
|
||||
[(modified)
|
||||
(values (apply vector-immutable vs*) 'modified)]
|
||||
[(#f)
|
||||
(values #f #f)]))]
|
||||
[else
|
||||
(non-sexp e)]))
|
||||
|
||||
|
||||
;; Sexp:
|
||||
|
||||
(struct (A) NonSexp ([value : A]) #:type-name NonSexpOf)
|
||||
|
||||
(: any->isexp+non-sexp (→ Any (Sexpof (NonSexpOf Any))))
|
||||
(define (any->isexp+non-sexp e)
|
||||
(let*-values ([(e* status) (try-any->isexp*
|
||||
e
|
||||
(λ (non-sexp-e)
|
||||
(values (NonSexp non-sexp-e)
|
||||
'modified)))])
|
||||
(case status
|
||||
[(unmodified) (unsafe-cast e (Sexpof (NonSexpOf Any)))]
|
||||
[(modified) e*]
|
||||
[(#f)
|
||||
(error
|
||||
(string-append "Got #f from try->any-isexp* using non-sexp which does"
|
||||
" not return #f."))])))
|
||||
|
||||
|
||||
(: try-any->isexp (→ Any (U (List Any) #f)))
|
||||
(define (try-any->isexp e)
|
||||
(let*-values ([(e* status) (try-any->isexp*
|
||||
e
|
||||
(λ (non-sexp-e)
|
||||
(values #f #f)))])
|
||||
(case status
|
||||
[(unmodified) (list e)]
|
||||
[(modified) (list e*)]
|
||||
[(#f) #f])))
|
||||
|
||||
;; Syntax:
|
||||
|
||||
(struct (A) NonSyntax ([value : A]) #:type-name NonSyntaxOf)
|
||||
(define-type (SyntaxU A)
|
||||
(Syntaxof (SexpStx A)))
|
||||
(define-type (SexpStx A)
|
||||
(Rec sexp (U Boolean
|
||||
Char
|
||||
Complex
|
||||
Keyword
|
||||
Null
|
||||
String
|
||||
Symbol
|
||||
(Boxof sexp)
|
||||
(Pairof sexp sexp)
|
||||
(Vectorof sexp)
|
||||
(Syntaxof sexp)
|
||||
A)))
|
||||
|
||||
(: syntax-wrapper (∀ (A) (→ (non-sexp-handler (U A (SyntaxU A)))
|
||||
(non-sexp-handler (U A (SyntaxU A))))))
|
||||
(define (syntax-wrapper nested-wrapper)
|
||||
(: recur (→ Any
|
||||
(Values (U (Sexpof (U A (SyntaxU A))) #f)
|
||||
(U 'unmodified 'modified #f))))
|
||||
(define (recur e)
|
||||
(cond
|
||||
[(syntax? e)
|
||||
(let-values ([(e* status) (try-any->isexp* (syntax-e e) recur)])
|
||||
(case status
|
||||
[(unmodified) (values (ann (unsafe-cast e (U (SyntaxU A) #f))
|
||||
(U (SyntaxU A) #f))'unmodified)]
|
||||
[(modified) (values (datum->syntax* e e* e e) 'modified)]
|
||||
[(#f) (values #f #f)]))]
|
||||
[else (nested-wrapper e)]))
|
||||
recur)
|
||||
|
||||
(: any->isexpstx+non-syntax (→ Any (Sexpof (U (NonSyntaxOf Any) (SyntaxU (NonSyntaxOf Any))))))
|
||||
(define (any->isexpstx+non-syntax e)
|
||||
(let*-values ([(e* status)
|
||||
((inst try-any->isexp* (U (NonSyntaxOf Any) (SyntaxU (NonSyntaxOf Any))))
|
||||
e
|
||||
(syntax-wrapper
|
||||
(λ (non-syntax-e)
|
||||
(values (NonSyntax non-syntax-e)
|
||||
'modified))))])
|
||||
(case status
|
||||
[(unmodified) (unsafe-cast e (SyntaxU (NonSyntaxOf Any)))]
|
||||
[(modified) e*]
|
||||
[(#f)
|
||||
(error
|
||||
(string-append "Got #f from try->any-isexp* using non-sexp which does"
|
||||
" not return #f."))])))
|
||||
|
||||
;; TODO: this duplicates parts of any->isexpstx+non-syntax and syntax-wrapper.
|
||||
(: syntax->isyntax+non-syntax (→ Syntax (SyntaxU (NonSyntaxOf Any))))
|
||||
(define (syntax->isyntax+non-syntax e)
|
||||
(let-values ([(e* status) (try-any->isexp* (syntax-e e)
|
||||
(syntax-wrapper
|
||||
(λ (non-syntax-e)
|
||||
(values (NonSyntax non-syntax-e)
|
||||
'modified))))])
|
||||
(case status
|
||||
[(unmodified) (unsafe-cast e (SyntaxU (NonSyntaxOf Any)))]
|
||||
[(modified) (datum->syntax* e e* e e)]
|
||||
[(#f)
|
||||
(error (string-append "Got #f from try->any-isexp* using non-sexp which"
|
||||
" does not return #f."))])))
|
||||
|
||||
|
||||
;(: try-any->isyntax (→ Any (U (List Any) #f)))
|
||||
#;(define (try-any->isyntax e)
|
||||
(let*-values ([(e* status) (try-any->isexp*
|
||||
e
|
||||
(λ (non-sexp-e)
|
||||
(values #f #f)))])
|
||||
(case status
|
||||
[(unmodified) (list e)]
|
||||
[(modified) (list e*)]
|
||||
[(#f) #f])))
|
||||
|
||||
52
comments/typed-syntax-predicate.rkt
Normal file
52
comments/typed-syntax-predicate.rkt
Normal file
|
|
@ -0,0 +1,52 @@
|
|||
#lang typed/racket
|
||||
|
||||
(provide isexp?
|
||||
CoreSexp)
|
||||
|
||||
(module unsafe racket
|
||||
(provide isexp?)
|
||||
|
||||
(define isexp/c
|
||||
(flat-rec-contract isexp
|
||||
(or/c boolean?
|
||||
char?
|
||||
number?
|
||||
keyword?
|
||||
null?
|
||||
(and/c string? immutable?)
|
||||
symbol?
|
||||
(box/c isexp #:immutable #t)
|
||||
(cons/c isexp isexp)
|
||||
(vectorof isexp #:immutable #t))))
|
||||
|
||||
(define sexp/c
|
||||
(recursive-contract
|
||||
(or/c boolean?
|
||||
char?
|
||||
number?
|
||||
keyword?
|
||||
null?
|
||||
string?
|
||||
symbol?
|
||||
(box/c sexp/c)
|
||||
(cons/c sexp/c sexp/c)
|
||||
(vectorof sexp/c))))
|
||||
|
||||
(define isexp?
|
||||
(flat-contract-predicate isexp/c)))
|
||||
|
||||
(define-type CoreSexp (Rec core-sexp
|
||||
(U Boolean
|
||||
Char
|
||||
Number
|
||||
Keyword
|
||||
Null
|
||||
String
|
||||
Symbol
|
||||
#|(Boxof sexp)|#
|
||||
(Pairof core-sexp core-sexp)
|
||||
#|(Vectorof sexp)|#)))
|
||||
|
||||
(require typed/racket/unsafe)
|
||||
(unsafe-require/typed 'unsafe
|
||||
[isexp? (→ Any Boolean : #:+ Sexp #:- (! CoreSexp))])
|
||||
10
comments/typed-syntax.rkt
Normal file
10
comments/typed-syntax.rkt
Normal file
|
|
@ -0,0 +1,10 @@
|
|||
#lang typed/racket
|
||||
|
||||
(provide isexp?
|
||||
try-any->isexp
|
||||
any->isexp+non-sexp
|
||||
CoreSexp)
|
||||
|
||||
(require "typed-syntax-convert.rkt"
|
||||
"typed-syntax-predicate.rkt")
|
||||
|
||||
|
|
@ -5,11 +5,11 @@
|
|||
racket/syntax
|
||||
syntax/strip-context
|
||||
"first-line-utils.rkt"
|
||||
(only-in "../comment-reader.rkt" make-comment-readtable))
|
||||
(only-in "../comment-reader.rkt" make-comment-readtable)
|
||||
"../comments/hide-comments.rkt")
|
||||
|
||||
(provide meta-read-inside
|
||||
meta-read-syntax-inside
|
||||
restore-#%comment)
|
||||
meta-read-syntax-inside)
|
||||
|
||||
(define (make-at-reader+comments #:syntax? [syntax? #t] #:inside? [inside? #f])
|
||||
(make-at-reader
|
||||
|
|
@ -28,7 +28,7 @@
|
|||
args))
|
||||
`(,rd1 . ,rd))
|
||||
|
||||
(begin
|
||||
#;(begin
|
||||
(require (rename-in syntax/parse [...+ …+])
|
||||
syntax/stx
|
||||
racket/match
|
||||
|
|
@ -357,7 +357,6 @@
|
|||
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)
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
#lang racket
|
||||
(require "lang/meta-first-line.rkt")
|
||||
(require "comments/restore-comments.rkt")
|
||||
(provide restore-#%comment)
|
||||
65
test/comments/annotate-syntax-typed.rkt
Normal file
65
test/comments/annotate-syntax-typed.rkt
Normal file
|
|
@ -0,0 +1,65 @@
|
|||
#lang typed/racket
|
||||
|
||||
(require typed-map
|
||||
"../../comments/typed-syntax.rkt")
|
||||
|
||||
(provide annotate-syntax)
|
||||
|
||||
(: annotate-syntax (->* (Syntax)
|
||||
(#:srcloc+scopes? Boolean)
|
||||
Sexp))
|
||||
(define (annotate-syntax e #:srcloc+scopes? [srcloc+scopes? #f])
|
||||
(annotate-syntax1 e srcloc+scopes?))
|
||||
|
||||
(: annotate-syntax1 (→ (U Syntax Syntax-E)
|
||||
Boolean
|
||||
Sexp))
|
||||
(define (annotate-syntax1 e srcloc+scopes?)
|
||||
(cond
|
||||
[(syntax? e)
|
||||
(append
|
||||
(list 'syntax
|
||||
(append-map (λ ([kᵢ : Symbol])
|
||||
(if (and (or (eq? kᵢ 'first-comments)
|
||||
(eq? kᵢ 'comments-after))
|
||||
(not (syntax-property e kᵢ)))
|
||||
(list)
|
||||
(list kᵢ (any->isexp (syntax-property e kᵢ)))))
|
||||
(syntax-property-symbol-keys e)))
|
||||
(if srcloc+scopes?
|
||||
(list (any->isexp (syntax-source e))
|
||||
(any->isexp (syntax-line e))
|
||||
(any->isexp (syntax-column e))
|
||||
(any->isexp (syntax-position e))
|
||||
(any->isexp (syntax-span e))
|
||||
(any->isexp (syntax-source-module e))
|
||||
(any->isexp (hash-ref (syntax-debug-info e)
|
||||
'context)))
|
||||
(list))
|
||||
(list (annotate-syntax1 (syntax-e e) srcloc+scopes?)))]
|
||||
[(null? e)
|
||||
'null]
|
||||
[(list? e)
|
||||
(list 'list
|
||||
(map (λ (eᵢ) (annotate-syntax1 eᵢ srcloc+scopes?))
|
||||
e))]
|
||||
[(pair? e)
|
||||
(list 'cons
|
||||
(annotate-syntax1 (car e) srcloc+scopes?)
|
||||
(annotate-syntax1 (cdr e) srcloc+scopes?))]
|
||||
[(vector? e)
|
||||
(list 'vector
|
||||
(immutable? e)
|
||||
(map (λ (eᵢ) (annotate-syntax1 eᵢ 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)]))
|
||||
52
test/comments/annotate-syntax.rkt
Normal file
52
test/comments/annotate-syntax.rkt
Normal file
|
|
@ -0,0 +1,52 @@
|
|||
#lang racket
|
||||
|
||||
(provide annotate-syntax)
|
||||
|
||||
(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)]))
|
||||
25
test/comments/same-syntax.rkt
Normal file
25
test/comments/same-syntax.rkt
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
#lang racket
|
||||
|
||||
(require "annotate-syntax.rkt"
|
||||
sexp-diff
|
||||
rackunit)
|
||||
|
||||
(provide check-same-syntax)
|
||||
|
||||
(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)]))
|
||||
55
test/comments/test-comments-round-trip.rkt
Normal file
55
test/comments/test-comments-round-trip.rkt
Normal file
|
|
@ -0,0 +1,55 @@
|
|||
#lang racket
|
||||
|
||||
(require rackunit
|
||||
"../../comments/hide-comments.rkt"
|
||||
"../../comments/restore-comments.rkt"
|
||||
"same-syntax.rkt")
|
||||
|
||||
(define round-trip (compose restore-#%comment hide-#%comment))
|
||||
|
||||
(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)]))
|
||||
|
||||
;; =============================================================================
|
||||
|
||||
(let ([stx #'(a b c)])
|
||||
(check-same-syntax stx (hide-#%comment 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))
|
||||
Loading…
Reference in New Issue
Block a user