stx-utils.rkt (6185B)
1 #lang racket/base 2 (require syntax/stx syntax/parse syntax/parse/define 3 racket/list racket/format version/utils) 4 (provide (all-defined-out)) 5 6 ;; shorthands 7 (define id? identifier?) 8 (define free-id=? free-identifier=?) 9 (define fmt format) 10 11 (define (stx-cadr stx) (stx-car (stx-cdr stx))) 12 (define (stx-caddr stx) (stx-cadr (stx-cdr stx))) 13 (define (stx-cddr stx) (stx-cdr (stx-cdr stx))) 14 15 (define datum->stx datum->syntax) 16 (define (stx->datum stx) 17 (cond [(syntax? stx) (syntax->datum stx)] 18 [(list? stx) (map stx->datum stx)] 19 [else stx])) 20 21 (define (stx-rev stx) 22 (reverse (stx->list stx))) 23 (define (stx-andmap f . stx-lsts) 24 (apply andmap f (map stx->list stx-lsts))) 25 (define (stx-ormap f . stx-lsts) 26 (apply ormap f (map stx->list stx-lsts))) 27 28 (define (stx-flatten stxs) 29 (apply append (stx-map stx->list stxs))) 30 31 (define (stx-filter p? stxs) 32 (filter p? (stx->list stxs))) 33 34 (define (curly-parens? stx) 35 (define paren-prop (syntax-property stx 'paren-shape)) 36 (and paren-prop (char=? #\{ paren-prop))) 37 38 (define (stx-datum-equal? x y [eq equal?]) 39 (eq (stx->datum x) (stx->datum y))) 40 41 (define (stx-member v stx [eq free-id=?]) 42 (member v (stx->list stx) eq)) 43 44 (define (stx-datum-member v stx [eq stx-datum-equal?]) 45 (stx-member v stx eq)) 46 47 (define (str-stx-member v stx) 48 (stx-datum-member v stx)) 49 (define (str-stx-assoc v stx) 50 (assoc v (map stx->list (stx->list stx)) stx-str=?)) 51 (define (stx-assoc v stx [cmp free-identifier=?]) ; v = id 52 (assoc v (map stx->list (stx->list stx)) cmp)) 53 (define (stx-findf f stx) 54 (findf f (stx->list stx))) 55 56 (define (stx-length stx) (length (stx->list stx))) 57 (define (stx-length=? stx1 stx2) (= (stx-length stx1) (stx-length stx2))) 58 (define (stx-length>=? stx1 stx2) (>= (stx-length stx1) (stx-length stx2))) 59 (define (stx-length<=? stx1 stx2) (<= (stx-length stx1) (stx-length stx2))) 60 61 (define (stx-last stx) (last (stx->list stx))) 62 63 (define (stx-list-ref stx i) 64 (list-ref (stx->list stx) i)) 65 (define-simple-macro (in-stx-list stx) (in-list (stx->list stx))) 66 67 (define (stx-str=? s1 s2) 68 (string=? (syntax-e s1) (syntax-e s2))) 69 70 (define (stx-sort stx 71 #:cmp [cmp (lambda (x y) (string<=? (~a (syntax->datum x)) 72 (~a (syntax->datum y))))] 73 #:key [key-fn (λ (x) x)]) 74 (sort (stx->list stx) cmp #:key key-fn)) 75 76 (define (stx-fold f base . lsts) 77 (apply foldl f base (map stx->list lsts))) 78 (define (stx-foldr f base . lsts) 79 (apply foldr f base (map stx->list lsts))) 80 81 (define (stx-apply f stx) 82 (apply f (stx->list stx))) 83 (define (stx-append . stxs) 84 (apply append (stx-map stx->list stxs))) 85 (define (stx-appendmap f . stxs) 86 (stx-flatten (apply stx-map f stxs))) 87 88 (define (stx-remove-dups Xs) 89 (remove-duplicates (stx->list Xs) free-identifier=?)) 90 (define (stx-remove v lst [f free-id=?]) 91 (remove v (stx->list lst) f)) 92 93 (define (stx-drop stx n) 94 (drop (stx->list stx) n)) 95 96 (define (id-lower-case? stx) 97 (unless (identifier? stx) 98 (error 'stx-upcase "Expected identifier, given ~a" stx)) 99 (char-lower-case? 100 (car (string->list (symbol->string (syntax->datum stx)))))) 101 102 (define (id-upcase stx) 103 (unless (identifier? stx) 104 (error 'stx-upcase "Expected identifier, given ~a" stx)) 105 (define chars (string->list (symbol->string (syntax->datum stx)))) 106 (define fst (car chars)) 107 (define rst (cdr chars)) 108 (datum->syntax 109 stx 110 (string->symbol (apply string (cons (char-upcase fst) rst))))) 111 112 (define (generate-temporariess stx) 113 (stx-map generate-temporaries stx)) 114 (define (generate-temporariesss stx) 115 (stx-map generate-temporariess stx)) 116 117 ;; stx prop helpers 118 119 ;; ca*r : Any -> Any 120 (define (ca*r v) 121 (if (cons? v) (ca*r (car v)) v)) 122 ;; cd*r : Any -> Any 123 (define (cd*r v) 124 (if (cons? v) (cd*r (cdr v)) v)) 125 126 ;; get-stx-prop/ca*r : Syntax Key -> Val 127 ;; Retrieves Val at Key stx prop on Stx. 128 ;; If Val is a non-empty list, continue down head until non-list. 129 (define (get-stx-prop/ca*r stx tag) 130 (ca*r (syntax-property stx tag))) 131 132 ;; get-stx-prop/cd*r : Syntax Key -> Val 133 (define (get-stx-prop/cd*r stx tag) 134 (cd*r (syntax-property stx tag))) 135 136 ;; transfers properties and src loc from orig to new 137 (define (transfer-stx-props new orig #:ctx [ctx new]) 138 (datum->syntax ctx (syntax-e new) orig orig)) 139 (define (replace-stx-loc old new) 140 (datum->syntax (syntax-disarm old #f) (syntax-e (syntax-disarm old #f)) new old)) 141 142 ;; transfer single prop 143 (define (transfer-prop p from to) 144 (define v (syntax-property from p)) 145 (syntax-property to p v)) 146 ;; transfer all props except 'origin, 'orig, and ': 147 (define (transfer-props from to #:except [dont-transfer '(origin orig :)]) 148 (define (transfer-from prop to) (transfer-prop prop from to)) 149 (define props (syntax-property-symbol-keys from)) 150 (define props/filtered (foldr remove props dont-transfer)) 151 (foldl transfer-from to props/filtered)) 152 153 ;; set-stx-prop/preserved : Stx Any Any -> Stx 154 ;; Returns a new syntax object with the prop property set to val. If preserved 155 ;; syntax properties are supported, this also marks the property as preserved. 156 (define REQUIRED-VERSION "6.5.0.4") 157 (define VERSION (version)) 158 (define PRESERVED-STX-PROP-SUPPORTED? (version<=? REQUIRED-VERSION VERSION)) 159 (define (set-stx-prop/preserved stx prop val) 160 (if PRESERVED-STX-PROP-SUPPORTED? 161 (syntax-property stx prop val #t) 162 (syntax-property stx prop val))) 163 164 ;; stx-contains-id? : Stx Id -> Boolean 165 ;; Returns true if stx contains the identifier x, false otherwise. 166 (define (stx-contains-id? stx x) 167 (syntax-parse stx 168 [a:id (free-identifier=? #'a x)] 169 [(a . b) 170 (or (stx-contains-id? #'a x) 171 (stx-contains-id? #'b x))] 172 [_ #false])) 173 174 ;; based on make-variable-like-transformer from syntax/transformer, 175 ;; but using (#%app id ...) instead of ((#%expression id) ...) 176 (define (make-variable-like-transformer ref-stx) 177 (unless (syntax? ref-stx) 178 (raise-type-error 'make-variable-like-transformer "syntax?" ref-stx)) 179 (lambda (stx) 180 (syntax-case stx () 181 [id 182 (identifier? #'id) 183 (replace-stx-loc ref-stx stx)] 184 [(id . args) 185 (let ([stx* (list* '#%app #'id (cdr (syntax-e stx)))]) 186 (datum->syntax stx stx* stx stx))]))) 187