PasteRack.org
Paste # 83501
2017-02-06 17:09:36

Fork as a new paste.

Paste viewed 1087 times.


Embed:

  1. #lang racket
  2.  
  3. (module combinator racket
  4.   (require (for-syntax racket/syntax
  5.                        (only-in syntax/parse/private/residual this-role))
  6.            racket/dict
  7.            syntax/location
  8.            syntax/parse/define)
  9.  
  10.   (provide (for-syntax wrap-expr/c expr/c))
  11.  
  12.   (struct bare-string (str)
  13.     #:methods gen:custom-write
  14.     [(define (write-proc str port mode)
  15.        (display (bare-string-str str) port))])
  16.  
  17.   (define (macro-arg/c macro-name ctc label)
  18.     (let ([ctc-project (get/build-late-neg-projection ctc)])
  19.       ((if (chaperone-contract? ctc) make-chaperone-contract make-contract)
  20.        #:name (bare-string (~a "a use of " macro-name))
  21.        #:first-order (contract-first-order ctc)
  22.        #:late-neg-projection
  23.        (λ (blame)
  24.          (ctc-project (blame-swap (blame-add-context blame label #:important macro-name)))))))
  25.  
  26.   (define-for-syntax infer-macro-name
  27.     (syntax-parser
  28.       [x:id #''x]
  29.       [(x:id . _) #''x]
  30.       [_ #f]))
  31.  
  32.   (define-for-syntax (wrap-expr/c ctc expr
  33.                                   #:description [description #'#f]
  34.                                   #:source [source #'expr]
  35.                                   #:name [name (infer-macro-name source)])
  36.     (quasisyntax/loc source
  37.       (contract (macro-arg/c #,name #,ctc #,description)
  38.                 #,expr
  39.                 #,name
  40.                 (quote-module-path)
  41.                 #f
  42.                 (quote-syntax #,source))))
  43.  
  44.   (begin-for-syntax
  45.     (define-syntax-class (expr/c ctc
  46.                                  #:description [description this-role]
  47.                                  #:source [source (current-syntax-context)]
  48.                                  #:name [name (infer-macro-name source)])
  49.       #:description #f
  50.       #:attributes [c]
  51.       [pattern expr:expr
  52.                #:attr c (wrap-expr/c ctc #'expr
  53.                                      #:description description
  54.                                      #:source source
  55.                                      #:name name)])))
  56.  
  57. (module macro racket
  58.   (require (except-in syntax/parse/define expr/c)
  59.            (submod ".." combinator))
  60.  
  61.   (provide app-integer-fn)
  62.  
  63.   (define-simple-macro (app-integer-fn f)
  64.     #:declare f (expr/c #'(-> integer? integer?) #:description "the argument to")
  65.     (f.c "hi")))
  66.  
  67. (module use racket
  68.   (require (submod ".." macro))
  69.  
  70.   (app-integer-fn add1))
  71.  
  72. (require 'use)

=>