#lang racket/base
(provide template-ddd
subtemplate-ddd
quasitemplate-ddd
quasisubtemplate-ddd)
(require (rename-in stxparse-info/parse/experimental/template
[?? stxparse:??]
[?@ stxparse:?@])
subtemplate/private/ddd-forms
subtemplate/private/template-subscripts
(only-in racket/base [... …])
stxparse-info/parse
stxparse-info/case
syntax/stx
racket/list
version-case
(for-syntax racket/base
racket/list
racket/syntax
stxparse-info/parse
(only-in racket/base [... …])
phc-toolkit/untyped))
(version-case
[(version< (version) "6.90.0.24")
(begin)]
[else
(require (only-in racket/private/template
[metafunction? template-metafunction?]))])
(define-for-syntax lifted (make-parameter #f))
(begin-for-syntax
(define-syntax-class qq
(pattern {~or {~literal stxparse:??} {~literal ??}}))
(define-syntax-class qa
(pattern {~or {~literal stxparse:?@} {~literal ?@}})))
(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
;; (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 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 ?if ?cond ?attr ?@@)
[({~and u unsyntax} (unquote e))
#:when (and (= escapes 0) quasi?)
;; full unsyntax with #,,e
(ds `(,#'u ,#'e))]
[({~and u unsyntax-splicing} (unquote e))
#:when (and (= escapes 0) quasi?)
;; full unsyntax-splicing with #,@,e
(ds `(,#'u ,#'e))]
[({~and u unsyntax} (unquote-splicing e))
#:when (and (= escapes 0) quasi?)
;; full unsyntax-splicing with #,,@e
(ds `(,(datum->syntax #'here 'unsyntax-splicing #'u) ,#'e))]
[({~and u unsyntax} e)
#:when (and (= escapes 0) quasi?)
;; ellipsis-preserving unsyntax with #,e
;; If we are nested at depth D, this lifts a syntax pattern variable
;; definition for (((tmp ...) ...) ...), with D levels of nesting.
;; It uses "begin" from subtemplate/private/ddd-forms to generate the
;; values for tmp succinctly. The template #'e is evaluated as many times
;; as necessary by "begin", each time stepping the variables under
;; ellipses.
(with-syntax ([tmp (generate-temporary #'e)]
[ooo* (map (λ (_) (quote-syntax …)) (range depth))])
;; The value returned by e is wrapped in a list via (splice-append e).
;; Normally, the list will contain a single element, unless e was a
;; splicing list, in which case it may contain multiple elements.
(lift! #`(begin (define/with-syntax tmp (splice-append e)) . ooo*))
;; Finally, tmp is inserted into the template (the current position is
;; under D levels of ellipses) using (?@) to destroy the wrapper list.
;; This allows #,(?@ 1 2 3) to be equivalent to #,@(list 1 2 3).
(ds `(,#'stxparse:?@ . ,(datum->syntax #'tmp #'tmp #'e))))]
[({~and u unsyntax-splicing} e)
;; ellipsis-preserving unsyntax-splicing with #,@e
;; This works in the same way as the #,e case just above…
#:when (and (= escapes 0) quasi?)
(with-syntax ([tmp (generate-temporary #'e)]
[ooo* (map (λ (_) (quote-syntax …)) (range depth))])
;; … with the notable difference that splice-append* is used instead of
;; splice-append.
(lift! #`(begin (define/with-syntax tmp (splice-append* e)) . ooo*))
(ds `(,#'stxparse:?@ . ,(datum->syntax #'tmp #'tmp #'e))))]
[({~and u {~or unsyntax unsyntax-splicing}} e)
;; Undo one level of protection, so that in #`#`#,x the inner #` adds one
;; level of escapement, and #, undoes that escapement.
;; Normally, escapes > 0 here (or quasi? is #false)
(ds `(,#'u ,(pre-parse-unsyntax #'e depth (sub1 escapes) quasi? form)))]
[(quasitemplate t . opts)
;; #`#`#,x does not unquote x, because it is nested within two levels of
;; quasitemplate. We reproduce this behaviour here.
(ds `(,#'quasitemplate
,(pre-parse-unsyntax #'t depth (add1 escapes) quasi? form)
. ,#'opts))]
[({~and self ?if} condition a b)
;; Special handling for the (?if condition a b) meta-operator
(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)
;; Special handling for the ?cond meta-operator, when the first case has
;; the shape [condition . v], but not [else . v]
(recur (ds `(,#'?if ,#'condition
,(ds `(,#'?@ . ,#'v))
,(ds `(,#'self . ,#'rest)))))]
[({~and self ?cond} [{~literal else}])
;; ?cond meta-operator, when the only case has the shape [else]
#'(stxparse:?@)]
[({~and self ?cond} [{~literal else} . v] . rest)
;; ?cond meta-operator, when the first case has the shape [else . v]
(recur (ds `(,#'?@ . ,#'v)))]
[({~and self ?@@} . e)
;; Special handling for the special (?@@ . e) meta-operator
(with-syntax ([tmp (generate-temporary #'self)]
[ooo* (map (λ (_) (quote-syntax …)) (range depth))])
(lift! #`(begin (define/with-syntax tmp
(append* (stx-map*syntax->list #,(form (recur #'e)))))
. ooo*))
#'(stxparse:?@ . tmp))]
[({~and self ?attr} condition)
;; Special handling for the special (?attr a) meta-operator
(recur (ds `(,#'?if ,#'condition
#t
#f)))]
[(:ooo t)
;; Ellipsis used to escape part of a template, i.e. (... escaped)
tmpl] ;; tmpl is fully escaped: do not change anything, pass the ... along
[(self:qq a b c . rest)
;; Extended ?? from syntax/parse with three or more cases
(ds `(,#'stxparse:?? ,(recur #'a)
,(recur (ds `(,#'self ,#'b ,#'c . ,#'rest)))))]
[(:qq a b)
;; ?? from syntax/parse with two cases
(ds `(,#'stxparse:?? ,(recur #'a) ,(recur #'b)))]
[(:qq a)
;; ?? from syntax/parse with a single case (implicit (?@) as the else case)
(ds `(,#'stxparse:?? ,(recur #'a)))]
[(:qa . args)
;; ?@ from syntax/parse
(ds `(,#'stxparse:?@ . ,(recur #'args)))]
[({~var mf (static template-metafunction? "template metafunction")} . args)
;; template metafunction from stxparse-info/parse (incompatible with
;; syntax/parse's metafunctions until PR racket/racket#1591 is merged).
(ds `(,#'mf . ,(recur #'args)))]
[(hd :ooo ...+ . tl)
;; (hd ... . tl), with one or more ellipses after hd
(ds `(,(pre-parse-unsyntax #'hd
(+ depth (stx-length #'(ooo …)))
escapes
quasi?
form)
,@(syntax->list #'(ooo ...))
. ,(recur #'tl)))]
[(hd . tl)
;; (hd . tl)
(ds `(,(recur #'hd) . ,(recur #'tl)))]
[#(t …)
;; #(t …)
(ds (vector->immutable-vector (list->vector (stx-map recur #'(t …)))))]
;; other ids, empty list, numbers, strings, chars, …
[_ tmpl]))
(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 quasi?
(λ (e) #`(#,form #,e . opts)))])
(if (null? (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 #f #'template))
(define-syntax subtemplate-ddd (*template-ddd #f #'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])))