copy-attribute.rkt (4069B)
1 #lang racket 2 3 (provide copy-raw-syntax-attribute 4 attribute-val/c) 5 6 (require version-case 7 stxparse-info/current-pvars 8 phc-toolkit/untyped 9 stxparse-info/parse 10 (for-syntax "optcontract.rkt" 11 racket/syntax 12 phc-toolkit/untyped 13 racket/function 14 stxparse-info/parse) 15 (for-syntax (only-in auto-syntax-e/utils make-auto-pvar))) 16 (version-case 17 [(version< (version) "6.90.0.24") 18 (require (only-in stxparse-info/parse/private/residual 19 [make-attribute-mapping 20 compat-make-attribute-mapping]))] 21 [else 22 (require (only-in stxparse-info/parse/private/residual ;; must be an absolute path 23 check-attr-value 24 [attribute-mapping -make-attribute-mapping])) 25 (define-for-syntax (compat-make-attribute-mapping valvar name depth syntax?) 26 (-make-attribute-mapping 27 valvar name depth (if syntax? #f (quote-syntax check-attr-value))))]) 28 29 (begin-for-syntax 30 (define/contract (nest-map f last n) 31 (-> (-> syntax? syntax?) syntax? exact-nonnegative-integer? syntax?) 32 (if (= n 0) 33 last 34 (f (nest-map f last (sub1 n)))))) 35 36 (define/contract (attribute-val/c depth [bottom-predicate any/c]) 37 (->* {exact-nonnegative-integer?} {flat-contract?} flat-contract?) 38 (flat-named-contract 39 (build-compound-type-name 'attribute-val/c depth bottom-predicate) 40 (λ (l) 41 (if (= depth 0) 42 (or (false? l) (bottom-predicate l)) 43 (or (false? l) 44 (and (list? l) 45 (andmap (attribute-val/c (sub1 depth)) l))))))) 46 47 (struct wrapped (value)) 48 49 (define (attribute-wrap val depth) 50 (if (= depth 0) 51 (wrapped val) 52 (if val 53 (map (λ (v) (attribute-wrap v (sub1 depth))) 54 val) 55 #f))) 56 57 (define-syntax/parse (copy-raw-syntax-attribute name:id 58 attr-value:expr 59 ellipsis-depth:nat 60 syntax?:boolean) 61 ;; the ~and is important, to prevent the nested ~or from being treated as 62 ;; an ellipsis-head pattern. 63 #:with nested (nest-map (λ (pat) #`{~or #f ({~and #,pat} (... ...))}) 64 (if (syntax-e #'syntax?) 65 #'{~or #f name} 66 ;; Variable with empty name, so that the attribute 67 ;; gets exported without a prefix. 68 ;; Take care to keep the original srcloc, 69 ;; otherwise error messages lack the proper srcloc 70 #`{~or #f {~var #,(datum->syntax #'name 71 '|| 72 #'name) 73 extract-non-syntax}}) 74 (syntax-e #'ellipsis-depth)) 75 (if (syntax-e #'syntax?) 76 (with-syntax ([vtmp (generate-temporary #'name)] 77 [stmp (generate-temporary #'name)]) 78 #'(begin 79 (define vtmp attr-value);; TODO: if already an id, no need to copy it (unless the id is mutated) 80 (define-syntax stmp 81 (compat-make-attribute-mapping (quote-syntax vtmp) 82 'name 'ellipsis-depth 'syntax?)) 83 (define-syntax name 84 (make-auto-pvar 'ellipsis-depth (quote-syntax stmp))) 85 (define-pvars name))) 86 ;; TODO ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ vvvvvvvvvvvvvvvvvvvvvvvvvv 87 #'(begin 88 (define-syntax-class extract-non-syntax 89 #:attributes (name) 90 (pattern v 91 #:attr name (wrapped-value (syntax-e #'v)))) 92 (define/syntax-parse nested (attribute-wrap attr-value 93 ellipsis-depth)))))