diff --git a/info.rkt b/info.rkt index 6358775..005b712 100644 --- a/info.rkt +++ b/info.rkt @@ -14,5 +14,5 @@ "scribble-math")) (define scribblings '(("scribblings/subtemplate.scrbl" () (parsing-library)))) (define pkg-desc "Various enhancements on syntax templates") -(define version "1.0") +(define version "1.1") (define pkg-authors '("Georges Dupéron")) diff --git a/private/top-subscripts.rkt b/private/top-subscripts.rkt index a930a39..17a3d30 100644 --- a/private/top-subscripts.rkt +++ b/private/top-subscripts.rkt @@ -14,6 +14,12 @@ (define-syntax (top stx) (define/with-syntax bound (stx-cdr stx)) + ;; find-subscript-binders detects the xᵢ pattern variables declared outside of + ;; the #'bound syntax, for which a corresponding yᵢ occurs within the #'bound + ;; syntax. Since #'bound should normally be a single identifier, this will in + ;; effect check whether #'bound is of the form yᵢ, and if so whether a + ;; corresponding pattern variable xᵢ is within scope. The ᵢ can be any + ;; subscript, as long as it is the same for xᵢ and yᵢ. (define binders+info (find-subscript-binders #'bound)) (if binders+info @@ -38,4 +44,6 @@ ((ellipsis-count/c ellipsis-depth) (list (attribute* binder) …)) ;; actually call template or quasitemplate bound))) + ;; If #'bound was not of the form yᵢ, or if we did not find a matching + ;; pattern variable xᵢ, we fall back to the original #%top implementation (datum->syntax stx `(,#'#%top . ,#'bound)))) \ No newline at end of file diff --git a/private/unsyntax-preparse.rkt b/private/unsyntax-preparse.rkt index c06e634..353b65e 100644 --- a/private/unsyntax-preparse.rkt +++ b/private/unsyntax-preparse.rkt @@ -38,32 +38,60 @@ (syntax-parse tmpl #:literals (unsyntax unsyntax-splicing unquote unquote-splicing quasitemplate ?? ?if ?cond ?attr ?@ ?@@) - [({~and u unsyntax} (unquote e)) ;; full unquote with #,, + [({~and u unsyntax} (unquote e)) + #:when (and (= escapes 0) quasi?) + ;; full unsyntax with #,,e (ds `(,#'u ,#'e))] - [({~and u unsyntax-splicing} (unquote e)) ;; full unquote with #,@, + [({~and u unsyntax-splicing} (unquote e)) + #:when (and (= escapes 0) quasi?) + ;; full unsyntax-splicing with #,@,e (ds `(,#'u ,#'e))] - [({~and u unsyntax} (unquote-splicing e)) ;; full unquote with #,,@ + [({~and u unsyntax} (unquote-splicing e)) + #:when (and (= escapes 0) quasi?) + ;; full unsyntax-splicing with #,,@e (ds `(,(datum->syntax #'here 'unsyntax-splicing #'u) ,#'e))] [({~and u unsyntax} e) #:when (and (= escapes 0) quasi?) + ;; ellipsis-preserving unsyntax with #,e + ;; If we are nested at depth D, this lifts a syntax pattern variable + ;; definition for (((tmp ...) ...) ...), with D levels of nesting. + ;; It uses "begin" from subtemplate/private/ddd-forms to generate the + ;; values for tmp succinctly. The template #'e is evaluated as many times + ;; as necessary by "begin", each time stepping the variables under + ;; ellipses. (with-syntax ([tmp (generate-temporary #'e)] [ooo* (map (λ (_) (quote-syntax …)) (range depth))]) + ;; The value returned by e is wrapped in a list via (splice-append e). + ;; Normally, the list will contain a single element, unless e was a + ;; splicing list, in which case it may contain multiple elements. (lift! #`(begin (define/with-syntax tmp (splice-append e)) . ooo*)) + ;; Finally, tmp is inserted into the template (the current position is + ;; under D levels of ellipses) using (?@) to destroy the wrapper list. + ;; This allows #,(?@ 1 2 3) to be equivalent to #,@(list 1 2 3). (ds `(,#'stxparse:?@ . ,(datum->syntax #'tmp #'tmp #'e))))] [({~and u unsyntax-splicing} e) + ;; ellipsis-preserving unsyntax-splicing with #,@e + ;; This works in the same way as the #,e case just above… #:when (and (= escapes 0) quasi?) (with-syntax ([tmp (generate-temporary #'e)] [ooo* (map (λ (_) (quote-syntax …)) (range depth))]) + ;; … with the notable difference that splice-append* is used instead of + ;; splice-append. (lift! #`(begin (define/with-syntax tmp (splice-append* e)) . ooo*)) - #'(stxparse:?@ . tmp))] + (ds `(,#'stxparse:?@ . ,(datum->syntax #'tmp #'tmp #'e))))] [({~and u {~or unsyntax unsyntax-splicing}} e) - ;; when escapes ≠ 0 (or quasi? is #false) - (ds `(,#'u ,(pre-parse-unsyntax e depth (sub1 escapes) quasi? form)))] + ;; Undo one level of protection, so that in #`#`#,x the inner #` adds one + ;; level of escapement, and #, undoes that escapement. + ;; Normally, escapes > 0 here (or quasi? is #false) + (ds `(,#'u ,(pre-parse-unsyntax #'e depth (sub1 escapes) quasi? form)))] [(quasitemplate t . opts) + ;; #`#`#,x does not unquote x, because it is nested within two levels of + ;; quasitemplate. We reproduce this behaviour here. (ds `(,#'quasitemplate ,(pre-parse-unsyntax #'t depth (add1 escapes) quasi? form) . ,#'opts))] [({~and self ?if} condition a b) + ;; Special handling for the (?if condition a b) meta-operator (with-syntax ([tmp (generate-temporary #'self)] [ooo* (map (λ (_) (quote-syntax …)) (range depth))]) (lift! #`(begin (define/with-syntax tmp (?if #,(form (recur #'condition)) @@ -72,14 +100,19 @@ . ooo*)) #'(stxparse:?@ . tmp))] [({~and self ?cond} [{~and condition {~not {~literal else}}} . v] . rest) + ;; Special handling for the ?cond meta-operator, when the first case has + ;; the shape [condition . v], but not [else . v] (recur (ds `(,#'?if ,#'condition ,(ds `(,#'?@ . ,#'v)) ,(ds `(,#'self . ,#'rest)))))] [({~and self ?cond} [{~literal else}] . rest) + ;; ?cond meta-operator, when the first case has the shape [else] #'(stxparse:?@)] [({~and self ?cond} [{~literal else} . v] . rest) + ;; ?cond meta-operator, when the first case has the shape [else . v] (recur #'(?@ . v))] [({~and self ?@@} . e) + ;; Special handling for the special (?@@ . e) meta-operator (with-syntax ([tmp (generate-temporary #'self)] [ooo* (map (λ (_) (quote-syntax …)) (range depth))]) (lift! #`(begin (define/with-syntax tmp @@ -87,23 +120,32 @@ . ooo*)) #'(stxparse:?@ . tmp))] [({~and self ?attr} condition) + ;; Special handling for the special (?attr a) meta-operator (recur (ds `(,#'?if ,#'condition #t #f)))] [(:ooo t) - tmpl] ;; fully escaped, do not change + ;; Ellipsis used to escape part of a template, i.e. (... escaped) + tmpl] ;; tmpl is fully escaped: do not change anything, pass the ... along [({~and self ??} a b c . rest) + ;; Extended ?? from syntax/parse with three or more cases (ds `(,#'stxparse:?? ,(recur #'a) ,(recur (ds `(,#'self ,#'b ,#'c . ,#'rest)))))] [(?? a b) + ;; ?? from syntax/parse with two cases (ds `(,#'stxparse:?? ,(recur #'a) ,(recur #'b)))] [(?? a) + ;; ?? from syntax/parse with a single case (implicit (?@) as the else case) (ds `(,#'stxparse:?? ,(recur #'a)))] [(?@ . args) + ;; ?@ from syntax/parse (ds `(,#'stxparse:?@ . ,(recur #'args)))] [({~var mf (static template-metafunction? "template metafunction")} . args) + ;; template metafunction from stxparse-info/parse (incompatible with + ;; syntax/parse's metafunctions until PR racket/racket#1591 is merged). (ds `(,#'mf . ,(recur #'args)))] [(hd :ooo ...+ . tl) + ;; (hd ... . tl), with one or more ellipses after hd (ds `(,(pre-parse-unsyntax #'hd (+ depth (stx-length #'(ooo …))) escapes @@ -112,9 +154,11 @@ ,@(syntax->list #'(ooo ...)) . ,(recur #'tl)))] [(hd . tl) + ;; (hd . tl) (ds `(,(recur #'hd) . ,(recur #'tl)))] [#(t …) - (ds (list->vector (stx-map recur #'(t …))))] + ;; #(t …) + (ds (vector->immutable-vector (list->vector (stx-map recur #'(t …)))))] ;; other ids, empty list, numbers, strings, chars, … [_ tmpl])) @@ -155,8 +199,8 @@ (define-syntax quasitemplate-ddd (*template-ddd #t #'quasitemplate)) (define-syntax quasisubtemplate-ddd (*template-ddd #t #'quasisubtemplate)) -(define-syntax template-ddd (*template-ddd #t #'template)) -(define-syntax subtemplate-ddd (*template-ddd #t #'subtemplate)) +(define-syntax template-ddd (*template-ddd #f #'template)) +(define-syntax subtemplate-ddd (*template-ddd #f #'subtemplate)) (define (stx-map*syntax->list e) (let loop ([l (syntax->list e)]) diff --git a/test/test-unsyntax2.rkt b/test/test-unsyntax2.rkt new file mode 100644 index 0000000..a394f16 --- /dev/null +++ b/test/test-unsyntax2.rkt @@ -0,0 +1,20 @@ +#lang racket +(require subtemplate/override + rackunit) + +(check-equal? (syntax->datum + (quasitemplate (a b #,(+ 1 1) c))) + '(a b 2 c)) + +(check-equal? (syntax->datum + (template (a b #,(+ 1 1) c))) + (let ([u 'unsyntax]) + `(a b (,u (+ 1 1)) c))) + +(check-equal? (syntax->datum + (quasitemplate (a b #,@(list (?@ 1 2) (?@ 3 4)) c))) + '(a b 1 2 3 4 c)) + +(check-equal? (syntax->datum + #`(a b #,@(list (?@ 1 2) (?@ 3 4)) c)) + '(a b 1 2 3 4 c))