contract.rkt (1556B)
1 #lang typed/racket 2 (require "typed-untyped.rkt") 3 (define-typed/untyped-modules #:no-test 4 (require racket/contract 5 (for-syntax syntax/parse 6 racket/contract)) 7 8 (provide define-for-syntax/contract? 9 define/contract? 10 regexp-match/c 11 id/c) 12 13 (begin-for-syntax 14 (define-splicing-syntax-class freevar 15 (pattern {~and {~or {~seq #:freevar id contract-expr} 16 {~seq #:freevars ([ids contract-exprs] ...)} 17 {~seq}} 18 {~seq fv ...}}))) 19 20 (begin-for-syntax 21 (define enable-contracts (make-parameter #t))) 22 23 (define-syntax define-for-syntax/contract? 24 (syntax-parser 25 [(_ id/head contract-expr fv:freevar . body) 26 (if (enable-contracts) 27 #'(begin-for-syntax 28 (define/contract id/head contract-expr fv.fv ... . body)) 29 #'(define-for-syntax id/head . body))])) 30 31 (define-syntax define/contract? 32 (syntax-parser 33 [(_ id/head contract-expr fv:freevar . body) 34 (if (enable-contracts) 35 #'(define/contract id/head contract-expr fv.fv ... . body) 36 #'(define id/head . body))])) 37 38 (module m-contracts racket/base 39 (require racket/contract) 40 41 (provide regexp-match/c 42 id/c) 43 44 (define (regexp-match/c rx) 45 (and/c (or/c string? bytes? path? input-port?) 46 (λ (s) (regexp-match? rx s)))) 47 48 (define (id/c id) 49 (and/c identifier? (λ (i) (free-identifier=? i id))))) 50 51 (require 'm-contracts))