commit e7e60b1da9696abc6eb9a4de4614cdc346e1f5dd
parent 74f38a3213310696922fe838f6822ac7d899f8ec
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Fri, 3 Feb 2017 11:54:40 +0100
More ?operations
Diffstat:
6 files changed, 210 insertions(+), 61 deletions(-)
diff --git a/ddd-forms.rkt b/ddd-forms.rkt
@@ -5,7 +5,11 @@
(rename-out [begin #%intef-begin])
(rename-out [app #%app])
??
+ ?if
+ ?cond
+ ?attr
?@
+ ?@@
splice-append
splice-append*
splicing-list?
@@ -94,8 +98,8 @@
(define-syntax/parse (begin stmt:stmt …)
(template (-begin (?@ stmt.expanded) …)))
-(define-syntax/parse (let ([var . val] …) . body)
- (template (-let ([var (begin . val)] …) (begin . body))))
+(define-syntax/parse (let {~optional name:id} ([var . val] …) . body)
+ (template (-let (?? name) ([var (begin . val)] …) (begin . body))))
(begin-for-syntax
(define-splicing-syntax-class arg
diff --git a/ddd.rkt b/ddd.rkt
@@ -1,6 +1,7 @@
#lang racket
-(provide ddd ?? ?@ splicing-list splicing-list-l splicing-list?)
+(provide ddd ?? ?if ?cond ?attr ?@ ?@@
+ splicing-list splicing-list-l splicing-list?)
(require stxparse-info/current-pvars
phc-toolkit/untyped
@@ -38,8 +39,8 @@
(if (syntax-local-value valvar (λ () #f)) ;; is it a macro-ish thing?
(begin
(log-warning
- (string-append "Could not extract the plain variable corresponding to"
- " the pattern variable or attribute ~a"
+ (string-append "Could not extract the plain variable corresponding"
+ " to the pattern variable or attribute ~a"
(syntax-e attr)))
#f)
valvar)))
@@ -54,7 +55,9 @@
(define/with-syntax expanded-body
(local-expand #`(let-values ()
- (quote-syntax #,(stx-map x-pvar-scope #'(pvar-real-valvar …)) #:local)
+ (quote-syntax #,(stx-map x-pvar-scope
+ #'(pvar-real-valvar …))
+ #:local)
body)
'expression
'()))
@@ -132,20 +135,24 @@
#;(define-syntax-rule (?@ v ...)
(splicing-list (list v ...)))
(define (?@ . vs) (splicing-list vs))
+(define (?@@ . vs) (map splicing-list vs))
-(define-syntax (?? stx)
+(define-for-syntax ((?* mode) stx)
(define (parse stx)
(syntax-case stx ()
- [(self a)
- (parse (datum->syntax stx `(,#'self ,#'a ,#'(?@)) stx stx))]
- [(_ a b)
+ [(self condition a)
+ (?* (datum->syntax stx `(,#'self ,#'c ,#'a ,#'(?@)) stx stx))]
+ [(_ condition 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-condition
+ (local-expand #'(detect-present-pvars (pvar …) condition)
+ 'expression
+ '()))
- (define present-variables (extract-present-variables #'expanded-a stx))
+ (define present-variables
+ (extract-present-variables #'expanded-condition stx))
(define/with-syntax (test-present-attribute …)
(for/list ([present? (in-list present-variables)]
@@ -154,13 +161,46 @@
;; only attributes can have missing elements.
#:when (eq? 'attr (car (attribute-info pv '(pvar attr)))))
#`(attribute* #,pv)))
-
-
- #'(if (and test-present-attribute …)
- a
+
+ #`(if (and test-present-attribute …)
+ #,(if (eq? mode 'if) #'a #'condition)
b))]))
(parse stx))
+(define-syntax ?if (?* 'if))
+
+(define-syntax (?cond stx)
+ (syntax-case stx (else)
+ [(self) #'(raise-syntax-error '?cond
+ "all branches contain omitted elements"
+ self)]
+ [(self [else]) #'(?@)]
+ [(self [else . v]) #'(begin . v)]
+ [(self [condition v . vs] . rest)
+ (not (free-identifier=? #'condition #'else))
+ (let ([else (datum->syntax stx `(,#'self . ,#'rest) stx stx)])
+ (datum->syntax stx
+ `(,#'?if ,#'condition ,#'(begin v . vs) . ,else)
+ stx
+ stx))]))
+
+(define-syntax (?attr stx)
+ (syntax-case stx ()
+ [(self condition)
+ (datum->syntax stx `(,#'?if ,#'condition #t #f) stx stx)]))
+
+(define-syntax (?? stx)
+ (define (parse stx)
+ (syntax-case stx ()
+ [(self a)
+ ((?* 'or) (datum->syntax stx `(,#'self ,#'a ,#'a ,#'(?@)) stx stx))]
+ [(self a b)
+ ((?* 'or) (datum->syntax stx `(,#'self ,#'a ,#'a ,#'b) stx stx))]
+ [(self a b c . rest)
+ (let ([else (datum->syntax stx `(,#'self ,#'b ,#'c . ,#'rest) stx stx)])
+ (datum->syntax stx `(,#'self ,#'a ,else) stx stx))]))
+ (parse stx))
+
(define-syntax/case (ddd body) ()
(define/with-syntax (pvar …) (current-pvars-shadowers))
diff --git a/test/test-optional.rkt b/test/test-optional.rkt
@@ -6,8 +6,6 @@
syntax/macro-testing
phc-toolkit/untyped)
-;; TODO: allow the overridden ?? and ?@ in template.
-
(check-equal? (syntax-parse #'(1 #:kw 3)
[({~and {~or x:nat #:kw}} …)
(?? x 'missing) …])
@@ -61,4 +59,4 @@
(check-equal? (syntax-parse #'(1 #:kw 3)
[({~and {~or x:nat #:kw}} …)
(list (?? (?@ 'x 'is x) (list 'nothing 'here)) ... 4 5)])
- '(x is 1 (nothing here) x is 3 4 5))
-\ No newline at end of file
+ '(x is 1 (nothing here) x is 3 4 5))
diff --git a/test/test-or.rkt b/test/test-or.rkt
@@ -0,0 +1,45 @@
+#lang racket
+
+(require subtemplate/ddd
+ subtemplate/unsyntax-preparse
+ stxparse-info/case
+ stxparse-info/parse
+ rackunit)
+
+(define (test-??-all v)
+ (syntax->datum
+ (syntax-parse v
+ [({~optional a:nat}
+ {~optional b:id}
+ {~optional c:boolean}
+ {~optional d:keyword})
+ (quasitemplate-ddd (?? a b c d))])))
+
+(check-equal? (test-??-all #'(1 x #f #:kw)) '1)
+(check-equal? (test-??-all #'(x #f #:kw)) 'x)
+(check-equal? (test-??-all #'(#f #:kw)) '#f)
+(check-equal? (test-??-all #'(#:kw)) '#:kw)
+
+(check-equal? (test-??-all #'(1)) '1)
+(check-equal? (test-??-all #'(x)) 'x)
+(check-equal? (test-??-all #'(#f)) '#f)
+(check-equal? (test-??-all #'(#:kw)) '#:kw)
+
+(define (test-?cond v)
+ (syntax->datum
+ (syntax-parse v
+ [({~optional a:nat}
+ {~optional b:id}
+ {~optional c:boolean}
+ {~optional d:keyword})
+ (quasitemplate-ddd (?cond [a 10] [b 20] [c 30] [d 40]))])))
+
+(check-equal? (test-?cond #'(1 x #f #:kw)) 10)
+(check-equal? (test-?cond #'(x #f #:kw)) 20)
+(check-equal? (test-?cond #'(#f #:kw)) 30)
+(check-equal? (test-?cond #'(#:kw)) 40)
+
+(check-equal? (test-?cond #'(1)) 10)
+(check-equal? (test-?cond #'(x)) 20)
+(check-equal? (test-?cond #'(#f)) 30)
+(check-equal? (test-?cond #'(#:kw)) 40)
diff --git a/test/test-splice.rkt b/test/test-splice.rkt
@@ -1,13 +1,12 @@
#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
+(require subtemplate/ddd-forms
+ rackunit)
+
+(check-equal? (let ([l '(4 5 6)])
+ (vector (?@ 1 2 3 . l)))
+ #(1 2 3 4 5 6))
+
+(check-equal? (let ([l '(4 5 6)])
+ (vector (?@ 1 2 3 (?@ . l) 7 8 9)))
+ #(1 2 3 4 5 6 7 8 9))
+\ No newline at end of file
diff --git a/unsyntax-preparse.rkt b/unsyntax-preparse.rkt
@@ -11,6 +11,7 @@
(only-in racket/base [... …])
stxparse-info/parse
stxparse-info/case
+ syntax/stx
(for-syntax racket/base
racket/list
racket/syntax
@@ -20,7 +21,7 @@
(define-for-syntax lifted (make-parameter #f))
-(define-for-syntax (pre-parse-unsyntax tmpl depth escapes)
+(define-for-syntax (pre-parse-unsyntax tmpl depth escapes quasi? form)
;; TODO: a nested quasisubtemplate should escape an unsyntax!
(define (ds e)
;; TODO: should preserve the shape of the original stx
@@ -28,13 +29,12 @@
(datum->syntax tmpl e tmpl tmpl))
(define-syntax-class ooo
(pattern {~and ooo {~literal ...}}))
- (define (recur t) (pre-parse-unsyntax t depth escapes))
+ (define (recur t) (pre-parse-unsyntax t depth escapes quasi? form))
(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]
+ quasitemplate ?? ?if ?cond ?attr ?@ ?@@)
[({~and u unsyntax} (unquote e)) ;; full unquote with #,,
(ds `(,#'u ,#'e))]
[({~and u unsyntax-splicing} (unquote e)) ;; full unquote with #,@,
@@ -42,59 +42,122 @@
[({~and u unsyntax} (unquote-splicing e)) ;; full unquote with #,,@
(ds `(,(datum->syntax #'here 'unsyntax-splicing #'u) ,#'e))]
[({~and u unsyntax} e)
- #:when (= escapes 0)
+ #:when (and (= escapes 0) quasi?)
(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)
+ #:when (and (= escapes 0) quasi?)
(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))))]
+ ;; when escapes ≠ 0 (or quasi? is #false)
+ (ds `(,#'u ,(pre-parse-unsyntax e depth (sub1 escapes) quasi? form)))]
[(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)))]
+ (ds `(,#'quasitemplate
+ ,(pre-parse-unsyntax #'t depth (add1 escapes) quasi? form)
+ . ,#'opts))]
+ [({~and self ?if} condition a b)
+ (with-syntax ([tmp (generate-temporary #'self)]
+ [ooo* (map (λ (_) (quote-syntax …)) (range depth))])
+ (lift! #`(begin (define/with-syntax tmp (?if #,(form (recur #'condition))
+ #,(form (recur #'(a)))
+ #,(form (recur #'(b)))))
+ . ooo*))
+ #'(stxparse:?@ . tmp))]
+ [({~and self ?cond} [{~and condition {~not {~literal else}}} . v] . rest)
+ (recur (ds `(,#'?if ,#'condition
+ ,(ds `(,#'?@ . ,#'v))
+ ,(ds `(,#'self . ,#'rest)))))]
+ [({~and self ?cond} [{~literal else}] . rest)
+ #'(stxparse:?@)]
+ [({~and self ?cond} [{~literal else} . v] . rest)
+ (recur #'(?@ . v))]
+ [({~and self ?@@} . e)
+ (with-syntax ([tmp (generate-temporary #'self)]
+ [ooo* (map (λ (_) (quote-syntax …)) (range depth))])
+ (lift! #`(begin (define/with-syntax tmp
+ (append* (stx-map*syntax->list #,(form #'e))))
+ . ooo*))
+ #'(stxparse:?@ . tmp))]
+ [({~and self ?attr} condition)
+ (recur (ds `(,#'?if ,#'condition
+ #t
+ #f)))]
[(:ooo t)
tmpl] ;; fully escaped, do not change
- [(?? . args)
- (ds `(,#'stxparse:?? . ,(recur #'args)))]
+ [({~and self ??} a b c . rest)
+ (ds `(,#'stxparse:?? ,(recur #'a)
+ ,(recur (ds `(,#'self ,#'b ,#'c . ,#'rest)))))]
+ [(?? a b)
+ (ds `(,#'stxparse:?? ,(recur #'a) ,(recur #'b)))]
+ [(?? a)
+ (ds `(,#'stxparse:?? ,(recur #'a)))]
[(?@ . args)
(ds `(,#'stxparse:?@ . ,(recur #'args)))]
+ [({~var mf (static template-metafunction? "template metafunction")} . args)
+ (ds `(,#'mf . ,(recur #'args)))]
[(hd :ooo ...+ . tl)
- (ds `(,(pre-parse-unsyntax #'hd (+ depth (stx-length #'(ooo …))) escapes)
+ (ds `(,(pre-parse-unsyntax #'hd
+ (+ depth (stx-length #'(ooo …)))
+ escapes
+ quasi?
+ form)
,@(syntax->list #'(ooo ...))
. ,(recur #'tl)))]
[(hd . tl)
(ds `(,(recur #'hd) . ,(recur #'tl)))]
[#(t …)
(ds (list->vector (stx-map recur #'(t …))))]
- [()
- tmpl]))
+ ;; other ids, empty list, numbers, strings, chars, …
+ [_ tmpl]))
-(define-for-syntax ((quasi*template-ddd form) stx)
+(define (check-single-result result stx form)
+ (unless (and (stx-pair? result) (stx-null? (stx-cdr result)))
+ (raise-syntax-error form
+ (string-append "the outer ?@ in the template produced"
+ " more than one syntax object")
+ stx))
+ (stx-car result))
+
+(define-for-syntax ((*template-ddd quasi? form) stx)
(syntax-case stx ()
[(_ tmpl . opts)
(parameterize ([lifted (box '())])
- (let ([new-tmpl (pre-parse-unsyntax #'tmpl 0 0)])
+ (let ([new-tmpl (pre-parse-unsyntax #'tmpl 0 0 quasi?
+ (λ (e) #`(#,form #,e . opts)))])
(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))))))]))
+ ((λ (~)
+ ;(local-require racket/pretty)
+ ;(pretty-write (syntax->datum ~))
+ ~)
+ (quasisyntax/top-loc stx
+ (let-values ()
+ #,@(reverse (unbox (lifted)))
+ (define result
+ #,(datum->syntax stx
+ `(,form (,new-tmpl) . ,#'opts)
+ stx
+ stx))
+ (check-single-result result (quote-syntax stx) 'form)))))))]))
+
+(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 quasitemplate-ddd (quasi*template-ddd #'quasitemplate))
-(define-syntax quasisubtemplate-ddd (quasi*template-ddd #'quasisubtemplate))
+(define (stx-map*syntax->list e)
+ (let loop ([l (syntax->list e)])
+ (cond
+ [(null? l) l]
+ [(pair? l) (cons (syntax->list (car l)) (loop (cdr l)))]
+ ;; Special treatment for the last element of e: it does not need to
+ ;; be a list (as long as ?@ is used in tail position).
+ [else l])))
+\ No newline at end of file
