Define with expanders

main definitions

define-with-expanders.rkt

@@ -0,0 +1,85 @@
+#lang racket
+
+(require syntax/parse/define
+         (for-syntax syntax/parse
+                     syntax/parse/define
+                     racket/syntax
+                     predicates
+                     (for-syntax racket/base
+                                 syntax/parse)))
+
+(define-for-syntax (disp a) (displayln a) a)
+
+(define-for-syntax syntax-list? (and? syntax? (compose list? syntax->list)))
+(define-for-syntax (identifier-bound-to? p)
+  (and? identifier? (compose p maybe-syntax-local-value)))
+
+(define-for-syntax (maybe-syntax-local-value stx)
+  (syntax-local-value stx (λ () #f)))
+
+(define-for-syntax ((stx-expander expand? transformer) stx)
+  (if (expand? stx)
+      (transformer stx)
+      (syntax-parse stx
+        [(a . b) #`(#,((stx-expander expand? transformer) #'a)
+                    #,@((stx-expander expand? transformer) #'b))]
+        [() #'()]
+        [a #'a])))
+
+(begin-for-syntax
+  (define-simple-macro (with-derived-ids ([pat-id:id format base-id-stx] ...) stx-expr)
+    (with-syntax ([pat-id (format-id base-id-stx format base-id-stx)] ...)
+      stx-expr)))
+
+(define-syntax define-syntax-with-expanders
+  (syntax-parser
+    [(_ foo:id transformer-expr)
+     (with-derived-ids ([foo-expander "~a-expander" #'foo]
+                        [foo-expander? "~a-expander?" #'foo]
+                        [foo-expander-transformer "~a-expander-transformer" #'foo]
+                        [define-foo-expander "define-~a-expander" #'foo])
+       #'(begin
+           (define-expander-struct foo-expander)
+           (define-expander-definer define-foo-expander foo-expander)
+           (define-syntax foo
+             (compose transformer-expr
+                      (stx-expander
+                       (compose
+                        (list-with-head? (identifier-bound-to? foo-expander?))
+                        syntax->list)
+                       (λ (expander-stx)
+                         (call-expander foo-expander-transformer
+                                        (car (syntax->list expander-stx))
+                                        expander-stx)))))))]))
+
+;; Helpers for define-syntax-with-expanders
+
+;; Binds id as a struct at phase level 1 that will contain a single field named "transformer"
+;; that is a procedure accepting a syntax object and returning a syntax object
+(define-simple-macro (define-expander-struct id:id)
+  (begin-for-syntax
+    (struct id (transformer))))
+
+;; Binds definer-id as a form that defines expanders for another syntactic form by using the
+;; phase level 1 struct created with define-expander-struct
+(define-simple-macro (define-expander-definer definer-id:id expander-struct-id:id)
+  (define-simple-macro (definer-id expander:id transformer)
+    (define-syntax expander
+      (expander-struct-id transformer))))
+
+;; Small helper that assumes expander-stx is an identifier bound to an expander struct value
+;; at phase level 1, and extracts the expander's transformer procedure with accessor then
+;; calls that transformer on stx-to-expand
+(define-for-syntax (call-expander accessor expander-stx stx-to-expand)
+  ((accessor (syntax-local-value expander-stx)) stx-to-expand))
+
+(define-syntax-with-expanders foo
+  (syntax-parser
+    [(_ blah ...)
+     #'(blah ...)]))
+
+(define-foo-expander baz
+  (syntax-parser
+    [(_ n:number blah)
+     #'blah]))
+