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