Multi-language macro-extensible macro system

multi-language-macro-system.rkt

#lang racket/base

(module mac-module racket/base
  (provide mac)

  (require syntax-spec-v3
           qi
           syntax/parse/define
           syntax/parse
           (for-syntax racket/base
                       syntax/parse)
           rackunit
           rackunit/text-ui)

  (begin-for-syntax
    (define-syntax-class any
      (pattern (~or* _:expr _:keyword))))

  (syntax-spec

    ;; Declare a compile-time datatype by which mac macros may
    ;; be identified.
    (extension-class mac-macro
                     #:binding-space mac)

    (nonterminal macx
      #:description "a macro expression"
      #:allow-extension mac-macro
      #:binding-space mac

      ((~datum rule) (name:id pat:expr ...) body:any ...)
      ((~datum case) body:any ...)))

  (begin-for-syntax
    (define (compile-mac stx)
      (syntax-parse stx
        [((~datum rule) (_name:id arg ...) body ...)
         #'(syntax-parser [(_ arg ...) body ...])]
        [((~datum case) body ...)
         #'(syntax-parser body ...)])))

  (syntax-spec
    (host-interface/expression
      (mac m:macx ...)
      (syntax-parse #'(m ...)
        [(m) (compile-mac #'m)]
        ;; error handling catch-all
        [(expr0 expr ...+)
         (raise-syntax-error
          #f
          "mac expects a single macro specification, but it received many."
          (datum->syntax this-syntax
            (cons 'mac
                  (syntax->list this-syntax))))])))

  ;; Test `mac`
  (module+ test
    (define mac-tests
      (test-suite
       "mac test"
       (test-true "mac compiles to a procedure"
                  (procedure? (mac (rule (my-mac-too a) #'a))))
       (test-equal? "parse syntax using rule"
                    (syntax->datum
                     ((mac (rule (_ a b) #'b)) #'(my-mac 1 2)))
                    2)
       (test-equal? "parse syntax using cases"
                    (syntax->datum
                     ((mac (case [(_ a) #'a]
                                 [(_ a b) #'b]))
                      #'(my-mac 1 2)))
                    2)
       (test-equal? "syntax binding"
                    (syntax->datum
                     ((mac (rule (_ a b) #:with c #'a #'c)) #'(my-mac 1 2)))
                    1)))

    (void (run-tests mac-tests))))

(require (for-syntax 'mac-module
                     racket/base))

(require (for-syntax syntax/parse)
         qi
         syntax-spec-v3)

(define-syntax macro
  (syntax-parser
    [(_ ((~datum dsl) extension-class:id) (name:id pattern ...) template ...)
     #'(define-dsl-syntax name extension-class (mac (rule (_ pattern ...) template ...)))]
    [(_ (name:id pattern ...) template ...)
     #'(define-syntax name (mac (rule (_ pattern ...) template ...)))]))

(macro (my-mac a b)
  #'b)

(my-mac 1 2)

(macro (dsl qi-macro) (my-qi-mac a)
  #'a)

(~> (3) (my-qi-mac 5))