在 Racket 中構建復雜的宏定義宏

Question

我正在嘗試構建一個宏定義宏

背景

我有一些用於表示 AST 的結構。 我將在這些結構上定義很多轉換，但其中一些轉換將是傳遞操作：即我將在 AST 上進行匹配，然后不加修改地返回它。 我想讓一個宏自動執行所有默認情況，並且我想讓一個宏自動生成該宏。 :)

例子

以下是我正在使用的結構定義：

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

我想要一個名為ast-matcher-maker的宏，它會給我一個新的宏，在本例中if-not-removal ，它會轉換模式，例如(if (not #<AST_1>) #<AST_2> #<AST_3>)進入(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)]))

理想情況下，對ast-matcher-maker的調用將擴展為以下內容：

(define-syntax (match/ast stx)
  (syntax-case stx ()
    [(match/ast in clauses ...)
     ;; somehow input the default clauses
     #'(match in
          clauses ...
          default-clauses ...)]))

並且在not-conversion主體內調用match/ast將擴展為：

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

到目前為止我所擁有的

這就是我所擁有的：

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

有任何想法嗎？

Answer 1

我有一個解決方案。 我願意接受改進或建議。

我不確定返回的語法宏是否可以關閉在該宏擴展器的 scope 中定義的覆蓋/引用函數。 （這就是我對make-handlers-add-defaults function 所做的。）我認為涉及的技術術語是 function 定義和 function 調用發生在不同的階段。

如果我錯了，請有人糾正我。

我的解決方案是將我需要的數據直接嵌入到宏中——這可能會使中間 AST 變大，但這可能是壞事，也可能不是壞事。 這是我最終得到的：

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

並使用：

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

調用foo-name給了我想要的東西：

(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

我想這就是你想要的。

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