quasitemplate.rkt (3260B)
1 #lang racket 2 3 (require syntax/parse/experimental/template 4 (for-syntax syntax/parse 5 racket/syntax)) 6 7 (provide quasitemplate 8 (all-from-out syntax/parse/experimental/template)) 9 10 ;; subst-quasitemplate returns a stx-pair, with definitions for 11 ;; with-syntax in the stx-car, and a template in the stx-cdr. 12 ;; The template is either of the form ('eh-tmpl . tmpl), in which case it is an 13 ;; ellipsis-head template, or of the form ('tmpl . tmpl), in which case it is 14 ;; a regular template. 15 16 ;; Appending the stx-car from the two branches at each recursion step is 17 ;; extremely inefficient (in the worst case O(n²)), so while gathering them, we 18 ;; store them as a binary tree, and then we flatten it with flatten-defs. 19 20 ;; Note that quasitemplate can still take O(n²) time, because of ellipsis-head 21 ;; templates which are not handled very efficiently. 22 23 (define-for-syntax (flatten-defs stx acc) 24 (syntax-parse stx 25 [(l r) (flatten-defs #'r (flatten-defs #'l acc))] 26 [() acc] 27 [(def) #`(def . #,acc)])) 28 29 ;; There are two cases for the transformation of #,@(expr): 30 ;; If it is in a car position, we write: 31 ;; (with-syntax ([(tmp ...) expr]) (tmp ... . the-cdr)) 32 ;; If it is in a cdr position, we write: 33 ;; (with-syntax ([tmp expr]) (the-car . tmp)) 34 (define-for-syntax (subst-quasitemplate car? stx) 35 (syntax-parse stx #:literals (unsyntax unsyntax-splicing) 36 [(unsyntax expr) 37 (with-syntax ([tmp (gensym)]) 38 #`(([tmp expr]) . #,(if car? #'{tmp} #'tmp)))] 39 [(unsyntax-splicing expr) 40 (with-syntax ([tmp (gensym)]) 41 (if car? 42 #'(... (([(tmp ...) expr]) . {tmp ...})) 43 #'(([tmp expr]) . tmp)))] 44 [((unsyntax-splicing expr)) ;; In last position in a list 45 (if car? 46 #'(([tmp expr]) . {tmp}) 47 #'(([tmp expr]) . tmp))] 48 [(a . b) 49 (with-syntax ([(defs-a sa ...) (subst-quasitemplate #t #'a)] 50 [(defs-b . sb) (subst-quasitemplate #f #'b)]) 51 #`((defs-a defs-b) . #,(if car? #'{(sa ... . sb)} #'(sa ... . sb))))] 52 [x 53 #`(() . #,(if car? #'{x} #'x))])) 54 55 (define-syntax (quasitemplate stx) 56 (syntax-parse stx 57 [(_ tmpl) 58 (with-syntax* ([(defs . new-tmpl) (subst-quasitemplate #f #'tmpl)] 59 [(flattened-defs ...) (flatten-defs #'defs #'())]) 60 #'(with-syntax (flattened-defs ...) 61 (template new-tmpl)))])) 62 63 (module+ test 64 (require rackunit) 65 (define-syntax-rule (check . tmpl) 66 (check-equal? (syntax->datum (quasitemplate . tmpl)) 67 (syntax->datum (quasisyntax . tmpl)))) 68 69 (check (a #,(+ 1 2))) 70 (check (a #,(+ 1 2) #,(+ 3 4))) 71 (check (a #,@(list 1 2) #,@(list 3 4))) 72 (check (#,@(list 1 2) #,@(list 3 4) . #,(list* 5 6))) 73 (check (a (#,@(list 1 2) #,@(list 3 4) . #,(list* 5 6)) c)) 74 (check (a . (#,@(list 1 2) #,@(list 3 4) . #,(list* 5 6)))) 75 (check (a (#,@(list 1 2) #,@(list 3 4) . #,(list* 5 6)))) 76 77 (check (#,@(list 1 2) #,@(list 3 4) #,@(list* 5 6))) 78 (check (a (#,@(list 1 2) #,@(list 3 4) #,@(list* 5 6)) c)) 79 (check (a . (#,@(list 1 2) #,@(list 3 4) #,@(list* 5 6)))) 80 (check (a (#,@(list 1 2) #,@(list 3 4) #,@(list* 5 6)))) 81 (check (a #,@1)) 82 (check (a (#,@1))) 83 (check (a (#,@1) c)) 84 (check ((#,@1) b)) 85 (check ((#,@1) b)))