suzanne.soy/subtemplate
1
0
Fork 0
Code Issues 2 Pull Requests Actions Packages Projects Releases Wiki Activity

More ?operations

Browse Source
This commit is contained in:
Georges Dupéron 2017-02-03 11:54:40 +01:00
parent 74f38a3213
commit e7e60b1da9
6 changed files with 208 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
ddd-forms.rkt
View File

@ -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

70
ddd.rkt
View File

@ -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))

4
test/test-optional.rkt
View File

@ -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))
'(x is 1 (nothing here) x is 3 4 5))

45
test/test-or.rkt Normal file
View File

@ -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)

21
test/test-splice.rkt
View File

@ -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 [... …]))
(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))

119
unsyntax-preparse.rkt
View File

@ -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 (quasi*template-ddd #'quasitemplate))
(define-syntax quasisubtemplate-ddd (quasi*template-ddd #'quasisubtemplate))
(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 (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])))