add define/freevar

from syntax-objects/Summer2021#24

cc @shhyou

define-freevar/define-freevar-test.rkt

@@ -0,0 +1,66 @@
+#lang racket/base
+(module+ test
+  (require rackunit syntax-parse-example/define-freevar/define-freevar)
+
+  (test-case "who-error"
+    (define/freevar (raise-who-error message source-stx)
+      #:freevars (who)
+      (raise-syntax-error who
+                          message
+                          source-stx))
+    (check-exn #rx"knock-knock: who"
+      (lambda ()
+        (let ([who 'knock-knock])
+          (raise-who-error "who's there" #'door)))))
+
+  (test-case "fib-immediate"
+    (define/freevar (fib n)
+      #:freevars (init0 init1)
+      #:immediate
+      (for/fold ([a init0]
+                 [b init1]
+                 [fib-list '()]
+                 #:result (reverse fib-list))
+                ([i (in-range n)])
+        (values b (+ a b) (cons a fib-list))))
+
+    (define init0 2)
+
+    (check-pred
+      procedure?
+      (let ([init1 13])
+        fib))            ;; <- The #:immediate flag makes a difference
+
+    (check-equal?
+      ;; init0 shadows the global definition
+      ;;=> '(0 1 1 2 3 5 8 ...)
+      (let ([init0 0]
+            [init1 1])
+        (fib 10))
+      '(0 1 1 2 3 5 8 13 21 34))
+
+    (check-equal?
+      ;; The free variable init1 is renamed to b
+      (with-freevar fib ([init1 b])
+        (define b 4)
+        (fib 10))
+      '(2 4 6 10 16 26 42 68 110 178))
+
+    (check-equal?
+      ;; Another renaming example. Free variables do not have bindings.
+      (let ([b 5])
+        (with-freevar fib ([init1 b])
+          (fib 10)))
+      '(2 5 7 12 19 31 50 81 131 212))
+
+    ;; Define a new open term, fib-same, with free variables renamed from fib.
+    (define/with-freevar fib-same fib
+      [init0 S]
+      [init1 S])
+
+    (check-equal?
+      (let ([S 3])
+        (fib-same 10))
+      '(3 3 6 9 15 24 39 63 102 165)))
+
+)

define-freevar/define-freevar.rkt

@@ -0,0 +1,138 @@
+#lang racket/base
+
+(provide define/freevar
+         with-freevar
+         define/with-freevar)
+
+(require (for-syntax racket/base
+                     racket/list
+                     racket/syntax
+                     syntax/parse))
+
+(define-syntax (define/freevar stx)
+  (syntax-parse stx
+    [(_ (name:id arg:id ...)
+        #:freevars (fv:id ...+)
+        (~optional (~and #:immediate immediate-flag))
+        body:expr ...+)
+     #:attr dup-id (or (check-duplicate-identifier (syntax-e #'(fv ... arg ...)))
+                       (cdr (check-duplicates
+                             (map cons (syntax->datum #'(fv ...)) (syntax-e #'(fv ...)))
+                             #:key car
+                             #:default '(#f . #f))))
+     #:do [(when (attribute dup-id)
+             (raise-syntax-error 'define/freevar
+                                 "duplicated argument or free variable name"
+                                 stx
+                                 (attribute dup-id)))]
+     #:with name-with-fvs (format-id #'fresh-stx "~a/fvs" #'name)
+     #:with immediate? (if (attribute immediate-flag) #t #f)
+     #`(begin
+         (define name-with-fvs
+           #,(cond
+               [(attribute immediate-flag)
+                #`(λ (fv ...)
+                    (let ([name #,(syntax/loc stx
+                                    (λ (arg ...) body ...))])
+                      name))]
+               [else
+                #`(let ([name #,(syntax/loc stx
+                                  (λ (fv ... arg ...) body ...))])
+                    name)]))
+         (define-syntax name
+           (open-term #'name-with-fvs
+                      '(fv ...)
+                      '(arg ...)
+                      'immediate?)))]))
+
+(define-syntax (with-freevar stx)
+  (syntax-parse stx
+    [(_ term-with-fv:id ([fv:id new-fv:id] ...) body:expr ...+)
+     (syntax-property
+      (syntax/loc stx
+        (let-syntax ([term-with-fv
+                      (open-term-set-freevars 'with-freevar
+                                              #'term-with-fv
+                                              (hash (~@ 'fv 'new-fv) ...))])
+          body ...))
+      'disappeared-use (list (syntax-local-introduce #'term-with-fv)))]))
+
+(define-syntax (define/with-freevar stx)
+  (syntax-parse stx
+    [(_ new-name:id original-term-with-fv:id [fv:id new-fv:id] ...)
+     (syntax-property
+      (syntax/loc stx
+        (define-syntax new-name
+          (open-term-set-freevars 'with-freevar
+                                  #'original-term-with-fv
+                                  (hash (~@ 'fv 'new-fv) ...))))
+      'disappeared-use (list (syntax-local-introduce #'original-term-with-fv)))]))
+
+(begin-for-syntax
+  (struct open-term (proc-stx freevars-name args-name immediate?)
+    #:property prop:procedure (λ (self stx) (link-freevars self stx)))
+
+  (define (freevars-in-context fvs #:context ctxt #:source src)
+    (for/list ([fv (in-list fvs)])
+      (syntax-property
+       (format-id ctxt "~a" fv #:source src)
+       'original-for-check-syntax #t)))
+
+  (define (link-freevars self stx)
+    (define/syntax-parse target (open-term-proc-stx self))
+    (syntax-parse stx
+      [proc-src:id
+       #:with (fv ...) (freevars-in-context (open-term-freevars-name self)
+                                            #:context stx
+                                            #:source #'proc-src)
+       #:with (arg ...) (generate-temporaries (open-term-args-name self))
+       (cond
+         [(open-term-immediate? self)
+          (fix-app stx
+                   (syntax/loc stx
+                     (target fv ...)))]
+         [else
+          (quasisyntax/loc stx
+            (λ (arg ...)
+              #,(fix-app stx
+                         (syntax/loc stx
+                           (target fv ... arg ...)))))])]
+      [(proc-src:id . args)
+       #:with (fv ...) (freevars-in-context (open-term-freevars-name self)
+                                            #:context stx
+                                            #:source #'proc-src)
+       (cond
+         [(open-term-immediate? self)
+          (fix-app stx
+                   (quasisyntax/loc stx
+                     (#,(fix-app stx
+                                 (syntax/loc stx
+                                   (target fv ...)))
+                      . args)))]
+         [else
+          (fix-app stx
+                   (syntax/loc stx
+                     (target fv ... . args)))])]))
+
+  (define (fix-app ctxt app-stx)
+    (define app-datum (syntax-e app-stx))
+    (datum->syntax ctxt app-datum app-stx app-stx))
+
+  (define (open-term-set-freevars who open-term-id map)
+    (define (fail)
+      (raise-syntax-error who
+                          "the binding is not defined by define/freevar"
+                          open-term-id))
+    (define self
+      (syntax-local-value open-term-id fail))
+    (unless (open-term? self)
+      (fail))
+    (define original-fvs (open-term-freevars-name self))
+    (define new-fvs
+      (for/list ([fv (in-list original-fvs)])
+        (hash-ref map fv (λ () fv))))
+    (open-term (open-term-proc-stx self)
+               new-fvs
+               (open-term-args-name self)
+               (open-term-immediate? self))))
+

define-freevar/define-freevar.scrbl

@@ -0,0 +1,129 @@
+#lang syntax-parse-example
+@require[
+  (for-label racket/base syntax/parse syntax-parse-example/define-freevar/define-freevar)]
+
+@(define define-freevar-eval
+   (make-base-eval '(require syntax-parse-example/define-freevar/define-freevar)))
+
+@title{Functions with Dynamically-Scoped Parameters}
+@stxbee2021["shhyou" 24]
+
+@; =============================================================================
+
+@defmodule[syntax-parse-example/define-freevar/define-freevar]{}
+
+@defform[(define/freevar (function-id arg-id ...)
+  #:freevars (freevar1-id freevar2-id ...)
+  body1-expr body2-expr ...)
+]{
+  The @racket[define/freevar] macro introduces function
+  definitions with free variables in their body.
+  The free variables are resolved non-hygienically to any
+  bindings of an equal symbol name at each use site.
+
+  One motivating example is the following helper function for Redex models:
+
+  @examples[#:label #f #:eval define-freevar-eval
+    (require racket/pretty redex/reduction-semantics)
+    (define/freevar (apply-reduction-relation*--> term)
+      #:freevars (-->R)
+      (pretty-print term)
+      (for/fold ([term-list (list (list #f term))])
+                ([step (in-naturals)]
+                 #:break (null? term-list))
+        (define new-terms
+          (apply-reduction-relation/tag-with-names -->R (list-ref (car term-list) 1)))
+        (pretty-print new-terms)
+        new-terms))
+  ]
+
+  This second example dynamically looks for a value @racket[_who] to format an
+  error message:
+
+  @examples[#:label #f #:eval define-freevar-eval
+    (define/freevar (raise-who-error message source-stx)
+      #:freevars (who)
+      (raise-syntax-error who
+                          message
+                          source-stx))
+    (eval:error
+      (let ([who 'knock-knock])
+        (raise-who-error "who's there" #'door)))
+  ]
+
+  Conceptually, the @racket[define/freevar] form expands into a new definition
+  having the original code and a new macro that generates references for
+  the free variables:
+
+  @racketblock[
+    (define (raise-who-error/impl who message source-stx)
+      (raise-syntax-error who
+                          message
+                          source-stx))
+
+    (define-syntax (raise-who-error stx)
+      (syntax-parse stx
+        [(proc-src:id args ...)
+         #:with who/use-site (syntax-property
+                              (format-id stx "~a" 'who #:source #'proc-src)
+                              'original-for-check-syntax #t)
+         (syntax/loc stx
+           (raise-who-error/impl who/use-site args ...))]))
+  ]
+
+  The new macro @racket[_raise-who-error] creates a reference, @racket[_who/use-site],
+  to be captured non-hygienically using the context from the use site.
+  The expansion then proceeds with the use-site reference and calls
+  the original code.
+
+  Additionally, the use-site references have the source location of the
+  @racket[_proc-src] identifier and the syntax property @racket['original-for-check-syntax]
+  so that Check Syntax and DrRacket can draw the binding arrows.
+
+  Caveat: mutation on the free variables will not reflect on the original
+  binding. This restriction can be overcome using @racket[make-set!-transformer].
+
+}
+
+@defform[(with-freevar function-id ([freevar-id new-freevar-id] ...)
+  body-expr1 body-expr2 ...) ]{
+  Locally renames the free variables for @racket[define/freevar] definitions.
+}
+@defform[(define/with-freevar new-function-id old-function-id
+  [freevar-id new-freevar-id]
+  ...)]{
+  Definition form of @racket[with-freevar].
+}
+
+@section{Implementation}
+
+While the idea is straightforward, a direct translation generates a large
+amount of code duplication. In the output of @racket[define/freevar], the only
+varying parts are the names of the free variables and the identifier
+of the actual implementation. The implementation of @racket[define/freevar]
+thus follows the common pattern of using a struct to share the transformer code.
+
+@itemlist[#:style 'ordered
+  @item{
+    The @racket[define/freevar] form expands to a new definition storing the
+    original code and a macro for binding the free identifiers.
+  }
+  @item{
+    The implementation introduces a procedure-like struct, @racket[_open-term],
+    that holds the list of free variables and the identifier of
+    the actual code.
+  }
+  @item{
+    When the macro expander applies an instance of @racket[_open-term], it
+    extracts names of the free variables and redirects the reference to the
+    actual code.
+  }
+]
+
+The idea behind custom @tech/syntax{pattern expanders} and syntax class aliases
+(see @racket[prop:syntax-class]) are related:
+using structs to store varying information while attaching struct type
+properties to assign behavior.
+
+  @racketfile{define-freevar.rkt}
+

index.scrbl

@@ -29,3 +29,4 @@
 @include-example{syntax-class-contract}
 @include-example{except-in-quiet}
 @include-example{dot-underscore}
+@include-example{define-freevar}