commit a0df96cb3a501e59e3f109a85e9c63a744536b4c
parent 208ad3e3218fe7ce1878f8efce2864d79600cd68
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Fri, 3 Feb 2017 08:18:21 +0100
Closes FB case 178 Attempt to allow escaping (template …) but keep the current nesting of ellipses
Diffstat:
11 files changed, 295 insertions(+), 36 deletions(-)
diff --git a/cross-phase-splicing-list.rkt 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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))
