fold-typed+prefab.rkt.does-not-work (2250B)
1 #lang typed/racket 2 3 (require "prefab.rkt") 4 (define-type SrcLoc (U False 5 (Syntaxof Any) 6 (List Any 7 (U Integer False) 8 (U Integer False) 9 (U Integer False) 10 (U Integer False)) 11 (Vector Any 12 (U Integer False) 13 (U Integer False) 14 (U Integer False) 15 (U Integer False)))) 16 17 ;; Replaces the syntax/loc for the top of the syntax object, until 18 ;; a part which doesn't belong to old-source is reached. 19 ;; e.g. (with-syntax ([d user-provided-syntax]) 20 ;; (replace-top-loc 21 ;; #'(a b (c d e)) 22 ;; (syntax-source #'here) 23 ;; new-loc)) 24 ;; will produce a syntax object #'(a b (c (x (y) z) e)) 25 ;; where a, b, c, z, e and their surrounding forms have their srcloc set to 26 ;; new-loc, but (x (y) z) will be left intact, if the user-provided-syntax 27 ;; appears in another file. 28 (: replace-top-loc (→ Syntax Any SrcLoc Syntax)) 29 (define (replace-top-loc stx old-source new-loc) 30 (define (process-e [stx : (U Syntax-E PrefabTop)]) : (U Syntax-E PrefabTop) 31 (cond 32 ;[(syntax? stx) 33 [(prefab-struct? stx) 34 (apply make-prefab-struct 35 (prefab-struct-key stx) 36 (map process (vector->list (struct->vector stx))))] 37 [(and (pair? stx) (syntax? (cdr stx))) 38 (cons (process (car stx)) 39 (process (cdr stx)))] 40 [(and (pair? stx) (not (syntax? (cdr stx)))) 41 (map process stx)] 42 [(vector? stx) 43 (list->vector (map process (vector->list stx)))] 44 [(box? stx) 45 (box (process (unbox stx)))] 46 [else 47 stx])) 48 (define (process [stx : Syntax]) : Syntax 49 (if (equal? (syntax-source stx) old-source) 50 (datum->syntax stx (process-e (syntax-e stx)) new-loc stx) 51 stx 52 ;; Use the following expression to replace the loc throughout stx 53 ;; instead of stopping the depth-first-search when the syntax-source 54 ;; is not old-source anymore 55 #;(datum->syntax stx (process (syntax-e stx)) stx stx))) 56 57 (process stx))