Created
February 6, 2017 19:53
-
-
Save lexi-lambda/081d5d1bbb76fd89de1a5cb5da9da0b8 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#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) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment