From ad97ade07130973607e4ccb03611cd7b8d1ef52f Mon Sep 17 00:00:00 2001
From: AlexKnauth <alexander@knauth.org>
Date: Sat, 16 Feb 2019 11:53:15 -0500
Subject: [PATCH] allow prop:template-metafunction value to be a function

---
 .../scribblings/parse/experimental.scrbl      | 16 ++++++---
 .../tests/stxparse/test-template.rkt          | 15 +++++++-
 .../private/prop-template-metafunction.rkt    | 34 +++++++++++++------
 3 files changed, 48 insertions(+), 17 deletions(-)

diff --git a/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl b/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl
index 003893f567..f261ddad74 100644
--- a/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl
+++ b/pkgs/racket-doc/syntax/scribblings/parse/experimental.scrbl
@@ -351,11 +351,17 @@ invalid binding list.
  ((defthing prop:template-metafunction struct-type-property?)
   (defthing template-metafunction? (-> any/c boolean?)))]{
 
- A structure type property, and the associated predicate. 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.
+ A structure type property, and the associated predicate. The property value is
+ one of:
+
+ @itemlist[
+   @item{an identifier bound to a run-time metafunction}
+   @item{the index of a field containing such an an identifier}
+   @item{a procedure that takes an instance of the structure and produces
+         such an identifier}]
+
+ The identifier's 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
diff --git a/pkgs/racket-test/tests/stxparse/test-template.rkt b/pkgs/racket-test/tests/stxparse/test-template.rkt
index 43745990f5..2361a4dd5f 100644
--- a/pkgs/racket-test/tests/stxparse/test-template.rkt
+++ b/pkgs/racket-test/tests/stxparse/test-template.rkt
@@ -128,4 +128,17 @@
   (define-syntax mf5 (my-template-metafunction5))
   
   (check-equal? (syntax->datum (template (x (mf5 3) z)))
-                '(x 6 z)))
\ No newline at end of file
+                '(x 6 z)))
+
+(begin-for-syntax
+  (struct my-template-metafunction6 (proc-id)
+    #:property prop:template-metafunction
+    (lambda (self) (my-template-metafunction6-proc-id self))))
+(test-case "use custom prop:template-metafunction with a function"
+  (define (myproc6 stx)
+    (syntax-case stx ()
+      [(_ n) #`#,(* 2 (syntax-e #'n))]))
+  (define-syntax mf6 (my-template-metafunction6 (quote-syntax myproc6)))
+  
+  (check-equal? (syntax->datum (template (x (mf6 3) z)))
+                '(x 6 z)))
diff --git a/racket/collects/racket/private/prop-template-metafunction.rkt b/racket/collects/racket/private/prop-template-metafunction.rkt
index c163b0124a..78fd877292 100644
--- a/racket/collects/racket/private/prop-template-metafunction.rkt
+++ b/racket/collects/racket/private/prop-template-metafunction.rkt
@@ -4,13 +4,20 @@
                       (rename prop:template-metafunction? template-metafunction?)
                       template-metafunction-accessor))
   
-  ;; The prop:template-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.
+  ;; The prop:template-metafunction structure type property can contain one of:
+  ;;  - an identifier bound to the run-time metafunction procedure
+  ;;  - the index of a field containing such an identifier
+  ;;  - a function that takes the structure instance and produces 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.
-  
+
+  ;; Internally, the value inside the property will be stored as a function
+  ;; that takes the structure instance and produces the identifier,
+  ;; so the first two cases of that `one-of` will be "normalized" to the
+  ;; function case by `prop:template-metafunction-guard`.
+
   (define-values (prop:template-metafunction-guard)
     (lambda (val struct-type-info-list)
       (if (exact-nonnegative-integer? val)
@@ -36,13 +43,18 @@
           (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:template-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)))))
+              ;; Otherwise, expect a function of one argument
+              (if
+               (if (procedure? val) (procedure-arity-includes? val 1) #f)
+               val
+               ;; Otherwise, raise an error.
+               (raise-argument-error
+                'prop:template-metafunction-guard
+                (string-append "an identifier, or an exact non-negative integer designating"
+                               " a field index within the structure that should contain an"
+                               " identifier, or a procedure of one argument that produces"
+                               " an identifier")
+                val))))))
   
   (define-values (prop:template-metafunction
                   prop:template-metafunction?