macro-arg.rkt

#lang racket

(module combinator racket
  (require (for-syntax racket/syntax
                       (only-in syntax/parse/private/residual this-role))
           racket/dict
           syntax/location
           syntax/parse/define)

  (provide (for-syntax wrap-expr/c expr/c))

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

  (define (macro-arg/c macro-name ctc label)
    (let ([ctc-project (get/build-late-neg-projection ctc)])
      ((if (chaperone-contract? ctc) make-chaperone-contract make-contract)
       #:name (bare-string (~a "a use of " macro-name))
       #:first-order (contract-first-order ctc)
       #:late-neg-projection
       (λ (blame)
         (ctc-project (blame-swap (blame-add-context blame label #:important macro-name)))))))

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

  (define-for-syntax (wrap-expr/c ctc expr
                                  #:description [description #'#f]
                                  #:source [source #'expr]
                                  #:name [name (infer-macro-name source)])
    (quasisyntax/loc source
      (contract (macro-arg/c #,name #,ctc #,description)
                #,expr
                #,name
                (quote-module-path)
                #f
                (quote-syntax #,source))))

  (begin-for-syntax
    (define-syntax-class (expr/c ctc
                                 #:description [description this-role]
                                 #:source [source (current-syntax-context)]
                                 #:name [name (infer-macro-name source)])
      #:description #f
      #:attributes [c]
      [pattern expr:expr
               #:attr c (wrap-expr/c ctc #'expr
                                     #:description description
                                     #:source source
                                     #:name name)])))

(module macro racket
  (require (except-in syntax/parse/define expr/c)
           (submod ".." combinator))

  (provide app-integer-fn)

  (define-simple-macro (app-integer-fn f)
    #:declare f (expr/c #'(-> integer? integer?) #:description "the argument to")
    (f.c "hi")))

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

  (app-integer-fn add1))

(require 'use)