fold.rkt (2871B)
1 #lang racket 2 3 (provide fold-syntax 4 replace-top-loc 5 syntax/top-loc 6 quasisyntax/top-loc 7 syntax/whole-loc 8 quasisyntax/whole-loc) 9 10 (define (fold-syntax f stx) 11 (let process ([stx stx]) 12 (cond 13 [(syntax? stx) 14 (f stx (λ (x) 15 (let ([p (process (syntax-e x))]) 16 (if (syntax? p) 17 p 18 (datum->syntax stx p stx stx)))))] 19 [(pair? stx) 20 (cons (process (car stx)) 21 (process (cdr stx)))] 22 [(null? stx) 23 stx] 24 [(vector? stx) 25 (list->vector (map process (vector->list stx)))] 26 [(box? stx) 27 (box (process (unbox stx)))] 28 [(hash? stx) 29 (define processed (process (hash->list stx))) 30 (cond 31 [(hash-equal? stx) (make-hash processed)] 32 [(hash-eqv? stx) (make-hasheqv processed)] 33 [(hash-eq? stx) (make-hasheq processed)])] 34 [(prefab-struct-key stx) 35 (apply make-prefab-struct 36 (prefab-struct-key stx) 37 (map process (vector->list (struct->vector stx))))] 38 [else 39 stx]))) 40 41 ;; Replaces the syntax/loc for the top of the syntax object, until 42 ;; a part which doesn't belong to old-source is reached. 43 ;; e.g. (with-syntax ([d user-provided-syntax]) 44 ;; (replace-top-loc 45 ;; #'(a b (c d e)) 46 ;; (syntax-source #'here) 47 ;; new-loc)) 48 ;; will produce a syntax object #'(a b (c (x (y) z) e)) 49 ;; where a, b, c, z, e and their surrounding forms have their srcloc set to 50 ;; new-loc, but (x (y) z) will be left intact, if the user-provided-syntax 51 ;; appears in another file. 52 53 (define (replace-top-loc stx old-source new-loc) 54 (fold-syntax 55 (λ (stx rec) 56 (if (equal? (syntax-source stx) old-source) 57 (datum->syntax stx (syntax-e (rec stx)) new-loc stx) 58 stx)) 59 stx)) 60 61 ;; Use the following function to replace the loc throughout stx 62 ;; instead of stopping the depth-first-search when the syntax-source 63 ;; is not old-source anymore 64 (define (replace-whole-loc stx old-source new-loc) 65 (fold-syntax 66 (λ (stx rec) 67 (if (equal? (syntax-source stx) old-source) 68 (datum->syntax stx (syntax-e (rec stx)) new-loc stx) 69 (rec stx))) 70 stx)) 71 72 (define-syntax (syntax/top-loc stx) 73 (syntax-case stx () 74 [(self loc template) 75 #'(replace-top-loc #'template (syntax-source #'self) loc)])) 76 77 (define-syntax (quasisyntax/top-loc stx) 78 (syntax-case stx () 79 [(self loc template) 80 #'(replace-top-loc #`template (syntax-source #'self) loc)])) 81 82 (define-syntax (syntax/whole-loc stx) 83 (syntax-case stx () 84 [(self loc template) 85 #'(replace-whole-loc #'template (syntax-source #'self) loc)])) 86 87 (define-syntax (quasisyntax/whole-loc stx) 88 (syntax-case stx () 89 [(self loc template) 90 #'(replace-whole-loc #`template (syntax-source #'self) loc)]))