From 2634eccdc796e6ed0b242f69f00e9e896d8fb171 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 3 Dec 2009 00:54:02 +0000 Subject: [PATCH] unstable/contract: added if/c combinator other minor changes svn: r17171 --- collects/unstable/contract.ss | 43 +++++++++++++++++++- collects/unstable/mutated-vars.ss | 6 ++- collects/unstable/scribblings/contract.scrbl | 38 +++++++++++++++-- collects/unstable/struct.ss | 25 +++++++----- 4 files changed, 94 insertions(+), 18 deletions(-) diff --git a/collects/unstable/contract.ss b/collects/unstable/contract.ss index a7b22b9c50..f3d7d286c1 100644 --- a/collects/unstable/contract.ss +++ b/collects/unstable/contract.ss @@ -1,4 +1,5 @@ -#lang scheme +#lang scheme/base +(require scheme/contract) (define path-element? (or/c path-string? (symbols 'up 'same))) @@ -13,7 +14,45 @@ ;; Eli: If this gets in, there should also be versions for bytes, lists, and ;; vectors. +;; ryanc added: + +;; (if/c predicate then/c else/c) applies then/c to satisfying +;; predicate, else/c to those that don't. +(define (if/c predicate then/c else/c) + #| + Naive version: + (or/c (and/c predicate then/c) + (and/c (not/c predicate) else/c)) + But that applies predicate twice. + |# + (let ([then-ctc (coerce-contract 'if/c then/c)] + [else-ctc (coerce-contract 'if/c else/c)]) + (define name (build-compound-type-name 'if/c predicate then-ctc else-ctc)) + ;; Special case: if both flat contracts, make a flat contract. + (if (and (flat-contract? then-ctc) + (flat-contract? else-ctc)) + ;; flat contract + (let ([then-pred (flat-contract-predicate then-ctc)] + [else-pred (flat-contract-predicate else-ctc)]) + (define (pred x) + (if (predicate x) (then-pred x) (else-pred x))) + (flat-named-contract name pred)) + ;; ho contract + (let ([then-proj ((proj-get then-ctc) then-ctc)] + [then-fo ((first-order-get then-ctc) then-ctc)] + [else-proj ((proj-get else-ctc) else-ctc)] + [else-fo ((first-order-get else-ctc) else-ctc)]) + (define ((proj pos neg srcinfo name pos?) x) + (if (predicate x) + ((then-proj pos neg srcinfo name pos?) x) + ((else-proj pos neg srcinfo name pos?) x))) + (make-proj-contract + name + proj + (lambda (x) (if (predicate x) (then-fo x) (else-fo x)))))))) + (provide/contract [non-empty-string/c contract?] [path-element? contract?] - [port-number? contract?]) + [port-number? contract?] + [if/c (-> procedure? contract? contract? contract?)]) diff --git a/collects/unstable/mutated-vars.ss b/collects/unstable/mutated-vars.ss index efa9b39e49..a585a2c321 100644 --- a/collects/unstable/mutated-vars.ss +++ b/collects/unstable/mutated-vars.ss @@ -13,8 +13,7 @@ ;; syntax -> void (define (fmv/list lstx) (for-each find-mutated-vars (syntax->list lstx))) - ;(when (and (pair? (syntax->datum form))) (printf "called with ~a~n" (syntax->datum form))) - (kernel-syntax-case* form #f (define-type-alias-internal define-typed-struct-internal require/typed-internal) + (kernel-syntax-case* form #f () ;; what we care about: set! [(set! v e) (begin @@ -51,5 +50,8 @@ ;; less general. ;; - What's with the typed-scheme literals? If they were needed, then ;; typed-scheme is probably broken now. +;; ryanc: +;; - The for-template is needed. +;; - I've removed the bogus literals. (provide find-mutated-vars is-var-mutated?) diff --git a/collects/unstable/scribblings/contract.scrbl b/collects/unstable/scribblings/contract.scrbl index b7851a4629..a774deb59b 100644 --- a/collects/unstable/scribblings/contract.scrbl +++ b/collects/unstable/scribblings/contract.scrbl @@ -1,6 +1,7 @@ #lang scribble/doc @(require scribble/base scribble/manual + "utils.ss" (for-label unstable/contract scheme/contract scheme/base)) @@ -9,8 +10,39 @@ @defmodule[unstable/contract] -@defthing[non-empty-string/c contract?]{Contract for non-empty strings.} +@defthing[non-empty-string/c contract?]{ +Contract for non-empty strings. +} -@defthing[port-number? contract?]{Equivalent to @scheme[(between/c 1 65535)].} +@defthing[port-number? contract?]{ +Equivalent to @scheme[(between/c 1 65535)]. +} -@defthing[path-element? contract?]{Equivalent to @scheme[(or/c path-string? (symbols 'up 'same))].} +@defthing[path-element? contract?]{ +Equivalent to @scheme[(or/c path-string? (symbols 'up 'same))]. +} + +@addition{Ryan Culpepper} + +@defproc[(if/c [predicate (-> any/c any/c)] + [then-contract contract?] + [else-contract contract?]) + contract?]{ + +Produces a contract that, when applied to a value, first tests the +value with @scheme[predicate]; if @scheme[predicate] returns true, the +@scheme[then-contract] is applied; otherwise, the +@scheme[else-contract] is applied. The resulting contract is a flat +contract if both @scheme[then-contract] and @scheme[else-contract] are +flat contracts. + +For example, the following contract enforces that if a value is a +procedure, it is a thunk; otherwise it can be any (non-procedure) +value: + @schemeblock[(if/c procedure? (-> any) any/c)] +Note that the following contract is @bold{not} equivalent: + @schemeblock[(or/c (-> any) any/c) (code:comment "wrong!")] +The last contract is the same as @scheme[any/c] because +@scheme[or/c] tries flat contracts before higher-order contracts. + +} diff --git a/collects/unstable/struct.ss b/collects/unstable/struct.ss index 1384d643fb..9a272bddad 100644 --- a/collects/unstable/struct.ss +++ b/collects/unstable/struct.ss @@ -3,24 +3,27 @@ (require (for-syntax scheme/base scheme/struct-info)) (provide make - struct->list) + struct->list + (for-syntax get-struct-info)) + +;; get-struct-info : identifier stx -> struct-info-list +(define-for-syntax (get-struct-info id ctx) + (define (bad-struct-name x) + (raise-syntax-error #f "expected struct name" ctx x)) + (unless (identifier? id) + (bad-struct-name id)) + (let ([value (syntax-local-value id (lambda () #f))]) + (unless (struct-info? value) + (bad-struct-name id)) + (extract-struct-info value))) ;; (make struct-name field-expr ...) ;; Checks that correct number of fields given. (define-syntax (make stx) - (define (bad-struct-name x) - (raise-syntax-error #f "expected struct name" stx x)) - (define (get-struct-info id) - (unless (identifier? id) - (bad-struct-name id)) - (let ([value (syntax-local-value id (lambda () #f))]) - (unless (struct-info? value) - (bad-struct-name id)) - (extract-struct-info value))) (syntax-case stx () [(make S expr ...) (let () - (define info (get-struct-info #'S)) + (define info (get-struct-info #'S stx)) (define constructor (list-ref info 1)) (define accessors (list-ref info 3)) (unless (identifier? #'constructor)