add define-extend

from syntax-objects/Summer2021#13
cc @camoy

define-extend/define-extend-test.rkt

@@ -0,0 +1,32 @@
+#lang racket/base
+(module+ test
+  (require racket/match rackunit syntax/macro-testing syntax-parse-example/define-extend/define-extend)
+
+  (test-begin
+
+    (define-extend (interp0 e)
+      (match e
+        [`(+ ,x ,y) (+ (interp0 x) (interp0 y))]
+        [(? number?) e]))
+
+    (test-case "interp0"
+      (check-equal? (interp0 '(+ (+ 1 2) (+ 5 6))) 14))
+
+    (define-extend (interp1 e)
+      #:extend interp0
+      (match e
+        [`(* ,x ,y) (* (interp1 x) (interp1 y))]
+        [_ (interp0 e)]))
+
+    (test-case "interp1"
+      (check-equal? (interp1 '(+ (+ 1 2) (* 5 6))) 33))
+
+    (test-case "bad-parent"
+      (check-exn exn:fail:syntax?
+        (lambda ()
+          (convert-compile-time-error (let ()
+            (define-extend (interp1 e)
+              #:extend map
+              'not-implemented)
+            (void)))))))
+)

define-extend/define-extend.rkt

@@ -0,0 +1,42 @@
+#lang racket/base
+(provide define-extend)
+
+(require (for-syntax racket/base
+                     syntax/parse
+                     syntax/parse/lib/function-header))
+
+(begin-for-syntax
+  (struct extensible (closed-id open-id)
+    #:property prop:rename-transformer 0)
+
+  (define-splicing-syntax-class extend-option
+    #:attributes (parent-id open-id)
+    (pattern (~seq #:extend parent-id:id)
+             #:do [(define-values (parent-ext _)
+                     (syntax-local-value/immediate #'parent-id
+                                                   (λ () (values #f #f))))]
+             #:fail-when (and (not (extensible? parent-ext)) #'parent-id)
+             "expected an extensible procedure"
+             #:attr open-id (extensible-open-id parent-ext))
+    (pattern (~seq)
+             #:attr parent-id #f
+             #:attr open-id #f)))
+
+(define-syntax (define-extend stx)
+  (syntax-parse stx
+    [(_ (?name:id . ?fmls:formals) ?ext:extend-option ?body:expr ...+)
+     #:with (?closed ?open) (generate-temporaries #'(?name ?name))
+     #:with ?proc
+     (syntax/loc stx
+       (~? (λ ?fmls
+             (let ([?ext.parent-id (?ext.open-id ?name)])
+               ?body ...))
+           (λ ?fmls ?body ...)))
+     #'(begin
+         (define ?closed
+           (letrec ([?name ?proc])
+             ?name))
+         (define (?open ?name) ?proc)
+         (define-syntax ?name
+           (extensible #'?closed #'?open)))]))
+

define-extend/define-extend.scrbl

@@ -0,0 +1,99 @@
+#lang syntax-parse-example
+@require[
+  (for-label racket/base racket/match syntax/parse syntax-parse-example/define-extend/define-extend)]
+
+@(define define-extend-eval
+   (make-base-eval '(require racket/match syntax-parse-example/define-extend/define-extend)))
+
+@title{@tt{define-extend}}
+@stxbee2021["camoy" 13]
+
+@; =============================================================================
+
+Suppose we're writing interpreters @racket[_interp0] and @racket[_interp1] for
+languages @racket[_L0] and @racket[_L1] respectively.
+@racket[_L0] has numbers and binary addition, and @racket[_L1] extends @racket[_L0]
+with binary multiplication.
+Goal: Write @racket[_interp1] without copying all the cases from @racket[_interp0].
+
+
+@bold{Basic Solution}
+
+One solution is to write the interpreters in open-recursive style. Instead of
+recurring directly, recursive calls occur indirectly through an extra
+parameter. An interpreter can be invoked by closing the recursion using a
+fixed-point combinator.
+
+@racketblock[
+(define fix
+  (λ (f)
+    ((λ (x) (f (λ (g) ((x x) g))))
+     (λ (x) (f (λ (g) ((x x) g)))))))
+
+(define ((interp0 recur) e)
+  (match e
+    [`(+ ,x ,y) (+ (recur x) (recur y))]
+    [(? number?) e]))
+
+((fix interp0) '(+ (+ 1 2) (+ 5 6)))
+
+(define ((interp1 recur) e)
+  (match e
+    [`(* ,x ,y) (* (recur x) (recur y))]
+    [_ ((interp0 recur) e)]))
+
+((fix interp1) '(+ (+ 1 2) (* 5 6)))
+]
+
+We can do better.
+
+
+@defmodule[syntax-parse-example/define-extend/define-extend]{}
+
+@defform[(define-extend (name . formals) maybe-extend body ...+)
+         #:grammar ([maybe-extend (code:line) (#:extend parent-id)])]{
+  The @racket[define-extend] macro allows you to write extensible procedures in a
+  more natural style.
+
+  @examples[#:eval define-extend-eval
+    (define-extend (interp0 e)
+      (match e
+        [`(+ ,x ,y) (+ (interp0 x) (interp0 y))]
+        [(? number?) e]))
+
+    (interp0 '(+ (+ 1 2) (+ 5 6)))
+
+    (define-extend (interp1 e)
+      #:extend interp0
+      (match e
+        [`(* ,x ,y) (* (interp1 x) (interp1 y))]
+        [_ (interp0 e)]))
+
+    (interp1 '(+ (+ 1 2) (* 5 6)))
+  ]
+
+  This macro supports some static checking. If the procedure we're extending
+  wasn't defined using @racket[define-extend], then we get a compile-time error.
+
+  @examples[#:eval define-extend-eval
+    (eval:error
+      (define-extend (interp1 e)
+        #:extend map
+        'not-implemented))]
+
+  Implementation:
+
+  @racketfile{define-extend.rkt}
+
+  For a valid input, @racket[define-extend] generates two variants of the procedure: a
+  closed version and an open version. It then creates a transformer binding
+  that records the name of both these variants in an extensible struct. This
+  struct has @racket[prop:rename-transformer] so that calling the procedure defaults to
+  the closed variant.
+
+  When defining an extension of procedure @racket[_f], we make sure to shadow the binding
+  of @racket[_f] within the body of the extension so as to close it off appropriately. We
+  use the extensible struct (found by @racket[syntax-local-value/immediate]) to get the
+  identifier of the open version of @racket[_f].
+
+}

index.scrbl

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