template-subscripts.rkt (19200B)
1 #lang racket/base 2 3 (require racket/require 4 racket/list 5 racket/string 6 racket/function 7 "optcontract.rkt" 8 phc-toolkit/untyped 9 phc-toolkit/untyped-only/syntax-parse 10 racket/stxparam 11 stxparse-info/parse 12 stxparse-info/case 13 stxparse-info/current-pvars 14 stxparse-info/parse/experimental/template 15 (prefix-in - stxparse-info/parse/private/residual) 16 (prefix-in dbg: stxparse-info/parse/private/runtime) 17 syntax/id-table 18 (subtract-in racket/syntax stxparse-info/case) 19 "copy-attribute.rkt" 20 "lifted-variables-communication.rkt" 21 (for-syntax (subtract-in racket/base srfi/13) 22 "patch-arrows.rkt" 23 "subscripts.rkt" 24 racket/format 25 stxparse-info/parse 26 racket/private/sc 27 racket/syntax 28 racket/list 29 racket/function 30 phc-toolkit/untyped 31 syntax/strip-context 32 srfi/13 33 (subtract-in racket/string srfi/13) 34 syntax/contract 35 "optcontract.rkt")) 36 37 (provide subtemplate 38 quasisubtemplate 39 derive 40 ellipsis-count/c) ;; TODO: don't provide this here. 41 42 (define derived-valvar-cache (make-weak-hash)) 43 44 (begin-for-syntax 45 (define/contract (nest-ellipses stx n) 46 (-> syntax? exact-nonnegative-integer? syntax?) 47 (if (= n 0) 48 stx 49 #`(#,(nest-ellipses stx (sub1 n)) 50 (… …))))) 51 52 ;; Checks that all the given attribute values have the same structure. 53 ;; 54 ;; ellipsis-count/c works with the value of pattern variables and of attributes 55 ;; too, including those missing (optional) elements in the lists, at any level. 56 ;; 57 ;; The lists must have the same lengths across all attribute values, including 58 ;; the missing #f elements. 59 ;; 60 ;; If same-shape is #true, a #f in one attribute value implies #f in all other 61 ;; attribute values at the same position. The same-shape check is not 62 ;; performed on the bottommost #f values (as they do not influence the shape of 63 ;; the tree). 64 (define/contract (ellipsis-count/c depth 65 [bottom-predicate any/c] 66 #:same-shape [same-shape #f]) 67 (->* {exact-nonnegative-integer?} 68 {flat-contract? 69 #:same-shape boolean?} 70 flat-contract?) 71 ;; Must be lazy, otherwise ellipsis-count/c would immediately call itself 72 (define (recur/c sublists) 73 ((ellipsis-count/c (sub1 depth) bottom-predicate #:same-shape same-shape) 74 sublists)) 75 (flat-named-contract 76 (apply build-compound-type-name 77 (list* 'ellipsis-count/c depth bottom-predicate 78 (if same-shape 79 (list '#:same-shape same-shape) 80 (list)))) 81 (λ (l*) 82 (true? 83 (and (list? l*) 84 (if (and same-shape (> depth 0)) 85 (or (andmap false? l*) ;; all #f 86 (andmap identity l*)) ;; all non-#f 87 #t) 88 (let ([l* (filter identity l*)]) 89 (if (= depth 0) 90 (andmap bottom-predicate l*) 91 (let ([lengths (map length l*)]) 92 (and (or (< (length lengths) 2) (apply = lengths)) 93 (or (empty? l*) 94 (apply andmap 95 (λ sublists 96 (recur/c sublists)) 97 l*))))))))))) 98 99 (define/contract (map-merge-stx-depth f l* depth) 100 (->i {[f (-> (listof any/c) any/c)] 101 [l* (depth) (ellipsis-count/c depth any/c)] 102 [depth exact-nonnegative-integer?]} 103 {result (depth l*) 104 (λ (r) ((ellipsis-count/c depth) (cons r l*)))}) 105 (let ([l* (filter identity l*)]) 106 (if (= depth 0) 107 (f l*) 108 (if (empty? l*) 109 #f 110 (apply map 111 (λ sublists 112 (map-merge-stx-depth f 113 sublists 114 (sub1 depth))) 115 l*))))) 116 117 (define-for-syntax (sub*template self-form tmpl-form get-attribute*) 118 (syntax-parser 119 [(self {~optional {~and #:force-no-stxinfo force-no-stxinfo}} 120 {~optkw #:props (prop:id ...)} 121 ;; #: marks end of options (so that we can have implicit ?@ later) 122 {~optional #:} 123 tmpl) 124 (unless (attribute force-no-stxinfo) 125 (for ([sym (in-list '(syntax-parse define/syntax-parse syntax-parser 126 syntax-case define/with-syntax with-syntax))]) 127 (let ([shadower (datum->syntax #'self sym)];syntax-local-get-shadower ? 128 [good (datum->syntax #'here sym)]) 129 (when (or (not (identifier-binding shadower)) 130 (not (free-identifier=? shadower good))) 131 (raise-syntax-error self-form 132 (~a sym (if (identifier-binding shadower) 133 (~a " resolves to the official " 134 sym ",") 135 " seems undefined,") 136 " but subtemplate needs the patched" 137 " version from stxparse-info. Use (require" 138 " stxparse-info/parse) and (require" 139 " stxparse-info/case) to fix this. This" 140 " message can be disabled with (" self-form 141 " #:force-no-stxinfo …), if you know what" 142 " you're doing.")))))) 143 144 (define acc '()) 145 146 ;; Finds identifiers of the form zᵢ, and return a list of existing xᵢ 147 ;; bindings 148 (define (fold-process stx rec) 149 (syntax-case stx () 150 [(id . _) (and (identifier? #'id) 151 (free-identifier=? #'id #'unsyntax)) 152 stx] 153 [id (identifier? #'id) 154 (let ([binders+info (find-subscript-binders #'id)]) 155 (when binders+info 156 (set! acc (cons binders+info acc))) 157 #'id)] 158 [other (rec #'other)])) 159 ;; Process the syntax, extract the derived bindings into acc 160 ;; Does not take zᵢ identifiers generated by template metafunctions into 161 ;; account for now. 162 (fold-syntax fold-process #'tmpl) 163 164 ;; define the result, which looks like (template . tmpl) or 165 ;; like (quasitemplate . tmpl) 166 (define result 167 (quasisyntax/top-loc #'self 168 (#,tmpl-form tmpl 169 #,@(if (attribute props) #'(#:props (prop ...)) #'())))) 170 ;; Make sure that we remove duplicates, otherwise we'll get errors if we 171 ;; define the same derived id twice. 172 (define/with-syntax ([bound 173 (binder …) 174 unique-at-runtime-ids 175 ellipsis-depth] 176 …) 177 (remove-duplicates acc bound-identifier=? #:key car)) 178 179 (define/with-syntax whole-form-id (generate-temporary 'whole-subtemplate)) 180 181 (define lift-target (lift-late-pvars-target)) 182 (if lift-target 183 (let () 184 (define/with-syntax ([token . to-insert] …) 185 (stx-map lifted-pvar 186 (stx-map syntax-e #'(bound …)) ;; name 187 #`([lifted-var-macro bound] …))) 188 #`(let-values () 189 (quote-syntax (to-insert …)) 190 (copy-raw-syntax-attribute bound 191 (hash-ref #,lift-target 'token) 192 ellipsis-depth 193 #f) ;; TODO: #t iff the original was #t 194 … 195 #,(if get-attribute* 196 #'(list (attribute* bound ) …) 197 result))) 198 #`(let-values () 199 (define-values (whole-form-id) (quote-syntax #,this-syntax)) 200 (derive bound 201 (binder …) 202 unique-at-runtime-ids 203 ellipsis-depth 204 whole-form-id) 205 … 206 #,(if get-attribute* 207 #'(list (attribute* bound ) …) 208 #`(let-values () 209 ;; check that all the binders for a given bound are 210 ;; compatible. 211 ((ellipsis-count/c ellipsis-depth) 212 (list (attribute* binder) …)) 213 … 214 ;; actually call template or quasitemplate 215 #,result))))])) 216 217 (define-syntax (lifted-var-macro stx) 218 (syntax-case stx () 219 [(_ bound) 220 #`(car (subtemplate/attribute* bound))])) 221 222 (define-syntax subtemplate/attribute* 223 (sub*template 'subtemplate #'template #t)) 224 (define-syntax subtemplate 225 (sub*template 'subtemplate #'template #f)) 226 (define-syntax quasisubtemplate 227 (sub*template 'quasisubtemplate #'quasitemplate #f)) 228 229 (define/contract (multi-hash-ref! h keys) 230 ;; This assumes that the hash does not get mutated during the execution of 231 ;; this function. 232 (-> (and/c (hash/c symbol? any/c #:immutable #f) hash-weak?) 233 (listof symbol?) 234 any/c) 235 (define val (or (for/or ([k (in-list keys)]) (hash-ref h k #f)) 236 (make-free-id-table))) ;; create an empty table by default. 237 ;; Set the existing value (or new to-set if none) on all keys which 238 ;; are not present in the hash table. 239 (for ([k (in-list keys)]) (hash-ref! h k val)) 240 val) 241 242 (define formattable/c (or/c number? string? symbol? bytes?)) 243 244 (define (generate-nested-ids-check-ellipsis-match-count 245 l* depth attribute-names whole-form bound) 246 (if ((ellipsis-count/c depth) l*) 247 #t 248 (raise-syntax-error 249 (syntax-case whole-form () 250 [(self . _) (syntax-e #'self)] 251 [_ 'subtemplate]) 252 "incompatible ellipsis match counts for subscripted variables:" 253 whole-form 254 bound 255 attribute-names))) 256 257 (module+ test-private 258 (provide generate-nested-ids)) 259 260 (define generate-nested-ids-full-contract 261 (->i {[depth exact-nonnegative-integer?] 262 [bound identifier?] 263 [binder₀ identifier?] 264 [format (-> formattable/c string?)] 265 [l* (depth) (listof (attribute-val/c depth))] 266 [attribute-names (l*) (and/c (listof identifier?) 267 (λ (a) (= (length l*) (length a))))] 268 [whole-form syntax?]} 269 #:pre (l* depth attribute-names whole-form bound) 270 (generate-nested-ids-check-ellipsis-match-count 271 l* depth attribute-names whole-form bound) 272 {result (depth l*) 273 (and/c (attribute-val/c depth identifier?) 274 (λ (r) ((ellipsis-count/c depth) (cons r l*))))})) 275 276 (define/contract/alt 277 (generate-nested-ids depth bound binder₀ format l* attribute-names whole-form) 278 generate-nested-ids-full-contract 279 (generate-nested-ids-check-ellipsis-match-count 280 l* depth attribute-names whole-form bound) 281 (define (gen bottom*) 282 (define v 283 (let ([vs (filter-map (λ (v) 284 (cond [(formattable/c v) v] 285 [(formattable/c (syntax-e v)) (syntax-e v)] 286 [else #f])) 287 bottom*)]) 288 (if (empty? vs) 289 (syntax-e (generate-temporary binder₀)) 290 (car vs)))) 291 (datum->syntax ((make-syntax-introducer) bound) 292 (string->symbol (format v)))) 293 294 (map-merge-stx-depth gen l* depth)) 295 296 (define-syntax/case (derive bound 297 (binder₀ binderᵢ …) 298 (unique-at-runtime-idᵢ …) 299 ellipsis-depth 300 whole-form-id) () 301 (define depth (syntax-e #'ellipsis-depth)) 302 (define/with-syntax bound-ddd (nest-ellipses #'bound depth)) 303 (define/with-syntax tmp-id 304 (format-id #'here "~a/~a" #'binder₀ (drop-subscripts #'bound))) 305 (define/with-syntax tmp-str 306 (datum->syntax #'tmp-id 307 (symbol->string 308 (syntax-e 309 (format-id #'here "~~a/~a" (drop-subscripts #'bound)))))) 310 (define/with-syntax tmp-ddd (nest-ellipses #'tmp-id depth)) 311 (define/with-syntax binder-ddd (nest-ellipses #'binder₀ depth)) 312 313 ;; Draw arrows in DrRacket. 314 (with-arrows 315 (define bound-subscripts (extract-subscripts #'bound)) 316 (define binder-subscripts (extract-subscripts #'binder₀)) 317 (define bound-id-str (identifier->string #'bound)) 318 (for ([binder (in-list (syntax->list #'(binder₀ binderᵢ …)))]) 319 (define binder-id-str (identifier->string binder)) 320 (record-sub-range-binders! (vector #'bound 321 (- (string-length bound-id-str) 322 (string-length bound-subscripts)) 323 (string-length bound-subscripts) 324 binder 325 (- (string-length binder-id-str) 326 (string-length binder-subscripts)) 327 (string-length binder-subscripts)))) 328 #;(define binder0-id-str (identifier->string #'binder0)) 329 #;(record-sub-range-binders! (vector #'bound 330 (- (string-length bound-id-str) 331 (string-length subscripts)) 332 (string-length subscripts) 333 #'binder0 334 (- (string-length binder0-id-str) 335 (string-length subscripts)) 336 (string-length subscripts))) 337 (define/with-syntax temp-derived (generate-temporary #'bound)) 338 (define/with-syntax temp-valvar (generate-temporary #'bound)) 339 (define/with-syntax temp-cached (generate-temporary #'bound)) 340 (define/with-syntax temp-generated (generate-temporary #'bound)) 341 (define/with-syntax temp-id-table (generate-temporary #'bound)) 342 ;; HERE: cache the define-temp-ids in the free-id-table, and make sure 343 ;; that we retrieve the cached ones, so that two subtemplate within the same 344 ;; syntax-case or syntax-parse clause use the same derived ids. 345 ;; 346 ;; We mark specially those bindings bound by (derive …) so that they are 347 ;; not seen as original bindings in nested subtemplates (e.g. with an 348 ;; "unsyntax"), otherwise that rule may not hold anymore, e.g. 349 ;; (syntax-parse #'(a b c) 350 ;; [(xᵢ …) 351 ;; (quasisubtemplate (yᵢ … 352 ;; #,(quasisubtemplate zᵢ …) ;; must be from xᵢ, not yᵢ 353 ;; zᵢ …))]) 354 ;; the test above is not exactly right (zᵢ will still have the correct 355 ;; binding), but it gives the general idea. 356 #`(begin 357 (define-values (temp-generated) 358 (generate-nested-ids 'ellipsis-depth 359 (quote-syntax bound) 360 (quote-syntax binder₀) 361 (λ (v) (format tmp-str v)) 362 (list (attribute* binder₀) 363 (attribute* binderᵢ) 364 …) 365 (list (quote-syntax binder₀) 366 (quote-syntax binderᵢ) 367 …) 368 whole-form-id)) 369 (define-values (temp-id-table) 370 (multi-hash-ref! derived-valvar-cache 371 (list unique-at-runtime-idᵢ 372 …))) 373 (define-values (temp-cached) 374 (free-id-table-ref! temp-id-table 375 (quote-syntax bound) 376 temp-generated)) 377 378 (check-derived-ellipsis-shape ellipsis-depth 379 temp-generated 380 temp-id-table 381 (quote-syntax whole-form-id) 382 (quote-syntax bound)) 383 384 (copy-raw-syntax-attribute bound 385 temp-cached 386 ellipsis-depth 387 #f)))) ;; TODO: #t iff the original was #t 388 389 (define (check-derived-ellipsis-shape ellipsis-depth 390 temp-generated 391 temp-id-table 392 whole-form-id 393 bound) 394 ;; Check that all derived pvars for this subscript from all binders 395 ;; have the same shape, i.e. we wouldn't want some elements to be missing 396 ;; (as in ~optional) at some position from one derived pvar, but not from 397 ;; others. This check implies that the original binder used did not 398 ;; introduce new elements compared to the binders used for other derived 399 ;; pvars, e.g: 400 ;; (syntax-parse #'([1 2 3] #f) 401 ;; [({~and {~or (xᵢ ...) #f}} ...) 402 ;; (subtemplate ({?? (yᵢ ...) _} ...)) ;; => ((1/y 2/y 3/y) _) 403 ;; (syntax-case #'([a b c] [d e]) () 404 ;; ;; introduces elements [d e] which were unknown when yᵢ was 405 ;; ;; generated: 406 ;; [((wᵢ ...) ...) 407 ;; ;; Would give ((a/z b/z c/z) (d/z e/z)), but this is 408 ;; ;; inconsistent with the shape of yᵢ. 409 ;; (subtemplate ({?? (zᵢ ...) _} ...))])]) 410 ;; The check must also compare temp-generated, even if it was not 411 ;; assigned to #'bound, so that it also cathes the error if we replace 412 ;; zᵢ with yᵢ in the example above. 413 (unless ((ellipsis-count/c ellipsis-depth #:same-shape #t) 414 (cons temp-generated 415 (free-id-table-map temp-id-table (λ (k v) v)))) 416 ;; TODO: For now this will just blow up, a better error message would 417 ;; be nice. Especially saying which one failed. 418 (raise-syntax-error 419 'sublist 420 (format (string-append 421 "some derived variables do not have the same ellipsis shape\n" 422 " depth: ~a\n" 423 " attributes...:\n" 424 " ~a\n" 425 " attribute ~a if it were generated here...:\n" 426 " ~a") 427 'ellipsis-depth 428 (string-join (free-id-table-map 429 temp-id-table 430 (λ (k v) 431 (format "~a => ~a" 432 (syntax-e k) 433 (syntax->datum 434 (datum->syntax #f v))))) 435 "\n ") 436 'bound 437 (syntax->datum 438 (datum->syntax #f temp-generated))) 439 whole-form-id 440 bound 441 (free-id-table-map temp-id-table (λ (k v) k)))))