(module contracts mzscheme (provide (rename -contract contract) contract-=> -> ->d ->* ->d* case-> opt-> opt->* class-contract (rename -contract? contract?) provide/contract define/contract) (require-for-syntax mzscheme (lib "list.ss") (lib "match.ss") (lib "name.ss" "syntax")) (require (lib "class.ss") (lib "etc.ss")) (require (lib "contract-helpers.scm" "mzlib" "private")) (require-for-syntax (prefix a: (lib "contract-helpers.scm" "mzlib" "private"))) ; ; ; ; ; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;;; ;;;; ; ; ;; ;;; ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; ; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;;;; ; ; ; ; ;;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; ; ; ; ; ; ;; (define/contract id contract expr) ;; defines `id' with `contract'; initially binding ;; it to the result of `expr'. These variables may not be set!'d. (define-syntax (define/contract define-stx) (syntax-case define-stx () [(_ name contract-expr expr) (identifier? (syntax name)) (with-syntax ([pos-blame-stx (datum->syntax-object define-stx 'here)] [contract-id (datum->syntax-object define-stx (string->symbol (format "ACK-define/contract-contract-id-~a" (syntax-object->datum (syntax name)))))] [id (datum->syntax-object define-stx (string->symbol (format "ACK-define/contract-id-~a" (syntax-object->datum (syntax name)))))]) (syntax/loc define-stx (begin (define contract-id contract-expr) (define-syntax name (make-set!-transformer (lambda (stx) ;; build-src-loc-string/unk : syntax -> (union #f string) (define (build-src-loc-string/unk stx) (let ([source (syntax-source stx)] [line (syntax-line stx)] [col (syntax-column stx)] [pos (syntax-position stx)]) (cond [(and (string? source) line col) (format "~a: ~a.~a" source line col)] [(and line col) (format "~a.~a" line col)] [(and (string? source) pos) (format "~a: ~a" source pos)] [pos (format "~a" pos)] [else #f]))) (with-syntax ([neg-blame-str (or (build-src-loc-string/unk stx) "")]) (syntax-case stx (set!) [(set! _ arg) (raise-syntax-error 'define/contract "cannot set! a define/contract variable" stx (syntax _))] [(_ arg (... ...)) (syntax/loc stx ((-contract contract-id id (syntax-object->datum (quote-syntax _)) (string->symbol neg-blame-str) (quote-syntax _)) arg (... ...)))] [_ (identifier? (syntax _)) (syntax/loc stx (-contract contract-id id (syntax-object->datum (quote-syntax _)) (string->symbol neg-blame-str) (quote-syntax _)))]))))) (define id (let ([name expr]) name)) ;; let for procedure naming )))] [(_ name contract-expr expr) (raise-syntax-error 'define/contract "expected identifier in first position" define-stx (syntax name))])) ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;;; ; ; ; ;; ; ;;; ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; ; ;; ; ;; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;;; ; ; ;; ; ;;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; ; ; ; ; ; ; ; ; ;; (provide/contract p/c-ele ...) ;; p/c-ele = (id expr) | (struct (id expr) ...) ;; provides each `id' with the contract `expr'. (define-syntax (provide/contract provide-stx) (syntax-case provide-stx (struct) [(_ p/c-ele ...) (let () ;; code-for-each-clause : (listof syntax) -> (listof syntax) ;; constructs code for each clause of a provide/contract (define (code-for-each-clause clauses) (cond [(null? clauses) null] [else (let ([clause (car clauses)]) (syntax-case clause (struct) [(struct struct-name ((field-name contract) ...)) (and (identifier? (syntax struct-name)) (andmap identifier? (syntax->list (syntax (field-name ...))))) (let ([sc (build-struct-code provide-stx (syntax struct-name) (syntax->list (syntax (field-name ...))) (syntax->list (syntax (contract ...))))]) (cons sc (code-for-each-clause (cdr clauses))))] [(struct name) (identifier? (syntax name)) (raise-syntax-error 'provide/contract "missing fields" provide-stx clause)] [(struct name (fields ...)) (for-each (lambda (field) (syntax-case field () [(x y) (identifier? (syntax x)) (void)] [(x y) (raise-syntax-error 'provide/contract "malformed struct field, expected identifier" provide-stx (syntax x))] [else (raise-syntax-error 'provide/contract "malformed struct field" provide-stx field)])) (syntax->list (syntax (fields ...)))) ;; if we didn't find a bad field something is wrong! (raise-syntax-error 'provide/contract "internal error" provide-stx clause)] [(struct name . fields) (raise-syntax-error 'provide/contract "malformed struct fields" provide-stx clause)] [(name contract) (identifier? (syntax name)) (cons (code-for-one-id provide-stx (syntax name) (syntax contract)) (code-for-each-clause (cdr clauses)))] [(name contract) (raise-syntax-error 'provide/contract "expected identifier" provide-stx (syntax name))] [unk (raise-syntax-error 'provide/contract "malformed clause" provide-stx (syntax unk))]))])) ;; build-struct-code : syntax syntax (listof syntax) (listof syntax) -> syntax ;; constructs the code for a struct clause ;; first arg is the original syntax object, for source locations (define (build-struct-code stx struct-name field-names field-contracts) (let* ([field-contract-ids (map (lambda (field-name) (mangle-id "provide/contract-field-contract" field-name struct-name)) field-names)] [selector-ids (map (lambda (field-name) (build-selector-id struct-name field-name)) field-names)] [mutator-ids (map (lambda (field-name) (build-mutator-id struct-name field-name)) field-names)] [predicate-id (build-predicate-id struct-name)] [constructor-id (build-constructor-id struct-name)]) (with-syntax ([(selector-codes ...) (map (lambda (selector-id field-contract-id) (code-for-one-id stx selector-id (build-selector-contract struct-name predicate-id field-contract-id))) selector-ids field-contract-ids)] [(mutator-codes ...) (map (lambda (mutator-id field-contract-id) (code-for-one-id stx mutator-id (build-mutator-contract struct-name predicate-id field-contract-id))) mutator-ids field-contract-ids)] [predicate-code (code-for-one-id stx predicate-id (syntax (-> any? boolean?)))] [constructor-code (code-for-one-id stx constructor-id (build-constructor-contract field-contract-ids predicate-id))] [(field-contracts ...) field-contracts] [(field-contract-ids ...) field-contract-ids] [struct-name struct-name]) (syntax/loc stx (begin (define field-contract-ids field-contracts) ... selector-codes ... mutator-codes ... predicate-code constructor-code (provide struct-name)))))) ;; build-constructor-contract : (listof syntax) syntax -> syntax (define (build-constructor-contract field-contract-ids predicate-id) (with-syntax ([(field-contract-ids ...) field-contract-ids] [predicate-id predicate-id]) (syntax (field-contract-ids ... . -> . (let ([predicate-id (lambda (x) (predicate-id x))]) predicate-id))))) ;; build-selector-contract : syntax syntax -> syntax ;; constructs the contract for a selector (define (build-selector-contract struct-name predicate-id field-contract-id) (with-syntax ([field-contract-id field-contract-id] [predicate-id predicate-id]) (syntax ((let ([predicate-id (lambda (x) (predicate-id x))]) predicate-id) . -> . field-contract-id)))) ;; build-mutator-contract : syntax syntax -> syntax ;; constructs the contract for a selector (define (build-mutator-contract struct-name predicate-id field-contract-id) (with-syntax ([field-contract-id field-contract-id] [predicate-id predicate-id]) (syntax ((let ([predicate-id (lambda (x) (predicate-id x))]) predicate-id) field-contract-id . -> . void?)))) ;; build-constructor-id : syntax -> syntax ;; constructs the name of the selector for a particular field of a struct (define (build-constructor-id struct-name) (datum->syntax-object struct-name (string->symbol (string-append "make-" (symbol->string (syntax-object->datum struct-name)))))) ;; build-predicate-id : syntax -> syntax ;; constructs the name of the selector for a particular field of a struct (define (build-predicate-id struct-name) (datum->syntax-object struct-name (string->symbol (string-append (symbol->string (syntax-object->datum struct-name)) "?")))) ;; build-selector-id : syntax syntax -> syntax ;; constructs the name of the selector for a particular field of a struct (define (build-selector-id struct-name field-name) (datum->syntax-object struct-name (string->symbol (string-append (symbol->string (syntax-object->datum struct-name)) "-" (symbol->string (syntax-object->datum field-name)))))) ;; build-mutator-id : syntax syntax -> syntax ;; constructs the name of the selector for a particular field of a struct (define (build-mutator-id struct-name field-name) (datum->syntax-object struct-name (string->symbol (string-append "set-" (symbol->string (syntax-object->datum struct-name)) "-" (symbol->string (syntax-object->datum field-name)) "!")))) ;; code-for-one-id : syntax syntax syntax -> syntax ;; given the syntax for an identifier and a contract, ;; builds a begin expression for the entire contract and provide ;; the first syntax object is used for source locations (define (code-for-one-id stx id ctrct) (with-syntax ([id-rename (mangle-id "provide/contract-id" id)] [contract-id (mangle-id "provide/contract-contract-id" id)] [pos-module-source (mangle-id "provide/contract-pos-module-source" id)] [pos-stx (datum->syntax-object provide-stx 'here)] [module-source-as-symbol (datum->syntax-object provide-stx 'module-source-as-symbol)] [id id] [ctrct ctrct]) (syntax/loc stx (begin (provide (rename id-rename id)) ;; unbound id check (if #f id) (define pos-module-source (module-source-as-symbol #'pos-stx)) (define contract-id (let ([id ctrct]) id)) (define-syntax id-rename (make-set!-transformer (lambda (stx) (with-syntax ([neg-stx (datum->syntax-object stx 'here)]) (syntax-case stx (set!) [(set! _ body) (raise-syntax-error #f "cannot set! provide/contract identifier" stx (syntax _))] [(_ arg (... ...)) (syntax ((-contract contract-id id pos-module-source (module-source-as-symbol #'neg-stx) (quote-syntax _)) arg (... ...)))] [_ (identifier? (syntax _)) (syntax (-contract contract-id id pos-module-source (module-source-as-symbol #'neg-stx) (quote-syntax _)))]))))))))) ;; mangle-id : string syntax ... -> syntax ;; constructs a mangled name of an identifier from an identifier ;; the name isn't fresh, so `id' combined with `ids' must already be unique. (define (mangle-id prefix id . ids) (datum->syntax-object provide-stx (string->symbol (string-append prefix (format "-~a~a-ACK-PLEASE_DONT_GUESS_THIS_ID" (syntax-object->datum id) (apply string-append (map (lambda (id) (format "-~a" (syntax-object->datum id))) ids))))))) (with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))]) (syntax (begin (require (lib "contract-helpers.scm" "mzlib" "private")) bodies ...))))])) ; ; ; ; ; ; ; ; ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; ; ; ; ;; contract = (make-contract (alpha ;; sym ;; sym ;; (union syntax #f) ;; -> ;; alpha) ;; (contract alpha sym src-info -> alpha) ;; (??? -> ???) ;; generic contract container; ;; the first argument to wrap is the value to test the contract. ;; the second to wrap is a symbol representing the name of the positive blame ;; the third to wrap is the symbol representing the name of the negative blame ;; the fourth argument to wrap is the src-info. ;; ;; impl-builder and impl-info are two pieces used to build ;; implication contracts. (define-struct contract (wrap impl-builder impl-info)) ;; flat-named-contract = (make-flat-named-contract string (any -> boolean)) ;; this holds flat contracts that have names for error reporting (define-struct flat-named-contract (type-name predicate)) (provide (rename build-flat-named-contract flat-named-contract) flat-named-contract-type-name flat-named-contract-predicate) (define build-flat-named-contract (let ([flat-named-contract (lambda (name contract) (unless (and (string? name) (procedure? contract) (procedure-arity-includes? contract 1)) (error 'flat-named-contract "expected string and procedure of one argument as arguments, given: ~e and ~e" name contract)) (make-flat-named-contract name contract))]) flat-named-contract)) (define -contract? (let ([contract? (lambda (val) (or (contract? val) ;; refers to struct predicate (flat-named-contract? val) (and (procedure? val) (procedure-arity-includes? val 1))))]) contract?)) (define-syntax -contract (lambda (stx) (syntax-case stx () [(_ a-contract to-check pos-blame-e neg-blame-e) (with-syntax ([src-loc (datum->syntax-object stx 'here)]) (syntax/loc stx (-contract a-contract to-check pos-blame-e neg-blame-e (quote-syntax src-loc))))] [(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e) (syntax/loc stx (let ([a-contract a-contract-e] [name to-check] [neg-blame neg-blame-e] [pos-blame pos-blame-e] [src-info src-info-e]) (unless (-contract? a-contract) (error 'contract "expected a contract as first argument, given: ~e, other args ~e ~e ~e ~e" a-contract name pos-blame neg-blame src-info)) (unless (and (symbol? neg-blame) (symbol? pos-blame)) (error 'contract "expected symbols as names for assigning blame, given: ~e and ~e, other args ~e ~e ~e" neg-blame pos-blame a-contract name src-info)) (unless (syntax? src-info) (error 'contract "expected syntax as last argument, given: ~e, other args ~e ~e ~e ~e" src-info neg-blame pos-blame a-contract name)) (check-contract a-contract name pos-blame neg-blame src-info)))]))) ;; check-contract : contract any symbol symbol syntax -> ... (define (check-contract contract val pos neg src-info) (cond [(contract? contract) ((contract-wrap contract) val pos neg src-info)] [(flat-named-contract? contract) (if ((flat-named-contract-predicate contract) val) val (raise-contract-error src-info pos neg "expected type <~a>, given: ~e" (flat-named-contract-type-name contract) val))] [else (if (contract val) val (raise-contract-error src-info pos neg "~agiven: ~e" (predicate->expected-msg contract) val))])) (define-syntax (contract-=> stx) (syntax-case stx () [(_ ant-e conq-e val-e tbb-e) (with-syntax ([src-loc (datum->syntax-object stx 'here)]) (syntax/loc stx (contract-=> ant-e conq-e val-e tbb-e (quote-syntax src-loc))))] [(_ ant-e conq-e val-e tbb-e src-info-e) (syntax/loc stx (let ([c1 ant-e] [c2 conq-e] [val val-e] [tbb tbb-e] [src-info src-info-e]) (unless (-contract? c1) (error 'contract-=> "expected a contract as first argument, given: ~e, other args ~e ~e ~e ~e" c1 c2 val tbb src-loc)) (unless (-contract? c2) (error 'contract-=> "expected a contract as second argument, given: ~e, other args ~e ~e ~e ~e" c2 c1 val tbb src-loc)) (unless (symbol? tbb) (error 'contract-=> "expected symbol as names for assigning blame, given: ~e, other args ~e ~e ~e ~e" tbb c1 c2 val src-loc)) (unless (syntax? src-info) (error 'contract "expected syntax as last argument, given: ~e, other args ~e ~e ~e ~e" src-info neg-blame pos-blame a-contract name)) (check-implication c1 c2 val tbb src-info)))])) ;; check-implication : contract contract any symbol (union syntax #f) -> any (define (check-implication antecedent consequent val tbb src-info) (cond [(and (contract? antecedent) (contract? consequent)) ((contract-impl-builder consequent) antecedent consequent val tbb src-info)] [(or (contract? antecedent) (contract? consequent)) (raise-contract-implication-error antecedent consequent val tbb src-info)] [else (let ([test-contract (lambda (c) (cond [(flat-named-contract? c) ((flat-named-contract-predicate c) val)] [else (c val)]))]) (if (or (not (test-contract antecedent)) (test-contract consequent)) val (raise-contract-implication-error antecedent consequent val tbb src-info)))])) ;; raise-contract-implication-error : contract contract any symbol (union syntax #f) -> alpha ;; escapes (define (raise-contract-implication-error antecedent consequent val tbb src-info) (let ([blame-src (src-info-as-string src-info)]) (raise (make-exn (string->immutable-string (format "~a~a: ~a does not imply ~a for ~e" blame-src tbb (contract->type-name antecedent) (contract->type-name consequent) val)) (current-continuation-marks))))) ;; raise-contract-error : (union syntax #f) symbol symbol string args ... -> alpha ;; doesn't return (define (raise-contract-error src-info to-blame other-party fmt . args) (let ([blame-src (src-info-as-string src-info)] [specific-blame (let ([datum (syntax-object->datum src-info)]) (if (symbol? datum) (format "broke ~a's contract" datum) "failed contract"))]) (raise (make-exn (string->immutable-string (string-append (format "~a~a: ~a ~a: " blame-src other-party to-blame specific-blame) (apply format fmt args))) (current-continuation-marks))))) ;; src-info-as-string : (union syntax #f) -> string (define (src-info-as-string src-info) (if (syntax? src-info) (let ([src-loc-str (build-src-loc-string src-info)]) (if src-loc-str (string-append src-loc-str ": ") "")) "")) ;; predicate->expected-msg : function -> string ;; if the function has a name and the name ends ;; with a question mark, turn it into a mzscheme ;; style type name (define (predicate->expected-msg pred) (let ([name (predicate->type-name pred)]) (if name (format "expected type <~a>, " name) ""))) ;; predicate->type-name : pred -> (union #f string) (define (predicate->type-name pred) (let* ([name (object-name pred)]) (and name (let ([m (regexp-match "(.*)\\?" (symbol->string name))]) (and m (cadr m)))))) ;; contract->type-name : contract -> string (define (contract->type-name c) (cond [(contract? c) "arrow contract"] [else (flat-contract->type-name c)])) ;; flat-contract->type-name : flat-contract -> string (define (flat-contract->type-name fc) (cond [(flat-named-contract? fc) (flat-named-contract-type-name fc)] [else (or (predicate->type-name fc) "unknown type")])) ; ; ; ; ; ; ; ; ; ; ;; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; ;;; ; ;; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ; ;;;;;; ;; ; ; ; ; ; ; ; ;;;; ; ; ;; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; ;;; ; ; ; (define-syntax-set (-> ->* ->d ->d* case-> class-contract) ;; ->/proc : syntax -> syntax ;; the transformer for the -> macro (define (->/proc stx) (make-/proc ->/h stx)) ;; ->*/proc : syntax -> syntax ;; the transformer for the ->* macro (define (->*/proc stx) (make-/proc ->*/h stx)) ;; ->d/proc : syntax -> syntax ;; the transformer for the ->d macro (define (->d/proc stx) (make-/proc ->d/h stx)) ;; ->d*/proc : syntax -> syntax ;; the transformer for the ->d* macro (define (->d*/proc stx) (make-/proc ->d*/h stx)) ;; case->/proc : syntax -> syntax ;; the transformer for the case-> macro (define (case->/proc stx) (syntax-case stx () [(_ case ...) (let-values ([(add-outer-check make-inner-check make-bodies _1 _2) (case->/h stx (syntax->list (syntax (case ...))))]) (let ([outer-args (syntax (val pos-blame neg-blame src-info))]) (with-syntax ([outer-args outer-args] [(inner-check ...) (make-inner-check outer-args)] [(body ...) (make-bodies outer-args)]) (with-syntax ([inner-lambda (set-inferred-name-from stx (syntax/loc stx (case-lambda body ...)))]) (add-outer-check (syntax/loc stx (make-contract (lambda outer-args inner-check ... inner-lambda) (lambda x (error 'impl-contract "unimplemented")) (lambda x (error 'impl-contract "unimplemented")) )))))))])) (define (class-contract/proc stx) (syntax-case stx () [(_ (meth-name meth-contract) ...) (andmap identifier? (syntax->list (syntax (meth-name ...)))) (match-let ([(`(,make-outer-checks ,xxx ,build-pieces) ...) (map (lambda (meth-contract-stx) (let ([/h (select/h meth-contract-stx 'class-contract stx)]) (let-values ([(make-outer-check xxx build-pieces impl-builder impl-info) (/h meth-contract-stx)]) (list make-outer-check xxx build-pieces)))) (syntax->list (syntax (meth-contract ...))))]) (let* ([outer-args (syntax (val pos-blame neg-blame src-info))] [meth-names (syntax->list (syntax (meth-name ...)))] [super-meth-names (map prefix-super meth-names)]) (with-syntax ([outer-args outer-args] [(super-meth-name ...) super-meth-names] [(method ...) (map (lambda (a b c) (make-wrapper-method outer-args a b c)) meth-names super-meth-names build-pieces)]) (foldr (lambda (f stx) (f stx)) (syntax/loc stx (make-contract (lambda outer-args (unless (class? val) (raise-contract-error src-info pos-blame neg-blame "expected a class, got: ~e" val)) (let ([class-i (class->interface val)]) (void) (unless (method-in-interface? 'meth-name class-i) (raise-contract-error src-info pos-blame neg -blame "expected class to have method ~a, got: ~e" 'meth-name val)) ...) (class val (rename [super-meth-name meth-name] ...) method ... (super-instantiate ()))) (lambda x (error 'impl-contract "unimplemented")) (lambda x (error 'impl-contract "unimplemented")))) make-outer-checks))))] [(_ (meth-name meth-contract) ...) (for-each (lambda (name) (unless (identifier? name) (raise-syntax-error 'class-contract "expected name" stx name))) (syntax->list (syntax (meth-name ...))))] [(_ clz ...) (for-each (lambda (clz) (syntax-case clz () [(a b) (void)] [else (raise-syntax-error 'class-contract "bad method/contract clause" stx clz)])) (syntax->list (syntax (clz ...))))])) ;; make-wrapper-method : syntax[identifier] syntax[identifier] (syntax -> syntax) -> syntax ;; constructs a wrapper method that checks the pre and post-condition, and ;; calls the super method inbetween. (define (make-wrapper-method outer-args method-name super-method-name build-piece) (with-syntax ([super-method-name super-method-name] [method-name method-name] [(val pos-blame neg-blame src-info) outer-args] [super-call (car (generate-temporaries (list super-method-name)))]) (with-syntax ([(args body) (build-piece (syntax (super-call pos-blame neg-blame src-info)))]) (syntax (define/override method-name (let ([super-call (lambda x (super-method-name . x))]) (lambda args body))))))) ;; prefix-super : syntax[identifier] -> syntax[identifier] ;; adds super- to the front of the identifier (define (prefix-super stx) (datum->syntax-object #'here (string->symbol (format "super-~a" (syntax-object->datum stx))))) ;; Each of the /h functions builds three pieces of syntax: ;; - code that binds the contract values to names and ;; does error checking for the contract specs ;; (were the arguments all contracts?) ;; - code that does error checking on the contract'd value itself ;; (is a function of the right arity?) ;; - a piece of syntax that has the arguments to the wrapper ;; and the body of the wrapper. ;; the first function accepts a body expression and wraps ;; the body expression with checks. In addition, it ;; adds a let that binds the contract exprssions to names ;; the results of the other functions mention these names. ;; the second and third function's input syntax should be four ;; names: val, pos-blame, neg-blame, src-info. ;; the third function returns a syntax list with two elements, ;; the argument list (to be used as the first arg to lambda, ;; or as a case-lambda clause) and the body of the function. ;; They are combined into a lambda for the -> ->* ->d ->d* macros, ;; and combined into a case-lambda for the case-> macro. ;; ->/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) (define (->/h stx) (syntax-case stx () [(_) (raise-syntax-error '-> "expected at least one argument" stx)] [(_ ct ...) (let* ([rng-normal (car (last-pair (syntax->list (syntax (ct ...)))))] [ignore-range-checking? (syntax-case rng-normal (any) [any #t] [_ #f])]) (with-syntax ([(dom ...) (all-but-last (syntax->list (syntax (ct ...))))] [rng (if ignore-range-checking? (syntax any?) ;; hack to simplify life... rng-normal)]) (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))] [arity (length (syntax->list (syntax (dom ...))))]) (let ([->add-outer-check (lambda (body) (with-syntax ([body body]) (syntax/loc stx (let ([dom-x dom] ... [rng-x rng]) (unless (-contract? dom-x) (error '-> "expected contract as argument, given: ~e" dom-x)) ... (unless (-contract? rng-x) (error '-> "expected contract as argument, given: ~e" rng-x)) body))))] [->body (syntax (->* (dom-x ...) (rng-x)))]) (let-values ([(->*add-outer-check ->*make-inner-check ->*make-body impl-builder impl-info) (->*/h ->body)]) (values (lambda (body) (->add-outer-check (->*add-outer-check body))) (lambda (stx) (->*make-inner-check stx)) (if ignore-range-checking? (lambda (stx) (with-syntax ([(val pos-blame neg-blame src-info) stx]) (syntax ((arg-x ...) (val (check-contract dom-x arg-x neg-blame pos-blame src-info) ...))))) (lambda (stx) (->*make-body stx))) impl-builder impl-info))))))])) ;; ->*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) (define (->*/h stx) (syntax-case stx () [(_ (dom ...) (rng ...)) (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))] [(rng-x ...) (generate-temporaries (syntax (rng ...)))] [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))] [(res-x ...) (generate-temporaries (syntax (rng ...)))] [arity (length (syntax->list (syntax (dom ...))))]) (values (lambda (body) (with-syntax ([body body]) (syntax (let ([dom-x dom] ... [rng-x rng] ...) (unless (-contract? dom-x) (error '->* "expected contract as argument, given: ~e" dom-x)) ... (unless (-contract? rng-x) (error '->* "expected contract as argument, given: ~e" rng-x)) ... body)))) (lambda (stx) (with-syntax ([(val pos-blame neg-blame src-info) stx]) (syntax (unless (and (procedure? val) (procedure-arity-includes? val arity)) (raise-contract-error src-info pos-blame neg-blame "expected a procedure that accepts ~a arguments, given: ~e" arity val))))) (lambda (stx) (with-syntax ([(val pos-blame neg-blame src-info) stx]) (syntax ((arg-x ...) (let-values ([(res-x ...) (val (check-contract dom-x arg-x neg-blame pos-blame src-info) ...)]) (values (check-contract rng-x res-x pos-blame neg-blame src-info) ...)))))) (syntax (lambda (ant conq val tbb src-info) (let* ([ant-info (contract-impl-info conq)] [dom-ant-info (ant-info dom-length)]) (if dom-ant-info (let ([dom-ant-x (vector-ref dom-ant-info dom-index)] ...) (lambda (arg-x ...) (val (check-implication dom-x dom-ant-x arg-x tbb src-info) ...))) (raise-contract-implication-error ant conq val tbb src-info))))) (syntax (lambda (len) (cond [(= len dom-length) (vector dom-x ...)] [else #f])))))] [(_ (dom ...) rest (rng ...)) (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))] [(rng-x ...) (generate-temporaries (syntax (rng ...)))] [(res-x ...) (generate-temporaries (syntax (rng ...)))] [arity (length (syntax->list (syntax (dom ...))))]) (values (lambda (body) (with-syntax ([body body]) (syntax (let ([dom-x dom] ... [dom-rest-x rest] [rng-x rng] ...) (unless (-contract? dom-x) (error '->* "expected contract for domain position, given: ~e" dom-x)) ... (unless (-contract? dom-rest-x) (error '->* "expected contract for rest position, given: ~e" dom-rest-x)) (unless (-contract? rng-x) (error '->* "expected contract for range position, given: ~e" rng-x)) ... body)))) (lambda (stx) (with-syntax ([(val check-rev-contract check-same-contract failure) stx]) (syntax (unless (procedure? val) (raise-contract-error src-info pos-blame neg-blame "expected a procedure that accepts ~a arguments, given: ~e" arity val))))) (lambda (stx) (with-syntax ([(val pos-blame neg-blame src-info) stx]) (syntax ((arg-x ... . rest-arg-x) (let-values ([(res-x ...) (apply val (check-contract dom-x arg-x neg-blame pos-blame src-info) ... (check-contract dom-rest-x rest-arg-x neg-blame pos-blame src-info))]) (values (check-contract rng-x res-x pos-blame neg-blame src-info) ...)))))) (syntax (lambda x (error 'impl-contract "unimplemented"))) (syntax (lambda x (error 'impl-contract "unimplemented")))))])) ;; ->d/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) (define (->d/h stx) (syntax-case stx () [(_) (raise-syntax-error '->d "expected at least one argument" stx)] [(_ ct ...) (with-syntax ([(dom ...) (all-but-last (syntax->list (syntax (ct ...))))] [rng (car (last-pair (syntax->list (syntax (ct ...)))))]) (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))] [arity (length (syntax->list (syntax (dom ...))))]) (values (lambda (body) (with-syntax ([body body]) (syntax (let ([dom-x dom] ... [rng-x rng]) (unless (-contract? dom-x) (error '->d "expected contract as argument, given: ~e" dom-x)) ... (unless (and (procedure? rng-x) (procedure-arity-includes? rng-x arity)) (error '->d "expected range portion to be a function that takes ~a arguments, given: ~e" arity rng-x)) body)))) (lambda (stx) (with-syntax ([(val pos-blame neg-blame src-info) stx]) (syntax (unless (and (procedure? val) (procedure-arity-includes? val arity)) (raise-contract-error src-info pos-blame neg-blame "expected a procedure that accepts ~a arguments, given: ~e" arity val))))) (lambda (stx) (with-syntax ([(val pos-blame neg-blame src-info) stx]) (syntax ((arg-x ...) (let ([rng-contract (rng-x arg-x ...)]) (unless (-contract? rng-contract) (error '->d "expected range portion to return a contract, given: ~e" rng-contract)) (check-contract rng-contract (val (check-contract dom-x arg-x neg-blame pos-blame src-info) ...) pos-blame neg-blame src-info)))))) (syntax (lambda x (error 'impl-contract "unimplemented"))) (syntax (lambda x (error 'impl-contract "unimplemented"))))))])) ;; ->d*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) (define (->d*/h stx) (syntax-case stx () [(_ (dom ...) rng-mk) (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))] [arity (length (syntax->list (syntax (dom ...))))]) (values (lambda (body) (with-syntax ([body body]) (syntax (let ([dom-x dom] ... [rng-mk-x rng-mk]) (unless (-contract? dom-x) (error '->*d "expected contract as argument, given: ~e" dom-x)) ... (unless (and (procedure? rng-mk-x) (procedure-arity-includes? rng-mk-x arity)) (error '->*d "expected range position to be a procedure that accepts ~a arguments, given: ~e" arity rng-mk-x)) body)))) (lambda (stx) (with-syntax ([(val pos-blame neg-blame src-info) stx]) (syntax (unless (and (procedure? val) (procedure-arity-includes? val arity)) (raise-contract-error src-info pos-blame neg-blame "expected a procedure that accepts ~a arguments, given: ~e" arity val))))) (lambda (stx) (with-syntax ([(val pos-blame neg-blame src-info) stx]) (syntax ((arg-x ...) (call-with-values (lambda () (rng-mk-x arg-x ...)) (lambda rng-contracts (call-with-values (lambda () (val (check-contract dom-x arg-x neg-blame pos-blame src-info) ...)) (lambda results (unless (= (length results) (length rng-contracts)) (error '->d* "expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively" (length results) (length rng-contracts))) (apply values (map (lambda (rng-contract result) (check-contract rng-contract result pos-blame neg-blame src-info)) rng-contracts results)))))))))) (syntax (lambda x (error 'impl-contract "unimplemented"))) (syntax (lambda x (error 'impl-contract "unimplemented")))))] [(_ (dom ...) rest rng-mk) (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] [(arg-x ...) (generate-temporaries (syntax (dom ...)))] [arity (length (syntax->list (syntax (dom ...))))]) (values (lambda (body) (with-syntax ([body body]) (syntax (let ([dom-x dom] ... [dom-rest-x rest] [rng-mk-x rng-mk]) (unless (-contract? dom-x) (error '->*d "expected contract as argument, given: ~e" dom-x)) ... (unless (-contract? dom-rest-x) (error '->*d "expected contract for rest argument, given: ~e" dom-rest-x)) (unless (procedure? rng-mk-x) (error '->*d "expected range position to be a procedure that accepts ~a arguments, given: ~e" arity rng-mk-x)) body)))) (lambda (stx) (with-syntax ([(val pos-blame neg-blame src-info) stx]) (syntax (unless (procedure? val) (raise-contract-error src-info pos-blame neg-blame "expected a procedure that accepts ~a arguments, given: ~e" arity val))))) (lambda (stx) (with-syntax ([(val pos-blame neg-blame src-info) stx]) (syntax ((arg-x ... . rest-arg-x) (call-with-values (lambda () (apply rng-mk-x arg-x ... rest-arg-x)) (lambda rng-contracts (call-with-values (lambda () (apply val (check-contract dom-x arg-x neg-blame pos-blame src-info) ... (check-contract dom-rest-x rest-arg-x neg-blame pos-blame src-info))) (lambda results (unless (= (length results) (length rng-contracts)) (error '->d* "expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively" (length results) (length rng-contracts))) (apply values (map (lambda (rng-contract result) (check-contract rng-contract result pos-blame neg-blame src-info )) rng-contracts results)))))))))) (syntax (lambda x (error 'impl-contract "unimplemented"))) (syntax (lambda x (error 'impl-contract "unimplemented")))))])) ;; make-/proc : (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))) ;; syntax ;; -> (syntax -> syntax) (define (make-/proc /h stx) (let-values ([(add-outer-check make-inner-check make-main impl-first impl-second) (/h stx)]) (let ([outer-args (syntax (val pos-blame neg-blame src-info))]) (with-syntax ([outer-args outer-args] [inner-check (make-inner-check outer-args)] [(inner-args body) (make-main outer-args)] [impl-first impl-first] [impl-second impl-second]) (with-syntax ([inner-lambda (set-inferred-name-from stx (syntax/loc stx (lambda inner-args body)))]) (add-outer-check (set-inferred-name-from stx (syntax/loc stx (make-contract (lambda outer-args inner-check inner-lambda) impl-first impl-second))))))))) ;; case->/h : syntax (listof syntax) -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) ;; like the other /h functions, but composes the wrapper functions ;; together and combines the cases of the case-lambda into a single list. (define (case->/h orig-stx cases) (let loop ([cases cases]) (cond [(null? cases) (values (lambda (x) x) (lambda (args) (syntax ())) (lambda (args) (syntax ())) (syntax (lambda x (error 'impl-contract "unimplemented"))) (syntax (lambda x (error 'impl-contract "unimplemented"))))] [else (let ([/h (select/h (car cases) 'case-> orig-stx)]) (let-values ([(add-outer-checks make-inner-checks make-bodies _a _b) (loop (cdr cases))] [(add-outer-check make-inner-check make-body _1 _2) (/h (car cases))]) (values (lambda (x) (add-outer-check (add-outer-checks x))) (lambda (args) (with-syntax ([checks (make-inner-checks args)] [check (make-inner-check args)]) (syntax (check . checks)))) (lambda (args) (with-syntax ([case (make-body args)] [cases (make-bodies args)]) (syntax (case . cases)))) (syntax (lambda x (error 'impl-contract "unimplemented"))) (syntax (lambda x (error 'impl-contract "unimplemented"))))))]))) ;; select/h : syntax -> /h-function (define (select/h stx err-name ctxt-stx) (syntax-case stx (-> ->* ->d ->d*) [(-> . args) ->/h] [(->* . args) ->*/h] [(->d . args) ->d/h] [(->d* . args) ->d*/h] [(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))] [_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)])) ;; set-inferred-name-from : syntax syntax -> syntax (define (set-inferred-name-from with-name to-be-named) (let ([name (syntax-local-infer-name with-name)]) (cond [(identifier? name) (syntax-property to-be-named 'inferred-name (syntax-e name))] [(symbol? name) (syntax-property to-be-named 'inferred-name name)] [else to-be-named]))) ;; (cons X (listof X)) -> (listof X) ;; returns the elements of `l', minus the last ;; element (define (all-but-last l) (cond [(null? l) (error 'all-but-last "bad input")] [(null? (cdr l)) null] [else (cons (car l) (all-but-last (cdr l)))])) ;; generate-indicies : syntax[list] -> (cons number (listof number)) ;; given a syntax list of length `n', returns a list containing ;; the number n followed by th numbers from 0 to n-1 (define (generate-indicies stx) (let ([n (length (syntax->list stx))]) (cons n (let loop ([i n]) (cond [(zero? i) null] [else (cons (- n i) (loop (- i 1)))])))))) (define-syntax (opt-> stx) (syntax-case stx () [(_ (reqs ...) (opts ...) res) (syntax (opt->* (reqs ...) (opts ...) (res)))])) (define-syntax (opt->* stx) (syntax-case stx () [(_ (reqs ...) (opts ...) (ress ...)) (let* ([res-vs (generate-temporaries (syntax->list (syntax (ress ...))))] [req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))] [opt-vs (generate-temporaries (syntax->list (syntax (opts ...))))] [cases (reverse (let loop ([opt-vs (reverse opt-vs)]) (cond [(null? opt-vs) (list req-vs)] [else (cons (append req-vs (reverse opt-vs)) (loop (cdr opt-vs)))])))]) (with-syntax ([((double-res-vs ...) ...) (map (lambda (x) res-vs) cases)] [(res-vs ...) res-vs] [(req-vs ...) req-vs] [(opt-vs ...) opt-vs] [((case-doms ...) ...) cases]) (syntax/loc stx (let ([res-vs ress] ... [req-vs reqs] ... [opt-vs opts] ...) (case-> (->* (case-doms ...) (double-res-vs ...)) ...)))))])) ; ; ; ; ; ; ; ; ; ; ; ;; ;; ; ;;; ;;; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; ;;; ; ;; ;; ; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;;;; ; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; ;;; ; ; ; (provide union) (define (union . args) (for-each (lambda (x) (unless (-contract? x) (error 'union "expected procedures of arity 1, flat-named-contracts, or -> contracts, given: ~e" x))) args) (let-values ([(contracts procs) (let loop ([ctcs null] [procs null] [args args]) (cond [(null? args) (values ctcs procs)] [else (let ([arg (car args)]) (if (contract? arg) (loop (cons arg ctcs) procs (cdr args)) (loop ctcs (cons arg procs) (cdr args))))]))]) (unless (or (null? contracts) (null? (cdr contracts))) (error 'union "expected at most one function contract, given: ~e" args)) (cond [(null? contracts) (make-flat-named-contract (apply build-compound-type-name "union" procs) (lambda (x) (ormap (lambda (proc) (test-flat-contract proc x)) procs)))] [else (make-contract (lambda (val pos neg src-info) (cond [(ormap (lambda (proc) (if (flat-named-contract? proc) ((flat-named-contract-predicate proc) val) (proc val))) procs) val] [(null? contracts) (raise-contract-error src-info pos neg "union failed, given: ~e" val)] [(null? (cdr contracts)) ((contract-wrap (car contracts)) val pos neg src-info)])) (lambda x (error 'impl-contract "unimplemented")) (lambda x (error 'impl-contract "unimplemented")))]))) (provide and/f or/f >=/c <=/c /c natural-number? false? any? printable? symbols subclass?/c implementation?/c is-a?/c listof vectorof vector/p cons/p list/p box/p mixin-contract make-mixin-contract) ;; test-flat-contract : (union pred flat-named-contract) any -> boolean (define (test-flat-contract flat-contract x) (cond [(flat-named-contract? flat-contract) ((flat-named-contract-predicate flat-contract) x)] [else (flat-contract x)])) ;; flat-contract? : any -> boolean? ;; determines if a value is a flat contract (define (flat-contract? fc) (or (flat-named-contract? fc) (and (procedure? fc) (procedure-arity-includes? fc 1)))) (define (build-compound-type-name name . fs) (let ([strs (map flat-contract->type-name fs)]) (format "(~a~a)" name (apply string-append (let loop ([strs strs]) (cond [(null? strs) null] [else (cons " " (cons (car strs) (loop (cdr strs))))])))))) (define (symbols . ss) (unless ((length ss) . >= . 1) (error 'symbols "expected at least one argument")) (unless (andmap symbol? ss) (error 'symbols "expected symbols as arguments, given: ~a" (apply string-append (map (lambda (x) (format "~e " x)) ss)))) (make-flat-named-contract (apply string-append (format "'~a" (car ss)) (map (lambda (x) (format ", '~a" x)) (cdr ss))) (lambda (x) (memq x ss)))) (define printable? (make-flat-named-contract "printable" (lambda (x) (let printable? ([x x]) (or (symbol? x) (string? x) (boolean? x) (char? x) (null? x) (number? x) (and (pair? x) (printable? (car x)) (printable? (cdr x))) (and (vector? x) (andmap printable? (vector->list x))) (and (box? x) (printable? (unbox x)))))))) (define (and/f . fs) (for-each (lambda (x) (unless (or (flat-named-contract? x) (and (procedure? x) (procedure-arity-includes? x 1))) (error 'and/f "expected procedures of arity 1 or s, given: ~e" x))) fs) (make-flat-named-contract (apply build-compound-type-name "and/f" fs) (lambda (x) (andmap (lambda (f) (test-flat-contract f x)) fs)))) (define (or/f . fs) (for-each (lambda (x) (unless (or (flat-named-contract? x) (and (procedure? x) (procedure-arity-includes? x 1))) (error 'or/f "expected procedures of arity 1 or s, given: ~e" x))) fs) (make-flat-named-contract (apply build-compound-type-name "or/f" fs) (lambda (x) (ormap (lambda (f) (test-flat-contract f x)) fs)))) (define (>=/c x) (make-flat-named-contract (format "number >= ~a" x) (lambda (y) (and (number? y) (>= y x))))) (define (<=/c x) (make-flat-named-contract (format "number <= ~a" x) (lambda (y) (and (number? y) (<= y x))))) (define (/c x) (make-flat-named-contract (format "number > ~a" x) (lambda (y) (and (number? y) (> y x))))) (define natural-number? (make-flat-named-contract "natural-number" (lambda (x) (and (number? x) (integer? x) (x . >= . 0))))) (define (is-a?/c <%>) (unless (or (interface? <%>) (class? <%>)) (error 'is-a?/c "expected or , given: ~e" <%>)) (let ([name (object-name <%>)]) (make-flat-named-contract (if name (format "instance of ~a" name) "instance of <>") (lambda (x) (is-a? x <%>))))) (define (subclass?/c %) (unless (class? %) (error 'subclass?/c "expected type , given: ~e" %)) (let ([name (object-name %)]) (make-flat-named-contract (if name (format "subclass of ~a" name) "subclass of <>") (lambda (x) (subclass? x %))))) (define (implementation?/c <%>) (unless (interface? <%>) (error 'implementation?/c "expected , given: ~e" <%>)) (let ([name (object-name <%>)]) (make-flat-named-contract (if name (format "implementation of ~a" name) "implementation of <>") (lambda (x) (implementation? x <%>))))) (define false? (make-flat-named-contract "false" (lambda (x) (not x)))) (define any? (make-flat-named-contract "any" (lambda (x) #t))) (define (listof p) (unless (flat-contract? p) (error 'listof "expected a flat contract as argument, got: ~e" p)) (make-flat-named-contract (build-compound-type-name "listof" p) (lambda (v) (and (list? v) (andmap (lambda (ele) (test-flat-contract p ele)) v))))) (define (vectorof p) (unless (flat-contract? p) (error 'vectorof "expected a flat contract as argument, got: ~e" p)) (make-flat-named-contract (build-compound-type-name "vectorof" p) (lambda (v) (and (vector? v) (andmap (lambda (ele) (test-flat-contract p ele)) (vector->list v)))))) (define (vector/p . args) (unless (andmap flat-contract? args) (error 'vector/p "expected flat contracts as arguments, got: ~a" (let loop ([args args]) (cond [(null? args) ""] [(null? (cdr args)) (format "~e" (car args))] [else (string-append (format "~e " (car args)) (loop (cdr args)))])))) (make-flat-named-contract (apply build-compound-type-name "vector/p" args) (lambda (v) (and (vector? v) (= (vector-length v) (length args)) (andmap test-flat-contract args (vector->list v)))))) (define (box/p pred) (unless (flat-contract? pred) (error 'box/p "expected a flat contract, got: ~e" pred)) (make-flat-named-contract (build-compound-type-name "box/p" pred) (lambda (x) (and (box? x) (test-flat-contract pred (unbox x)))))) (define (cons/p hdp tlp) (unless (and (flat-contract? hdp) (flat-contract? tlp)) (error 'cons/p "expected two flat contracts, got: ~e and ~e" hdp tlp)) (make-flat-named-contract (build-compound-type-name "cons/p" hdp tlp) (lambda (x) (and (pair? x) (test-flat-contract hdp (car x)) (test-flat-contract tlp (cdr x)))))) (define (list/p . args) (unless (andmap flat-contract? args) (error 'list/p "expected flat contracts, got: ~a" (let loop ([args args]) (cond [(null? args) ""] [(null? (cdr args)) (format "~e" (car args))] [else (string-append (format "~e " (car args)) (loop (cdr args)))])))) (let loop ([args args]) (cond [(null? args) null?] [else (cons/p (car args) (loop (cdr args)))]))) (define mixin-contract (class? . ->d . subclass?/c)) (define (make-mixin-contract . %/<%>s) ((and/f class? (apply and/f (map sub/impl?/c %/<%>s))) . ->d . subclass?/c)) (define (sub/impl?/c %/<%>) (cond [(interface? %/<%>) (implementation?/c %/<%>)] [(class? %/<%>) (subclass?/c %/<%>)] [else (error 'make-mixin-contract "unknown input ~e" %/<%>)])))