130 lines
4.9 KiB
Racket
130 lines
4.9 KiB
Racket
#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])) |