Created
November 9, 2012 23:54
-
-
Save greghendershott/4049108 to your computer and use it in GitHub Desktop.
A "term sheet" is a light-weight, more casual version of a contract. :)
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 | |
;; A term sheet is a light-weight, casual version of a contract. :) | |
;; | |
;; Seriously, `define/termsheet' takes the same form as | |
;; `define/contract', but uses the contract predicates as simple | |
;; checks. As a result, this runs much faster -- e.g. ~200x faster -- | |
;; than a normal, chaperoned wrapped procedure. | |
;; | |
;; In other words it gives the declarative convenience of | |
;; define/contract, but with the speed as if you wrote checks by hand. | |
(require (for-syntax racket/list | |
racket/syntax | |
syntax/parse) | |
racket/stxparam) | |
(provide lambda/termsheet | |
define/termsheet | |
termsheet-check) | |
(define-syntax-parameter any ;suppress error about `any' used outside `->' | |
(lambda (stx) | |
#'(lambda _ #t))) | |
(define enabled? #t) ;an actual `parameter' not needed, too slow | |
(define termsheet-check ;but `provide' a parameter-like function | |
(case-lambda | |
[() enabled?] | |
[(v) (set! enabled? v)])) | |
(define (contract->predicate c) | |
(cond [(flat-contract? c) (flat-contract-predicate c)] | |
[(chaperone-contract? c) procedure?] ;; downgrade to check for proc | |
[else (error 'contract->predicate "don't know about ~a" c)])) | |
;; If pred-stx looks like a procedure contract, i.e. (-> ...), then | |
;; replace arg-stx with a lamba/termsheet, i.e. like a chaperone. | |
(define-for-syntax (maybe-wrap arg-stx pred-stx) | |
(syntax-case pred-stx (->) | |
[(-> x ...) | |
(with-syntax ([(arg ...) (generate-temporaries | |
(map (lambda (x) (datum->syntax arg-stx x)) | |
(drop-right (syntax->list #'(x ...)) 1)))] | |
[func arg-stx] | |
[id arg-stx]) | |
#'(lambda/termsheet id | |
(arg ...) | |
(-> x ...) | |
(func arg ...)))] | |
[_ arg-stx])) | |
(define-for-syntax (ord-str n) | |
(let ([suffix (case n | |
[(1) "st"] | |
[(2) "nd"] | |
[(3) "rd"] | |
[else "th"])]) | |
(format "~a~a" n suffix))) | |
(define-syntax (lambda/termsheet stx) | |
(syntax-parse stx | |
[(_ id:id (arg:id ...) ((~datum ->) pred:expr ...) body ...+) | |
(unless (= (add1 (length (syntax->list #'(arg ...)))) | |
(length (syntax->list #'(pred ...)))) | |
(raise-syntax-error 'define/termsheet | |
"must supply a predicate for each argument plus one for the return value" | |
stx | |
#'(-> pred ...) | |
)) | |
(with-syntax* ([(arg-pred ...) | |
(map (lambda (x) | |
(datum->syntax stx x)) | |
(drop-right (syntax->list #'(pred ...)) 1))] | |
[rtn-pred | |
(car (take-right (syntax->list #'(pred ...)) 1))] | |
[(arg-pred-id ...) | |
(generate-temporaries #'(arg-pred ...))] | |
[(wrapped-arg ...) | |
(map maybe-wrap | |
(syntax->list #'(arg ...)) | |
(syntax->list #'(arg-pred ...)))] | |
[(nth ...) | |
(for/list ([a (syntax->list #'(arg ...))] | |
[n (in-naturals)]) | |
(ord-str (add1 n)))]) | |
#'(let ([arg-pred-id (contract->predicate arg-pred)] ...) | |
(lambda (arg ...) | |
(let ([arg wrapped-arg] ...) | |
(when enabled? | |
(unless (arg-pred-id arg) | |
(raise-argument-error 'id | |
(format "~a argument to be ~a" | |
nth | |
(quote arg-pred)) | |
arg)) ...) | |
(let ([rtn (begin body ...)]) | |
(cond [(or (not enabled?) | |
(rtn-pred rtn)) | |
rtn] | |
[else | |
(error 'id | |
"return value\nexpected: ~a\nreturned: ~a" | |
(quote rtn-pred) | |
rtn)]))))))])) | |
(define-syntax (define/termsheet stx) | |
(syntax-parse stx | |
[(_ (id:id arg:id ...) ((~datum ->) pred:expr ...) body ...+) | |
#'(define id | |
(lambda/termsheet id | |
(arg ...) | |
(-> pred ...) | |
body ...))])) | |
;;; | |
;;; benchmark | |
;;; | |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
;; Example 1: Single arg, return any | |
;; Only simple predicate | |
(define (f/raw x) | |
#t) | |
(define (f/checked x) | |
(unless (exact-nonnegative-integer? x) | |
(raise-argument-error 'f/checked | |
"exact-positive-integer?" | |
x)) | |
#t) | |
(define/contract (f/contracted x) | |
(exact-nonnegative-integer? . -> . any) | |
#t) | |
(define/termsheet (f/termsheet x) | |
(exact-nonnegative-integer? . -> . any) | |
#t) | |
(define-syntax-rule (bench func) | |
(begin | |
(display (object-name func)) (display ": ") | |
(time (for ([i (in-range 1000000)]) | |
(func i))) | |
(void))) | |
(bench f/raw) | |
(bench f/checked) | |
(bench f/termsheet) | |
(bench f/contracted) | |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
;; Example 2: Three args various types, return any. | |
;; Check includes predicate-creator, `or/c' | |
(define (f2/raw x y z) | |
#t) | |
(define f2/checked | |
(let ([or/c-number-string? (or/c number? string?)]) | |
(lambda (x y z) | |
(unless (exact-positive-integer? x) | |
(raise-argument-error 'f2/checked | |
"exact-positive-integer?" | |
x)) | |
(unless (string? y) | |
(raise-argument-error 'f2/checked | |
"string?" | |
y)) | |
(unless (or/c-number-string? z) | |
(raise-argument-error 'f2/checked | |
"number? or string?" | |
y)) | |
#t))) | |
(define/contract (f2/contracted x y z) | |
(exact-positive-integer? string? (or/c number? string?) . -> . any) | |
#t) | |
(define/termsheet (f2/termsheet x y z) | |
(exact-positive-integer? string? (or/c number? string?) . -> . any) | |
#t) | |
(define-syntax-rule (bench2 func) | |
(begin | |
(display (object-name func)) (display ": ") | |
(time (for ([i (in-range 1000000)]) | |
(func 1 "foo" "bar"))) | |
(void))) | |
(bench2 f2/raw) | |
(bench2 f2/checked) | |
(bench2 f2/termsheet) | |
(bench2 f2/contracted) | |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
;; Example 3: Three args various types, return boolean? | |
;; Check includes predicate-creator, `or/c' | |
(define (f3/raw x y z) | |
#t) | |
(define f3/checked | |
(let ([or/c-number-string? (or/c number? string?)]) | |
(lambda (x y z) | |
(unless (exact-positive-integer? x) | |
(raise-argument-error 'f3/checked | |
"exact-positive-integer?" | |
x)) | |
(unless (string? y) | |
(raise-argument-error 'f3/checked | |
"string?" | |
y)) | |
(unless (or/c-number-string? z) | |
(raise-argument-error 'f3/checked | |
"number? or string?" | |
y)) | |
(boolean? #t) | |
#t))) | |
(define/contract (f3/contracted x y z) | |
(exact-positive-integer? string? (or/c number? string?) . -> . boolean?) | |
#t) | |
(define/termsheet (f3/termsheet x y z) | |
(exact-positive-integer? string? (or/c number? string?) . -> . boolean?) | |
#t) | |
(define-syntax-rule (bench3 func) | |
(begin | |
(display (object-name func)) (display ": ") | |
(time (for ([i (in-range 1000000)]) | |
(func 1 "foo" "bar"))) | |
(void))) | |
(bench3 f3/raw) | |
(bench3 f3/checked) | |
(bench3 f3/termsheet) | |
(bench2 f3/contracted) | |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
;; Example 4 | |
;; Procedure contract | |
(define (f4/raw a f) | |
(f a)) | |
(define/termsheet (f4/termsheet a f) | |
(boolean? (boolean? . -> . boolean?) . -> . any) | |
(f a)) | |
(define/contract (f4/contract a f) | |
(boolean? (boolean? . -> . boolean?) . -> . any) | |
(f a)) | |
(define-syntax-rule (bench4 func) | |
(begin | |
(display (object-name func)) (display ": ") | |
(time (for ([i (in-range 1000000)]) | |
(func #t (lambda (x) x)))) | |
(void))) | |
(bench4 f4/raw) | |
(bench4 f4/termsheet) | |
(bench4 f4/contract) |
Latest results:
f/raw: cpu time: 10 real time: 10 gc time: 0
f/checked: cpu time: 11 real time: 11 gc time: 0
f/termsheet: cpu time: 20 real time: 20 gc time: 0
f/contracted: cpu time: 9601 real time: 9640 gc time: 345
f2/raw: cpu time: 10 real time: 11 gc time: 0
f2/checked: cpu time: 156 real time: 155 gc time: 0
f2/termsheet: cpu time: 66 real time: 67 gc time: 0
f2/contracted: cpu time: 13816 real time: 13884 gc time: 555
f3/raw: cpu time: 12 real time: 12 gc time: 0
f3/checked: cpu time: 167 real time: 167 gc time: 0
f3/termsheet: cpu time: 59 real time: 59 gc time: 0
f3/contracted: cpu time: 14086 real time: 14143 gc time: 562
f4/raw: cpu time: 13 real time: 13 gc time: 0
f4/termsheet: cpu time: 750 real time: 752 gc time: 16
f4/contract: cpu time: 17793 real time: 17871 gc time: 710
Re the new procedure contract handling: The macro wraps these in an additional lambda/termsheet
. This is much faster than real chaperone. However it's quite slow. Another approach I tried was to transform all procedure contracts into a simple procedure?
predicate, which is much faster. Granted this loses the deeper checking. However in my experience that's of limited value, especially if the procedure being called already has its own contract (or termsheet). It will check its own input args. At most, it would be useful to check only that the procedure returns something expected.
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Example results: