PasteRack.org
Paste # 18443
2017-02-06 14:01:21

Fork as a new paste.

Paste viewed 1149 times.


Embed:

  1. #lang racket
  2.  
  3. (module combinator racket
  4.   (require syntax/location
  5.            syntax/parse/define)
  6.  
  7.   (provide with-contracted-expressions)
  8.  
  9.   (struct bare-string (str)
  10.     #:methods gen:custom-write
  11.     [(define (write-proc str port mode)
  12.        (display (bare-string-str str) port))])
  13.  
  14.   (define (macro->/c macro-name ctcs labels)
  15.     (let ([chaperone? (andmap chaperone-contract? ctcs)])
  16.       ((if chaperone? make-chaperone-contract make-contract)
  17.        #:name (bare-string (~a "a use of " macro-name))
  18.        #:projection
  19.        (λ (blame)
  20.          (let ([blame (blame-add-context blame #f #:important macro-name)])
  21.            (λ (val)
  22.              (((contract-projection (procedure-arity-includes/c (length ctcs))) blame) val)
  23.              ((if chaperone? chaperone-procedure impersonate-procedure)
  24.               val
  25.               (λ args
  26.                 (let ([contracted-args (for/list ([ctc (in-list ctcs)]
  27.                                                   [label (in-list labels)]
  28.                                                   [arg (in-list args)])
  29.                                          (let ([blame (blame-add-context blame label #:swap? #t)])
  30.                                            (((contract-projection ctc) blame) arg)))])
  31.                   (apply values contracted-args))))))))))
  32.  
  33.   (define-syntax-parser with-contracted-expressions
  34.     [(_ macro-name:expr ([id:id ctc:expr expr:expr {~optional {~seq #:description description:expr}
  35.                                                               #:defaults ([description #'#f])}]
  36.                          ...)
  37.         {~optional {~seq #:source src} #:defaults ([src this-syntax])}
  38.         body:expr ...+)
  39.      #:with contracted
  40.             (quasisyntax/loc #'src
  41.               (contract (macro->/c macro-name (list ctc ...) (list description ...))
  42.                         (λ (id ...) body ...)
  43.                         macro-name
  44.                         (quote-module-path)
  45.                         #f
  46.                         (quote-syntax src)))
  47.      (syntax/loc #'src
  48.        (contracted expr ...))]))
  49.  
  50. (module macro racket
  51.   (require syntax/parse/define
  52.            (submod ".." combinator))
  53.  
  54.   (provide app-integer-fn)
  55.  
  56.   (define-simple-macro (app-integer-fn f:expr)
  57.     #:with src this-syntax
  58.     (with-contracted-expressions 'app-integer-fn ([f/c (-> integer? integer?) f])
  59.       #:source src
  60.       (f/c "hi"))))
  61.  
  62. (module use racket
  63.   (require (submod ".." macro))
  64.  
  65.   (app-integer-fn add1))
  66.  
  67. (require 'use)

=>