restore-comments-typed.rkt (4973B)
1 #lang racket 2 3 (require (rename-in syntax/parse [...+ …+]) 4 syntax/stx 5 racket/match 6 racket/set 7 racket/list 8 racket/function 9 racket/vector 10 racket/contract 11 sexp-diff 12 racket/pretty 13 rackunit 14 (only-in racket/base [... …]) 15 (for-syntax (rename-in racket/base [... …])) 16 "syntax-properties.rkt") 17 18 (provide restore-#%comment) 19 20 (define/contract (restore-#%comment stx 21 #:replace-with (replace-with #f) 22 #:scope [scope (datum->syntax #f 'zero)]) 23 (->* (syntax?) 24 (#:replace-with [or/c #f syntax? (-> syntax? syntax?)] 25 #:scope identifier?) 26 syntax?) 27 (define (erase-props stx) 28 (define stx* (if (syntax-property stx 'first-comments) 29 (syntax-property stx 'first-comments #f) 30 stx)) 31 (if (syntax-property stx* 'comments-after) 32 (syntax-property stx* 'comments-after #f) 33 stx*)) 34 (define (recur stx) 35 (restore-#%comment stx #:replace-with replace-with #:scope scope)) 36 (define (replace-in commentᵢ) 37 (syntax-parse commentᵢ 38 #:datum-literals (#%comment) 39 [({~and c #%comment} . rest) 40 (if (syntax? replace-with) 41 (datum->syntax commentᵢ 42 `(,(datum->syntax #'c replace-with #'c #'c) 43 . ,((make-syntax-delta-introducer 44 scope 45 (datum->syntax #f 'zero)) 46 #'rest 47 'add)) 48 commentᵢ 49 commentᵢ) 50 (replace-with 51 (datum->syntax commentᵢ 52 `(,#'c 53 . ,((make-syntax-delta-introducer 54 scope 55 (datum->syntax #f 'zero)) 56 #'rest 57 'add)) 58 commentᵢ 59 commentᵢ)))] 60 [_ 61 commentᵢ])) 62 (define (replace-in-after comments) 63 (if replace-with 64 (if (eq? comments #f) 65 comments 66 (stx-map replace-in comments)) 67 comments)) 68 (define (replace-in-first first-comments) 69 (define (replace-in-first1 first-comments) 70 (if (eq? first-comments #f) 71 first-comments 72 (cons (cons (caar first-comments) 73 (replace-in-first1 (cdar first-comments))) 74 (stx-map replace-in (cdr first-comments))))) 75 (if replace-with 76 (if (eq? first-comments #f) 77 first-comments 78 (cons (replace-in-first1 (car first-comments)) 79 (stx-map replace-in (cdr first-comments)))) 80 first-comments)) 81 (match (syntax-e stx) 82 [(list* e* ... rest) 83 ;; TODO: when extracting the comments properties, check that they have 84 ;; the right shape (listof syntax?) or (*list/c syntax? (list/c R)) 85 ;; Or append-map when stx is a stx-list (not in a tail position for the 86 ;; comments-after) 87 (define new-e* 88 (append-map (λ (eᵢ) 89 (cons (recur eᵢ) 90 (or (replace-in-after (extract-comments-after eᵢ)) 91 '()))) 92 e*)) 93 (define new-rest 94 (if (syntax? rest) 95 (recur rest) 96 ;; TODO: handle vectors etc. here? 97 rest)) 98 (define first-comments 99 (or (replace-in-first (extract-first-comments stx)) 100 #f)) 101 (define (nest first-comments to-nest) 102 (cond 103 [(eq? first-comments #f) 104 to-nest] 105 [(eq? (car first-comments) #f) 106 (append (cdr first-comments) to-nest)] 107 [else 108 (nest1 first-comments to-nest)])) 109 (define (nest1 first-comments to-nest) 110 (if (eq? first-comments #f) 111 to-nest 112 (append (cdr first-comments) 113 (datum->syntax (caar first-comments) 114 (nest (cdar first-comments) to-nest))))) 115 (define new-stx 116 (nest first-comments (append new-e* new-rest))) 117 (erase-props (datum->syntax stx new-stx stx stx))] 118 ;; TODO: recurse down vectors etc. 119 [(? vector? v) 120 ;; TODO: what if there is a first-comment property on the vector itself? 121 (erase-props 122 (datum->syntax stx 123 (vector-map (λ (vᵢ) 124 (recur vᵢ)) 125 v) 126 stx 127 stx))] 128 [other 129 'TODO… 130 other]))