Building a complex macro-defining-macro in Racket - macros

Question

I'm trying to build a macro-defining macro
Background
I have some structs that I'm using to represent an AST. I will be defining lots of transformations on these struct, but some of these transformations will be pass-through ops: i.e. I'll match on the AST and just return it unmodified. I'd like to have a macro automate all the default cases, and I'd like to have a macro automate making that macro. :)
Example
Here are the struct definitions that I'm using:
(struct ast (meta) #:transparent)
(struct ast/literal ast (val) #:transparent)
(struct ast/var-ref ast (name) #:transparent)
(struct ast/prim-op ast (op args) #:transparent)
(struct ast/if ast (c tc fc) #:transparent)
(struct ast/fun-def ast (name params body) #:transparent)
(struct ast/λ ast (params body) #:transparent)
(struct ast/fun-call ast (fun-ref args) #:transparent)
I want a macro called ast-matcher-maker that gives me a new macro, in this case if-not-removal, which would e.g. transform patterns like (if (not #<AST_1>) #<AST_2> #<AST_3>) into (if #<AST_1> #<AST_3> #<AST_2>):
(ast-matcher-maker match/ast
(ast/literal meta val)
(ast/var-ref meta name)
(ast/prim-op meta op args)
(ast/if meta test true-case false-case)
(ast/fun-def meta name params body)
(ast/λ meta params body)
(ast/fun-call meta fun-ref args))
(define (not-conversion some-ast)
(match/ast some-ast
[(ast/if meta `(not ,the-condition) tc fc) ; forgive me if my match syntax is a little off here
(ast/if meta the-condition fc tc)]))
Ideally, the call to ast-matcher-maker would expand to this or the like:
(define-syntax (match/ast stx)
(syntax-case stx ()
[(match/ast in clauses ...)
;; somehow input the default clauses
#'(match in
clauses ...
default-clauses ...)]))
And the call to match/ast inside the body of not-conversion would expand to:
(match some-ast
[(ast/if meta `(not ,the-condition) tc fc)
(ast/if meta the-condition fc tc)]
[(ast/literal meta val) (ast/literal meta val)]
[(ast/var-ref meta name) (ast/var-ref meta name)]
[(ast/prim-op meta op args) (ast/prim-op meta op args)]
[(ast/fun-def meta name params body) (ast/fun-def meta name params body)]
[(ast/λ meta params body) (ast/λ meta params body)]
[(ast/fun-call meta fun-ref args) (ast/fun-call meta fun-ref args)])
What I have so far
This is what I've got:
#lang racket
(require macro-debugger/expand)
(define-syntax (ast-matcher-maker stx)
(syntax-case stx ()
[(_ id struct-descriptors ...)
(with-syntax ([(all-heads ...) (map (λ (e) (datum->syntax stx (car e)))
(syntax->datum #'(struct-descriptors ...)))])
(define (default-matcher branch-head)
(datum->syntax stx (assoc branch-head (syntax->datum #'(struct-descriptors ...)))))
(define (default-handler branch-head)
(with-syntax ([s (default-matcher branch-head)])
#'(s s)))
(define (make-handlers-add-defaults clauses)
(let* ([ah (syntax->datum #'(all-heads ...))]
[missing (remove* (map car clauses) ah)])
(with-syntax ([(given ...) clauses]
[(defaults ...) (map default-handler missing)])
#'(given ... defaults ...))))
(println (syntax->datum #'(all-heads ...)))
(println (syntax->datum (default-matcher 'h-ast/literal)))
#`(define-syntax (id stx2)
(syntax-case stx2 ()
;;;
;;; This is where things get dicy
;;;
[(_ in-var handlers (... ...))
(with-syntax ([(all-handlers (... ...))
(make-handlers-add-defaults (syntax->datum #'(handlers (... ...))))])
#'(match in-var
all-handlers (... ...)))]))
)]))
;; I've been using this a little bit for debugging
(syntax->datum
(expand-only #'(ast-matcher-maker
match/h-ast
(h-ast/literal meta val)
(h-ast/var-ref meta name)
(h-ast/prim-op meta op args))
(list #'ast-matcher-maker)))
;; You can see the errors by running this:
;; (ast-matcher-maker
;; match/h-ast
;; (h-ast/literal meta val)
;; (h-ast/var-ref meta name)
;; (h-ast/prim-op meta op args))
Any ideas?

Answer 1

I have a solution. I am open to improvements or suggestions.
I am not sure if the syntax macros return can close over/reference functions defined inside the scope of that macro expander. (That's what I'm doing with the make-handlers-add-defaults function.) I think the technical terminology involved is that the function definition and the function invocation happens in different phases.
Someone please correct me if I am wrong.
My solution was to embed the data I need directly in the macro—this would make the intermediate AST bigger perhaps, but that may or may not be a bad thing. Here's what I ended up with:
(define-syntax (ast-matcher-maker stx)
(syntax-case stx ()
[(_ id struct-descriptors ...)
#`(define-syntax (id stx2)
(syntax-case stx2 ()
[(_ in-var handlers (... ...))
;; Embed the data I need directly into the macro
(let ([all-defaults '#,(syntax->datum #'(struct-descriptors ...))])
(define (gen-handlers clauses)
(let* ([missing (remove* (map car clauses) (map car all-defaults))]
[default-handler (λ (a) (with-syntax ([s (datum->syntax stx2 (assoc a all-defaults))])
#'(s s)))]
[override-handler (λ (a) (with-syntax ([s (datum->syntax stx2 (assoc (car a) all-defaults))]
[a (datum->syntax stx2 (cadr a))])
#'(s a)))])
(with-syntax ([(given (... ...)) (map override-handler clauses)]
[(defaults (... ...)) (map default-handler missing)])
#'(given (... ...) defaults (... ...)))))
(with-syntax ([(handlers (... ...)) (gen-handlers (syntax->datum #'(handlers (... ...))))])
#'(match in-var
handlers (... ...))))]))]))
And using:
(ast-matcher-maker
match/h-ast
(h-ast/literal meta val)
(h-ast/var-ref meta name)
(h-ast/prim-op meta op args))
(define (foo-name some-ast)
(match/h-ast some-ast
[h-ast/var-ref (h-ast/var-ref meta (cons 'foo name))]))
Invoking foo-name gives me what I want:
(foo-name (h-ast/literal null 42)) ;=> (h-ast/literal null 42))
(foo-name (h-ast/var-ref null 'hi)) ;=> (h-ast/var-ref null '(foo . hi))

Answer 2

I think this is what you are going for.
(define-syntax (ast-matcher-maker stx)
(syntax-case stx ()
[(_ name default-clauses ...)
#'(define-syntax name
(syntax-rules ()
[(_ e override-clauses (... ...))
(match e
override-clauses (... ...)
[(and v default-clauses) v] ...)]))]))