format-id-record.rkt (9396B)
1 #lang racket/base 2 3 (module m racket/base 4 (require racket/contract 5 racket/syntax 6 racket/stxparam 7 syntax/stx 8 syntax/parse 9 (submod "../syntax-parse.rkt" untyped) 10 (for-syntax racket/base)) 11 12 (provide sub-range-binder/c 13 current-recorded-sub-range-binders 14 maybe-record-sub-range-binders! 15 record-sub-range-binders! 16 with-sub-range-binders 17 with-arrows 18 syntax-parser-with-arrows 19 format-id/record) 20 21 (define sub-range-binder/c 22 (or/c (vector/c syntax? 23 exact-nonnegative-integer? exact-nonnegative-integer? 24 (real-in 0 1) (real-in 0 1) 25 syntax? 26 exact-nonnegative-integer? exact-nonnegative-integer? 27 (real-in 0 1) (real-in 0 1)) 28 (vector/c syntax? 29 exact-nonnegative-integer? exact-nonnegative-integer? 30 syntax? 31 exact-nonnegative-integer? exact-nonnegative-integer?))) 32 33 (define/contract current-recorded-sub-range-binders 34 (parameter/c (or/c (listof sub-range-binder/c) false/c)) 35 (make-parameter #f)) 36 37 ;; TODO: should use a parameter in addition to the error? argument. 38 (define/contract ((record-sub-range-binders/check! error?) sub-range-binders) 39 (-> boolean? 40 (-> (or/c sub-range-binder/c (listof sub-range-binder/c)) 41 void?)) 42 (if (current-recorded-sub-range-binders) 43 (if (list? sub-range-binders) 44 (current-recorded-sub-range-binders 45 (append sub-range-binders (current-recorded-sub-range-binders))) 46 (current-recorded-sub-range-binders 47 (cons sub-range-binders (current-recorded-sub-range-binders)))) 48 (when error? 49 (error 50 (format 51 (string-append "record-sub-range-binders should be used within the" 52 " dynamic extent of with-sub-range-binders," 53 " with-arrows or a similar form. Arguments were: ~a") 54 sub-range-binders))))) 55 56 (define/contract maybe-record-sub-range-binders! 57 (-> (or/c sub-range-binder/c (listof sub-range-binder/c)) 58 void?) 59 (record-sub-range-binders/check! #f)) 60 61 (define/contract record-sub-range-binders! 62 (-> (or/c sub-range-binder/c (listof sub-range-binder/c)) 63 void?) 64 (record-sub-range-binders/check! #t)) 65 66 (define-syntax-rule (with-sub-range-binders . body) 67 (parameterize ([current-recorded-sub-range-binders '()]) 68 (syntax-property (let () . body) 69 'sub-range-binders 70 (current-recorded-sub-range-binders)))) 71 72 (define-syntax-rule (with-arrows . body) 73 (with-disappeared-uses 74 (with-sub-range-binders 75 . body))) 76 77 (define-syntax-rule (syntax-parser-with-arrows . opts+clauses) 78 (λ (stx2) 79 (with-disappeared-uses 80 (with-sub-range-binders 81 (syntax-parameterize ([stx (make-rename-transformer #'stx2)]) 82 ((syntax-parser . opts+clauses) stx2)))))) 83 84 (define (identifier-length id) 85 (string-length (symbol->string (syntax-e id)))) 86 87 (define (formatted-length v) 88 (identifier-length (format-id #f "~a" v))) 89 90 (define (format-length fmt) 91 (identifier-length (format-id #f fmt))) 92 93 (define/contract (format-id/record lctx 94 fmt 95 #:source [src #f] 96 #:props [props #f] 97 . vs) 98 ;; TODO: use check-restricted-format-string from racket/syntax.rkt 99 (->* {(or/c syntax? #f) 100 (or/c string? (syntax/c string?))} 101 {#:source (or/c syntax? #f) 102 #:props (or/c syntax? #f)} 103 #:rest (listof (or/c string? symbol? keyword? char? number? 104 (syntax/c string?) 105 identifier? 106 (syntax/c keyword?) 107 (syntax/c char?) 108 (syntax/c number?))) 109 identifier?) 110 111 (define e-vs (stx-map (λ (v) (if (and (syntax? v) (not (identifier? v))) 112 (syntax-e v) 113 v)) 114 vs)) 115 (define str-fmt (if (syntax? fmt) (syntax-e fmt) fmt)) 116 (define whole (apply format-id lctx str-fmt e-vs 117 #:source src 118 #:props props)) 119 (define split-fmt (regexp-split #px"~[aA]" str-fmt)) 120 121 ;; sub-range-binder for the first static part of the format 122 (when (syntax? fmt) 123 (record-sub-range-binders! 124 (vector (syntax-local-introduce whole) 125 0 (format-length (car split-fmt)) 126 fmt 127 1 (string-length (car split-fmt))))) ;; +1 for #\" 128 129 (for/fold ([input-len (+ 1 (string-length (car split-fmt)))] ;; +1 for #\" 130 [output-len (string-length (car split-fmt))]) 131 ([v (in-list vs)] 132 [e-v (in-list e-vs)] 133 [fmt-part (cdr split-fmt)]) 134 (define v-len (formatted-length e-v)) 135 (define fmt-output-len (format-length fmt-part)) 136 (define fmt-input-len (string-length fmt-part)) 137 ;; sub-range binder for the ~a 138 (record-sub-range-binders! 139 (vector (syntax-local-introduce whole) 140 output-len v-len 141 v 142 0 v-len)) 143 ;; sub-range-binder for the static part of the format 144 (when (syntax? fmt) 145 (record-sub-range-binders! 146 (vector (syntax-local-introduce whole) 147 (+ output-len v-len) fmt-output-len 148 fmt 149 (+ input-len 2) fmt-input-len))) ;; +2 for the "~a" 150 ;; loop with format-len and output-len = 151 (values (+ input-len 2 fmt-input-len) ;; +2 for the "~a" 152 (+ output-len v-len fmt-output-len))) 153 whole)) 154 155 (module m2 racket/base 156 (require (for-syntax (submod ".." m) 157 phc-toolkit/untyped/aliases 158 syntax/parse 159 racket/function 160 syntax/stx 161 (only-in (submod "../stx.rkt" untyped) 162 remove-use-site-scope))) 163 (provide inject-sub-range-formats) 164 165 (require racket/splicing 166 (for-syntax racket/base)) 167 168 (define-syntax (inject-sub-range-formats stx) 169 ;; for some reason, callijng remove-use-site-scope on the whole stx object 170 ;; does not work. 171 (define clean-stx (remove-use-site-scope stx)) 172 (syntax-case stx (); parser 173 [(_ ([lctx fmt vs …] …) . body);(_ ([-lctx -fmt -vs …] …) . -body) 174 ;#:with (lctx …) (stx-map remove-use-site-scope #'(-lctx …)) 175 ;#:with (fmt …) (stx-map remove-use-site-scope #'(-fmt …)) 176 ;#:with ((vs …) …) (stx-map (curry stx-map remove-use-site-scope) 177 ; #'((-vs …) …)) 178 ;#:with body (remove-use-site-scope #'-body) 179 (remove-use-site-scope 180 #'(splicing-let-syntax 181 ([tmp (λ _ 182 (with-sub-range-binders 183 (format-id/record lctx fmt vs …) 184 … 185 (remove-use-site-scope 186 (syntax-local-introduce 187 (quote-syntax (begin . body))))))]) 188 (tmp)))]))) 189 190 (module m3 racket/base 191 (require racket/require-syntax 192 (for-syntax racket/base 193 racket/list) 194 racket/stxparam 195 racket/syntax) 196 197 (define-require-syntax (for-many stx) 198 (syntax-case stx () 199 [(_ require-spec ...) 200 #`(combine-in #,@(map (λ (n) #`(for-meta #,n require-spec ...)) 201 (range -16 17)))])) 202 ;; If the level 1 macro using with-format-ids/inject-binders places 203 ;; inject-sub-range-binders ... in a level 0 form, then 'm2 is needed 204 ;; for-template. However, if inject-sub-range-binders ... appears in 205 ;; a level 1 form, then 'm2 is needed for-meta 0. If 206 ;; inject-sub-range-binders ... appears in a level 2 form, then 'm2 is 207 ;; needed for-meta 1, etc. We therefore require it many times, for all 208 ;; meta-levels from -16 to 16, which should be plenty enough for all 209 ;; practical purposes. 210 (require (for-template (for-many (submod ".." m2)))) 211 212 (provide with-format-ids/inject-binders 213 inject-sub-range-binders) 214 215 (define-syntax (inject-sub-range-binders-init stx) 216 (raise-syntax-error 'inject-sub-range-binders 217 "must be used inside with-format-ids/inject" 218 stx)) 219 (define-rename-transformer-parameter inject-sub-range-binders 220 (make-rename-transformer #'inject-sub-range-binders-init)) 221 222 (define-syntax-rule 223 (with-format-ids/inject-binders ([id lctx fmt vs ...] ...) . body) 224 (with-syntax 225 ([(fmts (... ...)) 226 #'(inject-sub-range-formats ([lctx fmt vs ...] ...))]) 227 (syntax-parameterize 228 ([inject-sub-range-binders (make-rename-transformer #'fmts)]) 229 (with-syntax ([id (format-id lctx fmt vs ...)] ...) 230 (let () 231 . body)))))) 232 233 (require 'm 234 (for-template 'm2) 235 'm3) 236 237 (provide (all-from-out 'm) 238 (for-template inject-sub-range-formats) 239 (all-from-out 'm3))