diff --git a/cross-phase-splicing-list.rkt b/cross-phase-splicing-list.rkt new file mode 100644 index 0000000..246867c --- /dev/null +++ b/cross-phase-splicing-list.rkt @@ -0,0 +1,26 @@ +(module cross-phase-splicing-list '#%kernel + (#%declare #:cross-phase-persistent) + (#%provide struct:splicing-list + splicing-list + splicing-list? + splicing-list-l) + (define-values (struct:splicing-list + splicing-list + splicing-list? + splicing-list-ref + _splicing-list-set!) + (#%app make-struct-type + 'splicing-list ;; name + #f ;; super + 1 ;; fields + 0 ;; auto fields + #f ;; auto value + '() ;; props + #f ;; inspector + #f ;; proc-spec + (cons 0 '()) ;; immutables + #f ;; guard + 'splicing-list)) ;; constructor-name + (define-values (splicing-list-l) + (lambda (instance) + (splicing-list-ref instance 0)))) \ No newline at end of file diff --git a/ddd-forms.rkt b/ddd-forms.rkt index 58e7487..87f02fa 100644 --- a/ddd-forms.rkt +++ b/ddd-forms.rkt @@ -5,7 +5,12 @@ (rename-out [begin #%intef-begin]) (rename-out [app #%app]) ?? - ?@) + ?@ + splice-append + splice-append* + splicing-list? + splicing-list + splicing-list-l) (require racket/list subtemplate/ddd @@ -98,30 +103,31 @@ #:with expanded #`(splicing-list #,(ddd* e ooo*))) (pattern other ;#:with expanded #'(#%app list other) - #:with expanded #'other))) + #:with expanded #'other)) + (define-syntax-class not-stx-pair + (pattern {~not (_ . _)}))) (define-syntax app (syntax-parser - #;[(_ fn {~and arg {~not {~literal …}}} …) ;; TODO: check for ?@ too - #'(#%app fn arg …)] - [{~and (_ fn arg:arg …) + [{~and (_ fn arg:arg … #;.rest:not-stx-pair) {~not (_ _ {~literal …} . _)}} ;; not fn directly followed by a … ;#'(#%app apply fn (#%app append arg.expanded …)) (syntax/top-loc this-syntax - (#%app apply fn (#%app splice-append arg.expanded …)))] - [(_ arg:arg …) ;; shorthand for list creation + (#%app apply fn (#%app splice-append arg.expanded … #;#:rest #;rest)))] + [(_ arg:arg … #;.rest:not-stx-pair) ;; shorthand for list creation ;#'(#%app apply list (#%app append arg.expanded …)) (syntax/top-loc this-syntax - (#%app apply list (#%app splice-append arg.expanded …)))])) + (#%app apply list (#%app splice-append arg.expanded … #;#:rest #;rest)))])) -(define (splice-append . l*) (splice-append* l*)) +(define (splice-append #:rest [rest '()] . l*) + (splice-append* (if (null? rest) l* (append l* rest)))) (define (splice-append* l*) (cond [(pair? l*) (if (splicing-list? (car l*)) - (append (splice-append* (splicing-list-l (car l*))) - (splice-append* (cdr l*))) + (splice-append* (append (splicing-list-l (car l*)) + (cdr l*))) (cons (car l*) (splice-append* (cdr l*))))] [(splicing-list? l*) - (splicing-list-l l*)] + (splice-append* (splicing-list-l l*))] [else ;; should be null. l*])) \ No newline at end of file diff --git a/ddd.rkt b/ddd.rkt index 5facdcb..2ca8ba9 100644 --- a/ddd.rkt +++ b/ddd.rkt @@ -125,32 +125,41 @@ (define present-variables (map syntax-e present-variables*)) present-variables) -(struct splicing-list (l)) +;(struct splicing-list (l) #:transparent) +(require "cross-phase-splicing-list.rkt") + ;; TODO: dotted rest, identifier macro #;(define-syntax-rule (?@ v ...) (splicing-list (list v ...))) -(define ?@ (compose splicing-list list)) +(define (?@ . vs) (splicing-list vs)) -(define-syntax/case (?? a b) () - (define/with-syntax (pvar …) (current-pvars-shadowers)) +(define-syntax (?? stx) + (define (parse stx) + (syntax-case stx () + [(self a) + (parse (datum->syntax stx `(,#'self ,#'a ,#'(?@)) stx stx))] + [(_ a b) + (let () + (define/with-syntax (pvar …) (current-pvars-shadowers)) - (define/with-syntax expanded-a - (local-expand #'(detect-present-pvars (pvar …) a) 'expression '())) + (define/with-syntax expanded-a + (local-expand #'(detect-present-pvars (pvar …) a) 'expression '())) - (define present-variables (extract-present-variables #'expanded-a stx)) + (define present-variables (extract-present-variables #'expanded-a stx)) - (define/with-syntax (test-present-attribute …) - (for/list ([present? (in-list present-variables)] - [pv (in-syntax #'(pvar …))] - #:when present? - ;; only attributes can have missing elements. - #:when (eq? 'attr (car (attribute-info pv '(pvar attr))))) - #`(attribute* #,pv))) + (define/with-syntax (test-present-attribute …) + (for/list ([present? (in-list present-variables)] + [pv (in-syntax #'(pvar …))] + #:when present? + ;; only attributes can have missing elements. + #:when (eq? 'attr (car (attribute-info pv '(pvar attr))))) + #`(attribute* #,pv))) - #'(if (and test-present-attribute …) - a - b)) + #'(if (and test-present-attribute …) + a + b))])) + (parse stx)) (define-syntax/case (ddd body) () (define/with-syntax (pvar …) (current-pvars-shadowers)) diff --git a/info.rkt b/info.rkt index 5c45faa..ba24575 100644 --- a/info.rkt +++ b/info.rkt @@ -11,6 +11,6 @@ (define build-deps '("scribble-lib" "racket-doc")) (define scribblings '(("scribblings/subtemplate.scrbl" () (parsing-library)))) -(define pkg-desc "Description Here") -(define version "0.0") +(define pkg-desc "Various enhancements on syntax templates") +(define version "1.0") (define pkg-authors '("Georges Dupéron")) diff --git a/template-subscripts.rkt b/template-subscripts.rkt index e981e68..6482003 100644 --- a/template-subscripts.rkt +++ b/template-subscripts.rkt @@ -123,7 +123,7 @@ (unless (attribute force-no-stxinfo) (for ([sym (in-list '(syntax-parse define/syntax-parse syntax-parser syntax-case define/with-syntax with-syntax))]) - (let ([shadower (syntax-local-get-shadower (datum->syntax #'self sym))] + (let ([shadower (datum->syntax #'self sym)];syntax-local-get-shadower ? [good (datum->syntax #'here sym)]) (when (or (not (identifier-binding shadower)) (not (free-identifier=? shadower good))) diff --git a/test/assumption-weak-hash.rkt b/test/assumption-weak-hash.rkt index 06a57bb..42e8393 100644 --- a/test/assumption-weak-hash.rkt +++ b/test/assumption-weak-hash.rkt @@ -1,5 +1,9 @@ #lang racket +;; We use a weak hash to associate a pvar xᵢ with its the values contained in +;; the derived yᵢ. The assumptions below must hold, otherwise we would risk +;; memory leaks. + (require (for-syntax racket/private/sc) rackunit) diff --git a/test/test-ddd-top.rkt b/test/test-ddd-top.rkt index 756efca..6e0bf8c 100644 --- a/test/test-ddd-top.rkt +++ b/test/test-ddd-top.rkt @@ -10,10 +10,10 @@ phc-toolkit/untyped (only-in racket/base [... …])) -#;(check-equal? (syntax-parse #'(a b c) - [(xᵢ …) - yᵢ]) - '(a/y b/y c/y)) +(check-equal? (syntax-parse #'(a b c) + [(xᵢ …) + yᵢ]) + '(a/y b/y c/y)) (check-equal? (syntax-case #'(a b c) () [(xᵢ …) diff --git a/test/test-splice-append.rkt b/test/test-splice-append.rkt new file mode 100644 index 0000000..ae38555 --- /dev/null +++ b/test/test-splice-append.rkt @@ -0,0 +1,22 @@ +#lang racket/base +(require (only-in subtemplate/ddd-forms + splicing-list + splice-append + splice-append*) + rackunit) + +(define (mk . vs) (splicing-list vs)) + +(check-equal? (splice-append* '(1 2 3)) '(1 2 3)) +(check-equal? (splice-append* (mk 1 2 3)) '(1 2 3)) +(check-equal? (splice-append* (mk (mk 1 2 3))) '(1 2 3)) +(check-equal? (splice-append* (mk (mk (mk 1 2 3)))) '(1 2 3)) +(check-equal? (splice-append* (mk -1 (mk 0 (mk 1 2 3) 4 5) 6 7)) + '(-1 0 1 2 3 4 5 6 7)) + +(check-equal? (splice-append '(1 2 3)) '((1 2 3))) +(check-equal? (splice-append (mk 1 2 3)) '(1 2 3)) +(check-equal? (splice-append (mk (mk 1 2 3))) '(1 2 3)) +(check-equal? (splice-append (mk (mk (mk 1 2 3)))) '(1 2 3)) +(check-equal? (splice-append (mk -1 (mk 0 (mk 1 2 3) 4 5) 6 7)) + '(-1 0 1 2 3 4 5 6 7)) \ No newline at end of file diff --git a/test/test-splice.rkt b/test/test-splice.rkt new file mode 100644 index 0000000..5ea123a --- /dev/null +++ b/test/test-splice.rkt @@ -0,0 +1,13 @@ +#lang racket + +(require subtemplate/top-subscripts + subtemplate/ddd-forms + subtemplate/unsyntax-preparse + subtemplate/template-subscripts + (except-in subtemplate/override ?? ?@) + stxparse-info/case + stxparse-info/parse + rackunit + syntax/macro-testing + phc-toolkit/untyped + (only-in racket/base [... …])) \ No newline at end of file diff --git a/test/test-unsyntax.rkt b/test/test-unsyntax.rkt new file mode 100644 index 0000000..1e69787 --- /dev/null +++ b/test/test-unsyntax.rkt @@ -0,0 +1,75 @@ +#lang racket/base + +(require subtemplate/top-subscripts + subtemplate/ddd-forms + subtemplate/unsyntax-preparse + subtemplate/template-subscripts + (except-in subtemplate/override ?? ?@) + stxparse-info/case + stxparse-info/parse + rackunit + syntax/macro-testing + phc-toolkit/untyped + (only-in racket/base [... …])) + +(check-equal? (syntax->datum + (syntax-parse #'(1 2 3) + [(x …) + (quasisubtemplate-ddd (x …))])) + '(1 2 3)) + +(check-equal? (syntax->datum + (syntax-case #'(1 2 3) () + [(x …) + (quasisubtemplate-ddd (#,(+ x 4) …))])) + '(5 6 7)) + +(check-equal? (syntax->datum + (syntax-case #'(1 2 3) () + [(x …) + (quasisubtemplate-ddd (a b c))])) + '(a b c)) + +(check-equal? (syntax->datum + (syntax-case #'(1 2 3) () + [(xᵢ …) + (quasisubtemplate-ddd (#,(cons yᵢ (+ xᵢ 4)) …))])) + '([1/y . 5] [2/y . 6] [3/y . 7])) + +(check-equal? (syntax->datum + (syntax-case #'(1 2 3) () + [(xᵢ …) + (quasisubtemplate-ddd (#,@(list yᵢ (+ xᵢ 4)) …))])) + '(1/y 5 2/y 6 3/y 7)) + +(check-equal? (syntax->datum + (syntax-case #'(1 2 3) () + [(xᵢ …) + (quasisubtemplate-ddd (#,(?@ yᵢ (+ xᵢ 4)) …))])) + '(1/y 5 2/y 6 3/y 7)) + +(check-equal? (syntax->datum + (syntax-parse #'([1 2 3] [a #:kw c]) + [([xᵢ …] [{~and {~or zᵢ:id #:kw}} …]) + (quasisubtemplate-ddd (#,(?? #'zᵢ (?@ #'yᵢ (+ xᵢ 4))) …))])) + '(a 2/y 6 c)) + +(check-equal? (syntax->datum + (syntax-case #'([1 2 3] [4 5 6]) () + [([x …] …) + (quasisubtemplate-ddd ((#,(- x) …) …))])) + '((-1 -2 -3) (-4 -5 -6))) + +(check-equal? (syntax->datum + (syntax-case #'([1 2 3] [4 5 6]) () + [([x …] …) + (quasisubtemplate-ddd (([#,(- x) #,,x] …) …))])) + (let ([l '((1 2 3) (4 5 6))]) + `(([-1 ,l] [-2 ,l] [-3 ,l]) ([-4 ,l] [-5 ,l] [-6 ,l])))) + +(check-equal? (syntax->datum + (syntax-case #'([1 2 3] [4 5 6]) () + [([x …] …) + (quasisubtemplate-ddd (([#,(- x) #,,@x] …) …))])) + (let ([l '((1 2 3) (4 5 6))]) + `(([-1 ,@l] [-2 ,@l] [-3 ,@l]) ([-4 ,@l] [-5 ,@l] [-6 ,@l])))) \ No newline at end of file diff --git a/unsyntax-preparse.rkt b/unsyntax-preparse.rkt new file mode 100644 index 0000000..53e4bf6 --- /dev/null +++ b/unsyntax-preparse.rkt @@ -0,0 +1,100 @@ +#lang racket/base + +(provide quasitemplate-ddd + quasisubtemplate-ddd) + +(require (rename-in stxparse-info/parse/experimental/template + [?? stxparse:??] + [?@ stxparse:?@]) + subtemplate/ddd-forms + subtemplate/template-subscripts + (only-in racket/base [... …]) + stxparse-info/parse + stxparse-info/case + (for-syntax racket/base + racket/list + racket/syntax + stxparse-info/parse + (only-in racket/base [... …]) + phc-toolkit/untyped)) + +(define-for-syntax lifted (make-parameter #f)) + +(define-for-syntax (pre-parse-unsyntax tmpl depth escapes) + ;; TODO: a nested quasisubtemplate should escape an unsyntax! + (define (ds e) + ;; TODO: should preserve the shape of the original stx + ;; (syntax list vs syntax pair) + (datum->syntax tmpl e tmpl tmpl)) + (define-syntax-class ooo + (pattern {~and ooo {~literal ...}})) + (define (recur t) (pre-parse-unsyntax t depth escapes)) + (define (stx-length stx) (length (syntax->list stx))) + (define (lift! e) (set-box! (lifted) (cons e (unbox (lifted))))) + (syntax-parse tmpl + #:literals (unsyntax unsyntax-splicing unquote unquote-splicing + quasitemplate ?? ?@) + [:id tmpl] + [({~and u unsyntax} (unquote e)) ;; full unquote with #,, + (ds `(,#'u ,#'e))] + [({~and u unsyntax-splicing} (unquote e)) ;; full unquote with #,@, + (ds `(,#'u ,#'e))] + [({~and u unsyntax} (unquote-splicing e)) ;; full unquote with #,,@ + (ds `(,(datum->syntax #'here 'unsyntax-splicing #'u) ,#'e))] + [({~and u unsyntax} e) + #:when (= escapes 0) + (with-syntax ([tmp (generate-temporary #'e)] + [ooo* (map (λ (_) (quote-syntax …)) (range depth))]) + (lift! #`(begin (define/with-syntax tmp (splice-append e)) . ooo*)) + (ds `(,#'stxparse:?@ . ,(datum->syntax #'tmp #'tmp #'e))))] + [({~and u unsyntax-splicing} e) + #:when (= escapes 0) + (with-syntax ([tmp (generate-temporary #'e)] + [ooo* (map (λ (_) (quote-syntax …)) (range depth))]) + (lift! #`(begin (define/with-syntax tmp (splice-append* e)) . ooo*)) + #'(stxparse:?@ . tmp))] + [({~and u {~or unsyntax unsyntax-splicing}} e) + ;; when escapes ≠ 0 + (ds `(,#'u ,(pre-parse-unsyntax e depth (sub1 escapes))))] + [(quasitemplate t . opts) + (ds `(,#'quasitemplate ,(pre-parse-unsyntax #'t depth (add1 escapes)) + . ,#'opts))] + [({~var mf (static template-metafunction? "template metafunction")} . args) + (ds `(,#'mf . ,(recur #'args)))] + [(:ooo t) + tmpl] ;; fully escaped, do not change + [(?? . args) + (ds `(,#'stxparse:?? . ,(recur #'args)))] + [(?@ . args) + (ds `(,#'stxparse:?@ . ,(recur #'args)))] + [(hd :ooo ...+ . tl) + (ds `(,(pre-parse-unsyntax #'hd (+ depth (stx-length #'(ooo …))) escapes) + ,@(syntax->list #'(ooo ...)) + . ,(recur #'tl)))] + [(hd . tl) + (ds `(,(recur #'hd) . ,(recur #'tl)))] + [#(t …) + (ds (list->vector (stx-map recur #'(t …))))] + [() + tmpl])) + +(define-for-syntax ((quasi*template-ddd form) stx) + (syntax-case stx () + [(_ tmpl . opts) + (parameterize ([lifted (box '())]) + (let ([new-tmpl (pre-parse-unsyntax #'tmpl 0 0)]) + (if (null? (unbox (lifted))) + (datum->syntax stx + `(,form ,new-tmpl . ,#'opts) + stx + stx) + (quasisyntax/top-loc stx + (let-values () + #,@(unbox (lifted)) + #,(datum->syntax stx + `(,form ,new-tmpl . ,#'opts) + stx + stx))))))])) + +(define-syntax quasitemplate-ddd (quasi*template-ddd #'quasitemplate)) +(define-syntax quasisubtemplate-ddd (quasi*template-ddd #'quasisubtemplate))