Macro

Overview

In this example, the 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.

(define/freevar (function-id arg-id ...)
  #:freevars (freevar1-id freevar2-id ...)
  body1-expr body2-expr ...)

In conjunction with define/freevars, the with-freevar macro
locally renames the free variables for definitions introduced
using define/freevars.

(with-freevar function-id ([freevar-id new-freevar-id] ...)
  body-expr1 body-expr2 ...)

There is also the define counterpart of with-freevar:

(define/with-freevar new-function-id old-function-id
  [freevar-id new-freevar-id]
  ...)

Idea

The idea is transforming the original definition into a lambda function
that accepts the free variables and generating a new macro
which inserts the unhygienic references for the free variables at each
use site.

Here is an example illustrating the idea. The function raise-who-error
raises a syntax error and uses whichever binding named who
available as the name of the error message.

(define/freevar (raise-who-error message source-stx)
  #:freevars (who)
  (raise-syntax-error who
                      message
                      source-stx))
(let ([who 'knock-knock])
  (raise-who-error "who's there" #'door))

Conceptually, thedefine/freevar form expands into a new definition
having the original code and a new macro for generating references of
the free variables:

(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 raise-who-error creates a reference, 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
proc-src and the syntax property 'original-for-check-syntax
so Check Syntax and DrRacket can draw the binding arrows.

Caveat: mutation on the free variables will
not reflect on the original binding. Such a restriction can be overcome
using set!-transformers. The macro define/freevar can also disallow
mutation using make-variable-like-transformer.

Implementation

While the idea is straightforward, a direct translation generates a large
amount of code duplication. In the output of define/freevar, the only
varying parts are the names of the free variables and the identifier
of the actual implementation. The implementation of define/freevar
thus follows a common pattern in Racket to share the transformer code.

The define/freevar form expands to a new definition storing the
original code and a macro for binding the free identifiers.
The implementation introduces an applicative struct, open-term,
that holds the list of free variables and the identifier of
the actual code.

Being applicative, open-term also has the implementation of the
use-site macro and serves as the transformer in the expansion of
for define/freevar.
When the macro expander calls an instance of open-term, it extracts
names of the free variables and redirects the reference to the
actual code.

The idea behind custom pattern expanders and syntax class aliases are related: using structs to store varying information while attaching struct type properties to assign behavior.

#lang racket/base
(require (for-syntax racket/base
                     racket/list
                     racket/syntax
                     syntax/parse))
(provide define/freevar
         with-freevar
         define/with-freevar)
(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)))]))

The open-term itself can be used as a transformer, with the list of free
variables and the target identifier differs in different instances:

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

Example

In this example, we define a function for computing the Fibonacci
sequence where the base values are left open and resolved at each
use site.

To illustrate the syntax, fib uses the option #:immediate that
immediately retrieve the value of init0 and init1 instead of
wrapping the identifier reference fib at X in a function.

(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)
;; X
(let ([init1 13])
  fib)            ;; <- The #:immediate flag makes a difference
;; init0 shadows the global definition
;;=> '(0 1 1 2 3 5 8 ...)
(let ([init0 0]
      [init1 1])
  (fib 10))
;; The free variable init1 is renamed to b
(with-freevar fib ([init1 b])
  (define b 4)
  (fib 10))
;; Another renaming example. Free variables do not have bindings.
(let ([b 5])
  (with-freevar fib ([init1 b])
    (fib 10)))
;; Define a new open term, fib-same, with free variables renamed from fib.
(define/with-freevar fib-same fib
  [init0 S]
  [init1 S])
(let ([S 3])
  (fib-same 10))

For the interested readers, the motivating example of define/freevar
is the following utility function for Redex:

#lang racket/base
(require racket/pretty redex/reduction-semantics)
(provide apply-reduction-relation*-->)
(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))

Licence

I license the code in this issue under the same MIT License that the Racket language uses and the texts under the Creative Commons Attribution 4.0 International License