diff --git a/info.rkt b/info.rkt index 005b712..da42862 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.1") +(define version "1.2") (define pkg-authors '("Georges Dupéron")) diff --git a/private/ddd-forms.rkt b/private/ddd-forms.rkt index 647f213..d280ac7 100644 --- a/private/ddd-forms.rkt +++ b/private/ddd-forms.rkt @@ -20,10 +20,20 @@ stxparse-info/case stxparse-info/parse phc-toolkit/untyped + subtemplate/private/copy-attribute + (for-meta -2 subtemplate/private/syntax-case-as-syntax-parse) + (for-meta -1 subtemplate/private/syntax-case-as-syntax-parse) + (for-meta 0 subtemplate/private/syntax-case-as-syntax-parse) + (for-meta 1 subtemplate/private/syntax-case-as-syntax-parse) + (for-meta 2 subtemplate/private/syntax-case-as-syntax-parse) + (for-meta 3 subtemplate/private/syntax-case-as-syntax-parse) (prefix-in - (only-in racket/base begin let lambda define)) (prefix-in - (only-in stxparse-info/case define/with-syntax)) + (prefix-in - (only-in stxparse-info/parse + define/syntax-parse + syntax-parse)) (for-syntax racket/base racket/list stxparse-info/parse @@ -34,20 +44,24 @@ (for-meta 2 stxparse-info/parse)) (begin-for-syntax - (define (-nest* before after -v -ooo* [depth 0]) + (define (-nest* wrapper -v -ooo* [depth 0]) (if (stx-null? -ooo*) -v - (-nest* before - after - #`(#,@(syntax->list before) #,-v . #,after) + (-nest* wrapper + (wrapper -v) (stx-cdr -ooo*) (add1 depth)))) (define-syntax nest* (syntax-parser - [(self (before … {~datum %} . after) v ooo*) - (with-syntax ([s (datum->syntax #'self 'syntax)]) - #'(-nest* (s ((… …) (before …))) (s ((… …) after)) (s v) (s ooo*)))])) + [(self wrapper-stx v ooo*) + (with-syntax ([s (datum->syntax #'self 'syntax)] + [qs (datum->syntax #'self 'quasisyntax)]) + #`(-nest* (λ (new-v) + (with-syntax ([#,(datum->syntax #'self '%) new-v]) + (qs wrapper-stx))) + (s v) + (s ooo*)))])) (define-syntax ddd* (syntax-parser @@ -79,15 +93,22 @@ (pattern (:not-macro-id . _))) (define-splicing-syntax-class stmt - #:literals (define define/with-syntax) + #:literals (define define/with-syntax -define/syntax-parse) (pattern {~seq (define name:id e:expr) :ooo+} #:with expanded #`(-define name #,(nest* (ddd %) e ooo*))) (pattern {~seq (define/with-syntax pat e:expr) :ooo+} #:with expanded - #`(-define/with-syntax #,(nest* (% …) pat ooo*) - #,(nest* (ddd %) e ooo*))) + #`(-define/syntax-parse + #,(nest* (… {~and {~or (% …) #f}}) ({~syntax-case pat}) ooo*) + #,(nest* (ddd % #:allow-missing) (list e) ooo*))) + (pattern {~seq (-define/syntax-parse pat e:expr) :ooo+} + ;; Same as above, except that pat is not wrapped with ~syntax-case. + #:with expanded + #`(-define/syntax-parse + #,(nest* (… {~and {~or (% …) #f}}) (pat) ooo*) + #,(nest* (ddd % #:allow-missing) (list e) ooo*))) (pattern {~seq e :ooo+} ;#:with expanded #`(apply values #,(ddd* e ooo*)) #:with expanded #`(splicing-list #,(ddd* e ooo*))) diff --git a/private/ddd.rkt b/private/ddd.rkt index 58a18dd..dd1d488 100644 --- a/private/ddd.rkt +++ b/private/ddd.rkt @@ -1,5 +1,9 @@ #lang racket +;; Implementation of the (ddd e) macro, which iterates e over the syntax pattern +;; variables present in e. e should contain at least one syntax pattern variable +;; which is under ellipses. + (provide ddd ?? ?if ?cond ?attr ?@ ?@@ splicing-list splicing-list-l splicing-list?) @@ -93,17 +97,43 @@ #t (apply = vs))) -(define (map#f* f attr-ids l*) - (for ([l (in-list l*)] - [attr-id (in-list attr-ids)]) - (when (eq? l #f) - (raise-syntax-error (syntax-e attr-id) - "attribute contains an omitted element" - attr-id))) - (unless (apply =* (map length l*)) - (raise-syntax-error 'ddd - "incompatible ellipis counts for template")) - (apply map f l*)) +;; map, with extra checks for missing elements (i.e. when one of the l* lists +;; is #f). If allow-missing? is specified, each #f list is replaced by +;; a stream of #f values. If all l* lists are #f, then there is no way to know +;; the number of iterations to make, so #f is returned (indicating that the +;; whole sequence is missing, instead of being merely empty. +(define (map#f* allow-missing? f attr-ids l*) + (if allow-missing? + (let () + (define non-#f-l* (filter identity l*)) + (unless (apply =* (map length non-#f-l*)) + (raise-syntax-error 'ddd + "incompatible ellipis counts for template")) + (if (= (length non-#f-l*) 0) + ;; If all lists are missing (#f), return a single #f value, indicating + ;; that there are no elements to create the result list from. + #f + ;; Or should we use this? + ;(apply f (map (const #f) l*)) + ;; i.e. just call the function once with every variable bound to #f, + ;; i.e. missing. + + ;; replace the missing (#f) lists with a list of N #f values, where N + ;; is the length of the other lists. + (let* ([repeated-#f (map (const #f) (car non-#f-l*))] + [l*/repeated-#f (map (λ (l) (or l repeated-#f)) l*)]) + (apply map f l*/repeated-#f)))) + (let () + (for ([l (in-list l*)] + [attr-id (in-list attr-ids)]) + (when (eq? l #f) + (raise-syntax-error (syntax-e attr-id) + "attribute contains an omitted element" + attr-id))) + (unless (apply =* (map length l*)) + (raise-syntax-error 'ddd + "incompatible ellipis counts for template")) + (apply map f l*)))) (define-for-syntax (current-pvars-shadowers) @@ -259,7 +289,9 @@ ;;; extract-present-variables can find it. ;;; In effect, this is semantically equivalent to lifting the problematic ;;; pvar outside of the body. -(define-syntax/case (ddd body) () +(define-syntax/case (ddd body . tail) () + (define/with-syntax allow-missing? + (syntax-case #'tail () [() #'#f] [(#:allow-missing) #'#t])) (define/with-syntax (pvar …) (current-pvars-shadowers)) (define-temp-ids "~aᵢ" (pvar …)) @@ -314,7 +346,8 @@ [(presence-info #f pv pvᵢ #f _) #'#f]) present?+pvars))) - #'(map#f* (λ (iterated-pvarᵢ … lifted-key …) + #'(map#f* allow-missing? + (λ (iterated-pvarᵢ … lifted-key …) (expanded-f filling-pvar … (make-hash (list (cons 'lifted-key lifted-key) …)))) (list (quote-syntax iterated-pvar) … diff --git a/private/find-defined-pvars.rkt b/private/find-defined-pvars.rkt new file mode 100644 index 0000000..c1f7dc9 --- /dev/null +++ b/private/find-defined-pvars.rkt @@ -0,0 +1,46 @@ +#lang racket +;; This module is an experiment to extract the pattern variables defined by a +;; define/with-syntax form (it could easily be made to work with +;; define/syntax-parse too). Ti relies on inspecting current-pvars before and +;; after the define/with-syntax form. In order to be able to access the updated +;; current-pvars, the macro needs to call a second macro which gets expanded +;; after the define/with-syntax. + +(require stxparse-info/parse + stxparse-info/case) +(require stxparse-info/current-pvars + (for-syntax racket/list)) + +(define-syntax (continue stx) + (syntax-case stx () + [(_ old-pvars-stx) + (let () + (define old-pvars (syntax->list #'old-pvars-stx)) + (define now-pvars (current-pvars)) + (define-values (new-pvars rest-pvars) + (split-at now-pvars (- (length now-pvars) (length old-pvars)))) + (unless (andmap free-identifier=? old-pvars rest-pvars) + (log-error + (string-append "Internal error: The tail of current-pvars changed" + " between two calls.\n" + " Before: ~a\n" + " After: ~a\n" + " New items: ~a" + old-pvars + rest-pvars + new-pvars))) + + (displayln old-pvars) + (displayln new-pvars) + #'(begin))])) + +(define-syntax (find-defined-pvars stx) + (syntax-case stx () + [(_ pat val) + #`(begin + (define/with-syntax pat val) + (continue #,(current-pvars)))])) + +(define/with-syntax (a . b) #'(1 2)) +(find-defined-pvars (x . y) #'(3 4)) +(define/with-syntax (c . d) #'(5 6)) \ No newline at end of file diff --git a/private/syntax-case-as-syntax-parse.rkt b/private/syntax-case-as-syntax-parse.rkt new file mode 100644 index 0000000..cf9c4fa --- /dev/null +++ b/private/syntax-case-as-syntax-parse.rkt @@ -0,0 +1,65 @@ +#lang racket/base +(provide ~syntax-case ~syntax-case-stat) +(require syntax/parse + (for-syntax racket/base)) +(define-for-syntax (~syntax-case-impl not-stat? stx) + (with-syntax ([(_ stx1) stx]) + (define (id=? a b) (and (identifier? a) + (free-identifier=? a b))) + (define (ds e [ctx #'stx1]) + (datum->syntax ctx e ctx ctx)) + (define (ds2 sym [locprop #'stx1]) + (datum->syntax #'here sym locprop locprop)) + (define (sc e) + (datum->syntax #'here `{~syntax-case ,e} e e)) + (define (process-sequence stx2) + (syntax-case stx2 () + [(pat ooo . rest) + (and (id=? #'ooo (quote-syntax ...)) not-stat?) + `(,{sc #'pat} ,#'ooo . ,(process-sequence #'rest))] + [(pat . rest) + `(,{sc #'pat} . ,(process-sequence #'rest))] + [() + stx2])) + (syntax-case #'stx1 () + [underscore (and (id=? #'underscore #'_) not-stat?) + #'underscore] + [id (identifier? #'id) + (ds `{,{ds2 '~var #'id} ,#'id})] + [(ooo stat) (and (id=? #'ooo (quote-syntax ...)) not-stat?) + {ds + `(,{ds2 '~syntax-case-stat #'ooo} + ,#'stat)}] + [(pat ooo . rest) (and (id=? #'ooo (quote-syntax ...)) not-stat?) + (ds `(,{sc #'pat} ,#'ooo . ,{sc #'rest}))] + [(pat . rest) (ds `(,{sc #'pat} . ,{sc #'rest}))] + [() #'stx1] + [#(pat ...) + (ds (vector->immutable-vector + (list->vector + (process-sequence #'(pat ...)))))] + [#&pat + (ds (box-immutable (sc #'pat)))] + [p + (prefab-struct-key (syntax-e #'p)) + (ds (make-prefab-struct + (prefab-struct-key (syntax-e #'p)) + (process-sequence + (cdr (vector->list (struct->vector (syntax-e #'p)))))))] + [other + (ds `{,(ds2 '~datum #'other) ,#'other})]))) + +#;(syntax-case (quote-syntax #s(a b c d)) () + [#s(a ... bb) #'bb] + [(... #s(a ... b)) 'y]) + +(define-syntax ~syntax-case + (pattern-expander (λ (stx) (~syntax-case-impl #t stx)))) +(define-syntax ~syntax-case-stat + (pattern-expander (λ (stx) (~syntax-case-impl #f stx)))) + +#;(syntax-parse #'(1 2 3) + [{~syntax-case (~var ... ~and)} + (displayln (attribute ~var)) + (displayln (attribute ~and)) + ]) \ No newline at end of file diff --git a/scribblings/subtemplate.scrbl b/scribblings/subtemplate.scrbl index a852d68..83ca417 100644 --- a/scribblings/subtemplate.scrbl +++ b/scribblings/subtemplate.scrbl @@ -96,15 +96,15 @@ with @racketmodname[syntax/parse] and @|orig:syntax-case|. @${m - 1} levels in the result list). It is also possible to nest the use of these ellipses, e.g. with @racket[(x ...) ...], which keeps the structure of the nested lists in the result.} - @item{When a definition form (@racket[define] or @racket[define/with-syntax] - for now) is followed by @${n} ellipses, then the defined identifier is a - @${\text{nested}^n} list, or a syntax pattern variable with an ellipsis - depth of @${n}. The expression is evaluated for each value of the template - variables it contains. Note that the structure of the nested lists is not - flattened, despite the fact that the ellipses are written one after - another. This is because it is usually the desired outcome, and nesting - parentheses around the definition form would produce rather unreadable - code.} + @item{When a definition form (@racket[define], @racket[define/with-syntax] or + @racket[define/syntax-parse] for now) is followed by @${n} ellipses, then + the defined identifier is a @${\text{nested}^n} list, or a syntax pattern + variable with an ellipsis depth of @${n}. The expression is evaluated for + each value of the template variables it contains. Note that the structure + of the nested lists is not flattened, despite the fact that the ellipses + are written one after another. This is because it is usually the desired + outcome, and nesting parentheses around the definition form would produce + rather unreadable code.} @item{These ellipses can also be used ``inline'' within function calls (@racketmodname[subtemplate] overrides @racket[#%app] to achieve this). For example: @racket[(/ (+ x ...) (length x))] would compute the average of @@ -250,10 +250,17 @@ to their equivalents from this library, and without @orig:template/loc] and @defform[(begin body ...)]{ Overridden version of @|orig:begin|. Supports ellipses after definitions - (using @racket[define] and @racket[define-syntax]). Supports ellipses after - expressions, in which case the results are grouped into a splicing list, which - makes it possible to write @racket[(+ (begin x ...))] and obtain the same - result as with @racket[(+ x ...)].} + (using @racket[define], @racket[define/with-syntax] or + @racket[define/syntax-parse]). Supports ellipses after expressions, in which + case the results are grouped into a splicing list, which makes it possible to + write @racket[(+ (begin x ...))] and obtain the same result as with + @racket[(+ x ...)]. + + @history[ + #:changed "1.2" + @elem{Added support @racket[define/syntax-parse], fixed documentation which + incorrectly claimed support for @racket[define-syntax] instead of + @racket[define/with-syntax]}]} @defform*[[(let ([var val] …) . body) (let name ([var val] …) . body)]]{ diff --git a/test/test-missing-nested.rkt b/test/test-missing-nested.rkt new file mode 100644 index 0000000..1761663 --- /dev/null +++ b/test/test-missing-nested.rkt @@ -0,0 +1,60 @@ +#lang racket +(require subtemplate/override + rackunit) + +(check-equal? (syntax-parse #'((yy 1 2) #:kw (yyy 3 4)) + [({~and {~or (y x …) :keyword}} …) + (syntax->datum + (quasitemplate + (0 #,(list (quasitemplate + (?? (~~~ + y + #,(list x) ... + ~~~) + oops))) + ... 9)))]) + '(0 ((~~~ yy (1) (2) ~~~)) (oops) ((~~~ yyy (3) (4) ~~~)) 9)) + +(check-equal? + (syntax-parse #'((y a b 3 d 5 f) #:kw (z g 8 i) #:kww) + [({~and {~or (y {~and {~or x:id _}} …) :keyword}} …) + (syntax->datum + (quasitemplate + (0 #,(list (quasitemplate + (?? (~~~ + y + #,(list (template (?? x -)) (template (?? x -))) ... + ~~~) + oops))) + ... 9)))]) + '(0 + ((~~~ y (a a) (b b) (- -) (d d) (- -) (f f) ~~~)) + (oops) + ((~~~ z (g g) (- -) (i i) ~~~)) + (oops) + 9)) + +(check-equal? (syntax-parse #'((yy 1 2) #:kw (yyy 3 4)) + [({~and {~or (y x …) :keyword}} …) + (list (?? (list y (?? x '-) …) 'oops) …)]) + '((yy 1 2) oops (yyy 3 4))) + +(check-equal? (syntax-parse #'((y a b 3 d 5 f) #:kw (z g 8 i) #:kww) + [({~and {~or (y {~and {~or x:id _}} …) :keyword}} …) + (list (?? (list y (?? x '-) …) 'oops) …)]) + '((y a b - d - f) oops (z g - i) oops)) + +(check-exn + #rx"attribute contains an omitted element" + (λ () + (syntax-parse #'((y a b 3 d 5 f) #:kw (z g 8 i) #:kww) + [({~and {~or (y {~and {~or x:id _}} …) :keyword}} …) + (list (?? x '-) … …)]))) + +(check-exn + #rx"attribute contains an omitted element" + (λ () + (syntax-parse #'((y a b 3 d 5 f) #:kw (z g 8 i) #:kww) + [({~and {~or (y {~and {~or x:id _}} …) :keyword}} …) + (define l (?if y (?? x '-) 'oops)) … … + l]))) \ No newline at end of file diff --git a/test/test-use-before-definition.rkt b/test/test-use-before-definition.rkt new file mode 100644 index 0000000..c9e3b91 --- /dev/null +++ b/test/test-use-before-definition.rkt @@ -0,0 +1,19 @@ +#lang racket +(require subtemplate/override + rackunit) + +;; f is defined after xᵢ +(check-equal? + (let () + (define/with-syntax (xᵢ …) #'(a b c)) + (define (f) (list zᵢ ... (syntax->datum (subtemplate (yᵢ …))))) + (f)) + '(a/z b/z c/z (a/y b/y c/y))) + +;; f is defined before xᵢ (still works, yay!) +(check-equal? + (let () + (define (f) (list zᵢ ... (syntax->datum (subtemplate (yᵢ …))))) + (define/with-syntax (xᵢ …) #'(a b c)) + (f)) + '(a/z b/z c/z (a/y b/y c/y))) \ No newline at end of file