macro-arr.rkt

#lang racket

(module combinator racket
  (require racket/dict
           syntax/location
           syntax/parse/define)

  (provide with-contracted-expressions)

  (struct bare-string (str)
    #:methods gen:custom-write
    [(define (write-proc str port mode)
       (display (bare-string-str str) port))])

  (define (macro->/c macro-name ctcs+labels)
    (match-let* ([(list (or (list ctcs labels)
                            (and ctcs (app (const #f) labels)))
                        ...)
                  ctcs+labels]
                 [chaperone? (andmap chaperone-contract? ctcs)]
                 [wrap-procedure (if chaperone? chaperone-procedure impersonate-procedure)])
      ((if chaperone? make-chaperone-contract make-contract)
       #:name (bare-string (~a "a use of " macro-name))
       #:first-order
       (λ (val) (and (procedure? val)
                     (procedure-arity-includes? val (length ctcs))))
       #:projection
       (λ (blame)
         (let* ([blame (blame-add-context blame #f #:important macro-name)]
                [arg-blame (for/list ([label (in-list labels)])
                             (blame-add-context blame label #:swap? #t))])
           (λ (val)
             (((contract-projection (procedure-arity-includes/c (length ctcs))) blame) val)
             (wrap-procedure
              val
              (λ args
                (let ([contracted-args (for/list ([ctc (in-list ctcs)]
                                                  [blame (in-list arg-blame)]
                                                  [arg (in-list args)])
                                         (((contract-projection ctc) blame) arg))])
                  (apply values contracted-args))))))))))

  (define-for-syntax infer-macro-name
    (syntax-parser
      [x:id #''x]
      [(x:id . _) #''x]
      [_ #f]))

  (define-syntax-parser with-contracted-expressions
    [(_ ([id:id ctc:expr expr:expr {~optional {~seq #:description description:expr}
                                              #:defaults ([description #'#f])}]
         ...)
        {~or {~optional {~seq #:source src}}
             {~optional {~seq #:name macro-name:expr}}}
        ...
        body:expr ...+)
     #:fail-unless (or (attribute src) (attribute macro-name))
                   "either the #:name or #:source option must be provided"
     #:attr src* (or (attribute src) this-syntax)
     #:attr macro-name* (or (attribute macro-name) (infer-macro-name #'src))
     #:fail-unless (attribute macro-name*)
                   "#:name could not be inferred from #:source"
     #:with contracted
            (syntax/loc #'src*
              (contract (macro->/c macro-name* (list (list ctc description) ...))
                        (λ (id ...) body ...)
                        macro-name*
                        (quote-module-path)
                        #f
                        (quote-syntax src*)))
     (syntax/loc #'src*
       (contracted expr ...))]))

(module macro racket
  (require syntax/parse/define
           (submod ".." combinator))

  (provide app-integer-fn)

  (define-simple-macro (app-integer-fn f:expr)
    #:with src this-syntax
    (with-contracted-expressions ([f/c (-> integer? integer?) f
                                       #:description "the 1st argument of"])
      #:source src
      (f/c "hi"))))

(module use racket
  (require (submod ".." macro))

  (app-integer-fn add1))

(require 'use)