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

added set/c and made sets print as set, seteq, or seteqv

Browse Source 
closes PR 11454
This commit is contained in:
Robby Findler 2011-01-08 08:39:37 -06:00
parent 422bb10b53
commit 0411cddba5
3 changed files with 158 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
collects/racket/set.rkt
View File

@ -1,7 +1,8 @@
#lang racket/base
(require (for-syntax racket/base)
racket/serialize
racket/pretty)
racket/pretty
racket/contract)
(provide set seteq seteqv
set? set-eq? set-eqv? set-equal?
@ -12,7 +13,8 @@
set-map set-for-each
(rename-out [*in-set in-set])
for/set for/seteq for/seteqv
for*/set for*/seteq for*/seteqv)
for*/set for*/seteq for*/seteqv
set/c)
(define-serializable-struct set (ht)
#:omit-define-syntaxes
@ -24,9 +26,19 @@
[(integer? mode) (lambda (p port) (print p port mode))]
[else write]))
(define (print-prefix port)
(if (equal? 0 mode)
(write-string "(set" port)
(write-string "#<set:" port)))
(cond
[(equal? 0 mode)
(write-string "(set" port)
(print-prefix-id port)]
[else
(write-string "#<set" port)
(print-prefix-id port)
(write-string ":" port)]))
(define (print-prefix-id port)
(cond
[(set-equal? s) (void)]
[(set-eqv? s) (write-string "eqv" port)]
[(set-eq? s) (write-string "eq" port)]))
(define (print-suffix port)
(if (equal? 0 mode)
(write-string ")" port)
@ -281,3 +293,66 @@
(define-for for*/fold/derived for*/seteq seteq)
(define-for for/fold/derived for/seteqv seteqv)
(define-for for*/fold/derived for*/seteqv seteqv)
(define (get-pred a-set/c)
(case (set/c-cmp a-set/c)
[(dont-care) set?]
[(eq) set-eq?]
[(eqv) set-eqv?]
[(equal) set-equal?]))
(define (get-name a-set/c)
(case (set/c-cmp a-set/c)
[(dont-care) 'set]
[(eq) 'set-eq]
[(eqv) 'set-eqv]
[(equal) 'set-equal]))
(define (set/c ctc #:cmp [cmp 'dont-care])
(unless (memq cmp '(dont-care equal eq eqv))
(raise-type-error 'set/c
"(or/c 'dont-care 'equal? 'eq? 'eqv)"
cmp))
(make-set/c ctc cmp))
(define-struct set/c (ctc cmp)
#:omit-define-syntaxes
#:property prop:contract
(build-contract-property
#:name
(λ (c) `(set/c ,(contract-name (set/c-ctc c))
,@(if (eq? (set/c-cmp c) 'dont-care)
'()
`(#:cmp ',(set/c-cmp c)))))
#:first-order
get-pred
#:stronger
(λ (this that)
(and (set/c? that)
(or (eq? (set/c-cmp this)
(set/c-cmp that))
(eq? (set/c-cmp that) 'dont-care))
(contract-stronger? (set/c-ctc this)
(set/c-ctc that))))
#:projection
(λ (c)
(let ([proj (contract-projection (set/c-ctc c))]
[pred (get-pred c)])
(λ (blame)
(let ([pb (proj blame)])
(λ (s)
(if (pred s)
(cond
[(set-equal? s)
(for/set ((e (in-set s)))
(pb e))]
[(set-eqv? s)
(for/seteqv ((e (in-set s)))
(pb e))]
[(set-eq? s)
(for/seteq ((e (in-set s)))
(pb e))])
(raise-blame-error
blame
s
"expected a <~a>, got ~v" (get-name c))))))))))

60
collects/tests/racket/contract-test.rktl
View File

@ -11,6 +11,7 @@
(namespace-require '(for-syntax scheme/base))
(namespace-require '(for-template scheme/base))
(namespace-require 'scheme/contract)
(namespace-require 'scheme/set)
(namespace-require '(only racket/contract/private/arrow procedure-accepts-and-more?))
(namespace-require 'scheme/class)
(namespace-require 'scheme/promise)
@ -9665,6 +9666,11 @@ so that propagation occurs.
(test-name '(couple/dc [hd any/c] [tl ...])
(couple/dc [hd any/c] [tl (hd) any/c]))
(test-name '(set/c integer?) (set/c integer?))
(test-name '(set/c boolean? #:cmp 'equal) (set/c boolean? #:cmp 'equal))
(test-name '(set/c char? #:cmp 'eq) (set/c char? #:cmp 'eq))
(test-name '(set/c (set/c char?) #:cmp 'eqv) (set/c (set/c char? #:cmp 'dont-care) #:cmp 'eqv))
;; NOT YET RELEASED
#;
(test-name '(pr/dc [x integer?]
@ -10248,6 +10254,60 @@ so that propagation occurs.
11))
11)
; ;
; ;
; ; ;
; ;;;; ;;;; ;;;;;; ; ;;;;
; ; ; ; ; ; ;
; ;; ; ; ; ; ;
; ;; ;;;;;; ; ; ;
; ; ; ; ; ;
; ; ; ; ; ;
; ;;;; ;;;;; ;;; ; ;;;;
; ;
; ;
;
(test/spec-passed/result
'set/c1
'(contract (set/c integer?)
(set 0)
'pos 'neg)
(contract-eval '(set 0)))
(test/pos-blame
'set/c2
'(contract (set/c integer?)
(set #t)
'pos 'neg))
(test/pos-blame
'set/c3
'(contract (set/c integer? #:cmp 'eq)
(set 0)
'pos 'neg))
(test/pos-blame
'set/c4
'(contract (set/c integer? #:cmp 'eqv)
(set 0)
'pos 'neg))
(test/pos-blame
'set/c5
'(contract (set/c integer? #:cmp 'equal)
(seteq 0)
'pos 'neg))
(test/spec-passed/result
'set/c6
'(set-map (contract (set/c integer?)
(set 0)
'pos 'neg)
values)
(list 0))
;
;
;

18
collects/tests/racket/set.rktl
View File

@ -105,6 +105,24 @@
(void))
(test "#<set: 1>"
'print-set1
(let ([sp (open-output-string)])
(write (set 1) sp)
(get-output-string sp)))
(test "#<seteq: 1>"
'print-set1
(let ([sp (open-output-string)])
(write (seteq 1) sp)
(get-output-string sp)))
(test "#<seteqv: 1>"
'print-set1
(let ([sp (open-output-string)])
(write (seteqv 1) sp)
(get-output-string sp)))
;; ----------------------------------------
(test (set 1 2 3) 'for/set (for/set ([i '(0 1 2)]) (add1 i)))