suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add *list/c

Browse Source
This commit is contained in:
Robby Findler 2016-01-27 20:11:10 -06:00
parent 5214b06a86
commit 856e60fe51
8 changed files with 277 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
pkgs/racket-doc/scribblings/reference/contracts.scrbl
View File

@ -552,6 +552,29 @@ each element of the list must match the corresponding contract. Beware
that when this contract is applied to a value, the result is not
necessarily @racket[eq?] to the input.}
@defproc[(*list/c [prefix contract?] [suffix contract?] ...) list-contract?]{
Produces a contract for a list. The number of elements in the list
must be at least as long as the number of @racket[suffix] contracts
and the tail of the list must match those contracts, one for each
element. The beginning portion of the list can be arbitrarily long,
and each element must match @racket[prefix].
Beware that when this contract is applied to a value, the result is not
necessarily @racket[eq?] to the input.
@examples[#:eval (contract-eval) #:once
(define/contract a-list-of-numbers-ending-with-two-integers
(*list/c number? integer? integer?)
(list 1/2 4/5 +1i -11 322))
(eval:error
(define/contract not-enough-integers-at-the-end
(*list/c number? integer? integer? integer?)
(list 1/2 4/5 1/2 321 322)))]
}
@defproc[(syntax/c [c flat-contract?]) flat-contract?]{

8
pkgs/racket-test/tests/racket/contract/first-order.rkt
View File

@ -58,7 +58,13 @@
(ctest #t contract-first-order-passes? (non-empty-listof integer?) (list 1))
(ctest #f contract-first-order-passes? (non-empty-listof integer?) (list))
(ctest #t contract-first-order-passes? (*list/c integer? boolean? char?) '(1 2 3 4 #f #\a))
(ctest #t contract-first-order-passes? (*list/c integer? boolean? char?) '(#f #\a))
(ctest #f contract-first-order-passes? (*list/c integer? boolean? char?) '(1 2 #f 4 #f #\a))
(ctest #f contract-first-order-passes? (*list/c integer? boolean? char?) '())
(ctest #f contract-first-order-passes? (*list/c integer? boolean? char?) '(#f))
(ctest #f contract-first-order-passes? (*list/c integer? boolean? char?) 1)
(ctest #t contract-first-order-passes?
(vector-immutableof integer?)
(vector->immutable-vector (vector 1)))

12
pkgs/racket-test/tests/racket/contract/list-contract.rkt
View File

@ -158,6 +158,18 @@
(letrec ([c (recursive-contract (first-or/c (cons/c 1 c) empty?) #:list-contract?)])
c))
#t)
(test/spec-passed/result
'list-contract-25
'(list-contract?
(*list/c integer? boolean? char?))
#t)
(test/spec-passed/result
'list-contract-26
'(list-contract?
(*list/c (-> integer? integer?) boolean? char?))
#t)
(test/pos-blame
'test-contract-25

35
pkgs/racket-test/tests/racket/contract/list.rkt
View File

@ -170,5 +170,40 @@
'cons/dc13
'(contract? (cons/dc [hd integer?] [tl (hd) integer?] #:impersonator))
#t)
(test/spec-passed/result
'*list/c1
'(contract (*list/c integer? char? boolean?) '(1 2 3 #\a #f) 'pos 'neg)
'(1 2 3 #\a #f))
(test/pos-blame
'*list/c2
'(contract (*list/c integer? char? boolean?) '(1 2 #\a #\a #f) 'pos 'neg))
(test/spec-passed/result
'*list/c3
'((car (contract (*list/c (-> integer? integer?) (-> boolean? boolean?))
(list (λ (x) x) (λ (y) y)) 'pos 'neg))
1)
1)
(test/neg-blame
'*list/c4
'((car (contract (*list/c (-> integer? integer?) (-> boolean? boolean?))
(list (λ (x) x) (λ (y) y)) 'pos 'neg))
#f))
(test/spec-passed/result
'*list/c5
'((cadr (contract (*list/c (-> integer? integer?) (-> boolean? boolean?))
(list (λ (x) x) (λ (y) y)) 'pos 'neg))
#f)
#f)
(test/neg-blame
'*list/c6
'((cadr (contract (*list/c (-> integer? integer?) (-> boolean? boolean?))
(list (λ (x) x) (λ (y) y)) 'pos 'neg))
1))
(test/pos-blame
'*list/c7
'((caddr (contract (*list/c (-> integer? integer?) (-> boolean? boolean?) (-> char? char?))
(list (λ (x) x) (λ (y) y) (λ (y) 'not-a-bool) (λ (y) y)) 'pos 'neg))
#f))
)

2
pkgs/racket-test/tests/racket/contract/random-generate.rkt
View File

@ -79,6 +79,8 @@
(check-not-exn (λ () (test-contract-generation (list*of boolean? char?))))
(check-not-exn (λ () (test-contract-generation (list/c boolean? number?))))
(check-not-exn (λ () ((car (test-contract-generation (list/c (-> number? number?)))) 0)))
(check-not-exn (λ () (test-contract-generation (*list/c boolean? number? char?))))
(check-not-exn (λ () (test-contract-generation (-> (*list/c boolean? number? char?) any))))
(check-not-exn
(λ ()

4
pkgs/racket-test/tests/racket/contract/stronger.rkt
View File

@ -305,6 +305,10 @@
(ctest #t contract-stronger? (list/c (<=/c 3)) (non-empty-listof (<=/c 5)))
(ctest #f contract-stronger? (list/c) (non-empty-listof (<=/c 5)))
(ctest #t contract-stronger? (list/c) (listof (<=/c 5)))
(ctest #t contract-stronger? (*list/c integer? boolean? char?) (*list/c integer? boolean? char?))
(ctest #t contract-stronger? (list/c integer? boolean? char?) (listof (or/c integer? boolean? char?)))
(ctest #t contract-stronger? (promise/c (<=/c 2)) (promise/c (<=/c 3)))
(ctest #f contract-stronger? (promise/c (<=/c 3)) (promise/c (<=/c 2)))

1
racket/collects/racket/contract/base.rkt
View File

@ -76,6 +76,7 @@
false/c
printable/c
listof list*of non-empty-listof cons/c list/c cons/dc
*list/c
promise/c
syntax/c

194
racket/collects/racket/contract/private/list.rkt
View File

@ -14,7 +14,8 @@
(provide listof list*of non-empty-listof cons/c list/c cons/dc
blame-add-car-context
blame-add-cdr-context
raise-not-cons-blame-error)
raise-not-cons-blame-error
*list/c)
(define (listof-generate ctc)
(cond
@ -779,7 +780,198 @@
#:late-neg-projection list/c-chaperone/other-late-neg-projection
#:list-contract? (λ (c) #t)))
(define (*list/c-name-proc ctc)
`(*list/c ,(contract-name (*list-ctc-prefix ctc))
,@(map contract-name (*list-ctc-suffix ctc))))
(define (*list/c-first-order ctc)
(define prefix? (contract-first-order (*list-ctc-prefix ctc)))
(define suffix?s (map contract-first-order (*list-ctc-suffix ctc)))
(define suffix?s-len (length suffix?s))
(λ (val)
(cond
[(list? val)
(define-values (long-enough? end) (get-end val suffix?s-len))
(cond
[long-enough?
(let loop ([val val]
[end end])
(cond
[(null? end)
(for/and ([ele (in-list val)]
[suffix? (in-list suffix?s)])
(suffix? ele))]
[else
(and (prefix? (car val))
(loop (cdr val) (cdr end)))]))]
[else #f])]
[else #f])))
(define (get-end val suffix?s-len)
(let loop ([val val]
[i suffix?s-len])
(cond
[(zero? i) (values #t val)]
[(null? val) (values #f #f)]
[else (loop (cdr val) (- i 1))])))
(define (*list/c-generate ctc)
(λ (fuel)
(define prefix-gen (contract-random-generate/choose (*list-ctc-prefix ctc) fuel))
(define suffix-gens
(for/list ([suf (*list-ctc-suffix ctc)])
(contract-random-generate/choose suf fuel)))
(and prefix-gen
(for/and ([i (in-list suffix-gens)]) i)
(λ ()
(let loop ()
(rand-choice
[1/5 (for/list ([suffix-gen (in-list suffix-gens)])
(suffix-gen))]
[else (cons (prefix-gen) (loop))]))))))
(define (*list/c-exercise ctc)
(define suffix (reverse (*list-ctc-suffix ctc)))
(λ (fuel)
(define env (contract-random-generate-get-current-environment))
(values
(λ (lst)
(let loop ([lst (reverse lst)]
[suffix suffix])
(cond
[(null? suffix) (void)]
[else
(contract-random-generate-stash env (car lst) (car suffix))
(loop (cdr lst) (cdr suffix))])))
suffix)))
(define (*list/c-stronger this that)
(define this-prefix (*list-ctc-prefix this))
(define this-suffix (*list-ctc-suffix this))
(cond
[(*list-ctc? that)
(define that-prefix (*list-ctc-prefix that))
(define that-suffix (*list-ctc-suffix that))
(define (pad-to a-suf b-suf a-prefix)
(define a-len (length a-suf))
(define b-len (length b-suf))
(cond
[(< a-len b-len)
(append (build-list (- b-len a-len) (λ (x) a-prefix))
a-suf)]
[else a-suf]))
(define padded-this (pad-to this-suffix that-suffix this-prefix))
(define padded-that (pad-to that-suffix this-suffix that-prefix))
(and (contract-struct-stronger? this-prefix that-prefix)
(for/and ([this (in-list padded-this)]
[that (in-list padded-that)])
(contract-struct-stronger? this that)))]
[(listof-ctc? that)
(define that-elem (listof-ctc-elem-c that))
(and (contract-struct-stronger? this-prefix that-elem)
(for/and ([suf (in-list this-suffix)])
(contract-struct-stronger? suf that-elem)))]
[else #f]))
(define (*list/c-late-neg-projection ctc flat?)
(define prefix-lnp (contract-late-neg-projection (*list-ctc-prefix ctc)))
(define suffix-lnps (map contract-late-neg-projection (*list-ctc-suffix ctc)))
(define suffix?s-len (length suffix-lnps))
(λ (blame)
(define prefix-val-acceptor (prefix-lnp (blame-add-context blame "the prefix of")))
(define suffix-val-acceptors
(for/list ([i (in-naturals)]
[suffix-lnp (in-list suffix-lnps)])
(define which (- suffix?s-len i))
(define msg
(if (= 1 which)
"the last element of"
(format "the ~a to the last element of" (n->th which))))
(suffix-lnp (blame-add-context blame msg))))
(λ (val neg-party)
(cond
[(list? val)
(define-values (long-enough? end) (get-end val suffix?s-len))
(cond
[long-enough?
(let loop ([remainder-to-process val]
[end end])
(cond
[(null? end)
(cond
[flat?
(for ([ele (in-list remainder-to-process)]
[suffix-val-acceptor (in-list suffix-val-acceptors)])
(suffix-val-acceptor ele neg-party))
val]
[else
(for/list ([ele (in-list remainder-to-process)]
[suffix-val-acceptor (in-list suffix-val-acceptors)])
(suffix-val-acceptor ele neg-party))])]
[else
(define fst (prefix-val-acceptor (car remainder-to-process) neg-party))
(if flat?
(loop (cdr remainder-to-process) (cdr end))
(cons fst (loop (cdr remainder-to-process) (cdr end))))]))]
[else
(raise-blame-error
blame
val
'(expected: "list? with at least ~a elements" given: "~e")
suffix?s-len
val)])]
[else (raise-blame-error
blame
val
'(expected: "list?" given: "~e") val)]))))
;; prefix : contract
;; suffix : (listof contract)
(struct *list-ctc (prefix suffix)
#:property prop:custom-write custom-write-property-proc)
(struct flat-*list/c *list-ctc ()
#:property prop:contract
(build-contract-property
#:name *list/c-name-proc
#:first-order *list/c-first-order
#:generate *list/c-generate
#:exercise *list/c-exercise
#:stronger *list/c-stronger
#:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #t))
#:list-contract? (λ (c) #t)))
(struct chaperone-*list/c *list-ctc ()
#:property prop:contract
(build-contract-property
#:name *list/c-name-proc
#:first-order *list/c-first-order
#:generate *list/c-generate
#:exercise *list/c-exercise
#:stronger *list/c-stronger
#:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f))
#:list-contract? (λ (c) #t)))
(struct impersonator-*list/c *list-ctc ()
#:property prop:contract
(build-contract-property
#:name *list/c-name-proc
#:first-order *list/c-first-order
#:generate *list/c-generate
#:exercise *list/c-exercise
#:stronger *list/c-stronger
#:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f))
#:list-contract? (λ (c) #t)))
(define (*list/c ele . rest)
(define ctcs (coerce-contracts '*list/c (cons ele rest)))
(cond
[(null? rest) (listof ele)]
[(andmap flat-contract? ctcs)
(flat-*list/c (car ctcs) (cdr ctcs))]
[(andmap chaperone-contract? ctcs)
(chaperone-*list/c (car ctcs) (cdr ctcs))]
[else
(impersonator-*list/c (car ctcs) (cdr ctcs))]))
;; this is a hack to work around cyclic linking issues;
;; see definition of set-some-basic-contracts!
(set-some-basic-contracts!