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

Implements and provides prop:template-metafunction

Browse Source
This commit is contained in:
Georges Dupéron 2017-01-24 23:23:36 +01:00 committed by Suzanne Soy
parent cb959879de
commit f6eee5eb33
4 changed files with 172 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl
View File

@ -347,4 +347,37 @@ the context above; instead, @racket[let-values] would report an
invalid binding list.
}
@deftogether[
((defthing prop:template-metafunction struct-type-property?)
(defthing template-metafunction? (-> any/c boolean?))
(defthing template-metafunction-accessor (-> template-metafunction? identifier?)))]{
A structure type property, and the associated predicate and accessor. The
property value is either an identifier, or the index of a field containing an
identifier. The identifier should be bound to the run-time metafunction. The
run-time metafunction should accept a syntax object representing its use, and
produce a new syntax object as a result.
When an identifier is bound as syntax to a structure instance with this
property, it is treated as a template metafunction as if the identifier had
been declared with define-template-metafunction.
@examples[#:eval the-eval
(define (my-metafunction-proc stx)
(syntax-case stx ()
[(_ n) (datum->syntax #'n (add1 (syntax-e #'n)))]))
(begin-for-syntax
(struct mf-struct (proc-id)
#:property prop:template-metafunction
(struct-field-index proc-id)))
(define-syntax mf (mf-struct #'my-metafunction-proc))
(template (mf 3))
(with-syntax ([(x ...) #'(1 2 3)])
(template ((mf x) ...)))]
@history[#:added 6.9]}
@(close-eval the-eval)

63
pkgs/racket-test/tests/stxparse/test-template.rkt
View File

@ -66,3 +66,66 @@
(terx (template (bad-mf))
#rx"result of template metafunction was not syntax")
;; ============================================================
;; Test prop:template-metafunction and template-metafunction?
(define-syntax (is-metafunction? stx)
(syntax-case stx ()
[(_ id)
#`#,(template-metafunction? (syntax-local-value #'id))]))
(test-case "template-metafunction? on define-template-metafunction"
(define-template-metafunction (mf1 stx)
#'1)
(check-true (is-metafunction? mf1)))
(begin-for-syntax
(struct my-template-metafunction2 (proc-id)
#:property prop:template-metafunction (struct-field-index proc-id)))
(test-case
"template-metafunction? on custom prop:template-metafunction with field"
(define (myproc2 stx) #'2)
(define-syntax mf2 (my-template-metafunction2 (quote-syntax myproc2)))
(check-true (is-metafunction? mf2)))
;; must be before the definition of my-template-metafunction3
(define (myproc3 stx) #'3)
;; must be outside of the (test-case …) form
(begin-for-syntax
(struct my-template-metafunction3 ()
#:property prop:template-metafunction (quote-syntax myproc3)))
(test-case "template-metafunction? on custom prop:template-metafunction with id"
(define-syntax mf3 (my-template-metafunction3))
(check-true (is-metafunction? mf3)))
(begin-for-syntax
(struct my-template-metafunction4 (proc-id)
#:property prop:template-metafunction (struct-field-index proc-id)))
(test-case "use custom prop:template-metafunction with field"
(define (myproc4 stx)
(syntax-case stx ()
[(_ n) #`#,(add1 (syntax-e #'n))]))
(define-syntax mf4 (my-template-metafunction4 (quote-syntax myproc4)))
(check-equal? (syntax->datum (template (x (mf4 3) z)))
'(x 4 z)))
;; must be before the definition of my-template-metafunction5
(define (myproc5 stx)
(syntax-case stx ()
[(_ n) #`#,(* (syntax-e #'n) 2)]))
;; must be outside of the (test-case …) form
(begin-for-syntax
(struct my-template-metafunction5 ()
#:property prop:template-metafunction (quote-syntax myproc5)))
(test-case "use custom prop:template-metafunction with id"
(define-syntax mf5 (my-template-metafunction5))
(check-equal? (syntax->datum (template (x (mf5 3) z)))
'(x 6 z)))

69
racket/collects/racket/private/prop-template-metafunction.rkt Normal file
View File

@ -0,0 +1,69 @@
(module prop-template-metafunction '#%kernel
(#%provide (protect metafunction
prop:metafunction
(rename prop:metafunction? metafunction?)
metafunction-accessor))
;; The prop:metafunction structure type property can contain an
;; identifier bound to the run-time metafunction procedure, or the index of a
;; field containing such an identifier.
;; At run-time, when processing the template, the syntax object whose first
;; element is a metafunction identifiers is passed to this metafunction
;; procedure.
(define-values (prop:metafunction-guard)
(lambda (val struct-type-info-list)
(if (exact-nonnegative-integer? val)
;; Field index, the field must contain an identifier bound to the run-time
;; metafunction procedure.
(let-values ([(make-struct-accessor) (cadddr struct-type-info-list)])
(let-values ([(accessor) (make-struct-field-accessor make-struct-accessor val)])
(λ (instance)
(let-values ([(metafunction-internal-id) (accessor instance)])
;; Check that the value contained in the field is correct
;; (if (identifier? metafunction-internal-id) ...)
(if (if (syntax? metafunction-internal-id)
(symbol? (syntax-e metafunction-internal-id))
#f)
metafunction-internal-id
(raise-argument-error
'prop:metafunction-guard
(format (string-append "the value of the ~a-th field should be"
" an identifier")
val)
metafunction-internal-id))))))
;;(if (identifier? val)
(if (if (syntax? val) (symbol? (syntax-e val)) #f)
;; Identifier bound to the run-time metafunction procedure.
(λ (_instance) val)
;; Otherwise, raise an error.
(raise-argument-error
'prop:metafunction-guard
(string-append "an identifier, or an exact non-negative integer designating"
" a field index within the structure that should contain an"
" identifier.")
val)))))
(define-values (prop:metafunction
prop:metafunction?
metafunction-raw-accessor)
(make-struct-type-property 'metafunction
prop:metafunction-guard))
(define-values (metafunction-accessor)
(lambda (instance . more-args)
(let-values ([(raw) (if (null? more-args) ;; no failure-result given
(metafunction-raw-accessor instance)
(if (null? (cdr more-args))
(let-values ([(failure-result) (car more-args)])
(metafunction-raw-accessor instance failure-result))
(error "invalid number of arguments [TODO]")))])
(raw instance))))
;; A default struct type with prop:metafunction.
;; (struct template-metafunction (proc-id)
;; #:property prop:template-metafunction (struct-field-index proc-id))
(define-values (struct:metafunction metafunction metafunction? metafunction-ref _mf-set!)
(make-struct-type 'syntax-metafunction #f 1 0 #f
(list (cons prop:metafunction 0))
(current-inspector))))

15
racket/collects/racket/private/template.rkt
View File

@ -4,6 +4,7 @@
(rename "define-et-al.rkt" define-syntax -define-syntax)
"ellipses.rkt"
(for-syntax "stx.rkt" "define-et-al.rkt" "qq-and-or.rkt" "cond.rkt"
"prop-template-metafunction.rkt"
(rename "define-et-al.rkt" define -define)
(rename "define-et-al.rkt" define-syntax -define-syntax)
#;"member.rkt" "sc.rkt" '#%kernel))
@ -12,14 +13,17 @@
datum
~? ~@
~@! signal-absent-pvar
(for-syntax prop:metafunction
metafunction
metafunction-accessor
metafunction?)
(protect
(for-syntax attribute-mapping
attribute-mapping?
attribute-mapping-name
attribute-mapping-var
attribute-mapping-depth
attribute-mapping-check
metafunction metafunction?)))
attribute-mapping-check)))
;; ============================================================
;; Syntax of templates
@ -111,11 +115,6 @@
(define (attribute-mapping-depth a) (attribute-mapping-ref a 2))
(define (attribute-mapping-check a) (attribute-mapping-ref a 3))
;; (struct metafunction (var))
(define-values (struct:metafunction metafunction metafunction? metafunction-ref _mf-set!)
(make-struct-type 'syntax-metafunction #f 1 0 #f null (current-inspector)))
(define (metafunction-var mf) (metafunction-ref mf 0))
(define (guide-is? x tag) (and (pair? x) (eq? (car x) tag)))
(define (ht-guide? x) (guide-is? x 'h-t))
@ -275,7 +274,7 @@
(unless stx? (wrong-syntax (stx-car t) "metafunctions are not supported"))
(disappeared! (stx-car t))
(define guide (parse-t (stx-cdr t) depth esc?))
`(t-metafun ,(metafunction-var mf) ,guide
`(t-metafun ,(metafunction-accessor mf) ,guide
(quote-syntax
,(let ([tstx (and (syntax? t) t)])
(datum->syntax tstx (cons (stx-car t) #f) tstx tstx)))))]