Building a complex macro-defining-macro in Racket

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 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] ...)]))]))

Answer 2

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