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

Move `hashof' contract combinator to utils/utils.ss

Browse Source 
Fix frees for arr to use `fix-bounds' properly.
Match : symbolically in ->*

svn: r14786
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-12 19:53:48 +00:00
parent ce9f98098d
commit 5300481176
4 changed files with 53 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/typed-scheme/infer/constraint-structs.ss
View File

@ -31,18 +31,6 @@
;; don't want to rule them out too early
(define-struct cset (maps) #:prefab)
(define (hashof k/c v/c)
(flat-named-contract
(format "#<hashof ~a ~a>" k/c v/c)
(lambda (h)
(define k/c? (if (flat-contract? k/c) (flat-contract-predicate k/c) k/c))
(define v/c? (if (flat-contract? v/c) (flat-contract-predicate v/c) v/c))
(and (hash? h)
(for/and ([(k v) h])
(and (k/c? k)
(v/c? v)))))))
(provide/contract (struct c ([S Type?] [X symbol?] [T Type?]))
(struct dcon ([fixed (listof c?)] [rest (or/c c? false/c)]))
(struct dcon-exact ([fixed (listof c?)] [rest c?]))

36
collects/typed-scheme/rep/type-rep.ss
View File

@ -146,18 +146,30 @@
[rest (or/c #f Type/c)]
[drest (or/c #f (cons/c Type/c (or/c natural-number/c symbol?)))]
[kws (listof Keyword?)])
[#:frees (lambda (free*)
(combine-frees
(append (map (compose flip-variances free*)
(append (if rest (list rest) null)
(map Keyword-ty kws)
dom))
(match drest
[(cons t (? symbol? bnd))
(list (fix-bound (flip-variances (free* t)) bnd))]
[(cons t (? number? bnd)) (list (flip-variances (free* t)))]
[#f null])
(list (free* rng)))))]
[#:frees (combine-frees
(append (map (compose flip-variances free-vars*)
(append (if rest (list rest) null)
(map Keyword-ty kws)
dom))
(match drest
[(cons t (? symbol? bnd))
(list (fix-bound (flip-variances (free-vars* t)) bnd))]
[(cons t (? number? bnd))
(list (flip-variances (free-vars* t)))]
[#f null])
(list (free-vars* rng))))
(combine-frees
(append (map (compose flip-variances free-idxs*)
(append (if rest (list rest) null)
(map Keyword-ty kws)
dom))
(match drest
[(cons t (? symbol? bnd))
(list (flip-variances (free-idxs* t)))]
[(cons t (? number? bnd))
(list (fix-bound (flip-variances (free-idxs* t)) bnd))]
[#f null])
(list (free-idxs* rng))))]
[#:fold-rhs (*arr (map type-rec-id dom)
(type-rec-id rng)
(and rest (type-rec-id rest))

26
collects/typed-scheme/types/abbrev.ss
View File

@ -172,20 +172,22 @@
(make-Values (list (-result rng filters obj))))
rest drest (sort #:key Keyword-kw kws keyword<?)))
(define-syntax ->*
(syntax-rules (:)
(define-syntax (->* stx)
(define-syntax-class c
(pattern x:id #:when (eq? ': (syntax-e #'x))))
(syntax-parse stx
[(_ dom rng)
(make-Function (list (make-arr* dom rng)))]
#'(make-Function (list (make-arr* dom rng)))]
[(_ dom rst rng)
(make-Function (list (make-arr* dom rng #:rest rst)))]
[(_ dom rng : filters)
(make-Function (list (make-arr* dom rng #:filters filters)))]
[(_ dom rng : filters : object)
(make-Function (list (make-arr* dom rng #:filters filters #:object object)))]
[(_ dom rst rng : filters)
(make-Function (list (make-arr* dom rng #:rest rst #:filters filters)))]
[(_ dom rst rng : filters : object)
(make-Function (list (make-arr* dom rng #:rest rst #:filters filters #:object object)))]))
#'(make-Function (list (make-arr* dom rng #:rest rst)))]
[(_ dom rng :c filters)
#'(make-Function (list (make-arr* dom rng #:filters filters)))]
[(_ dom rng _:c filters _:c object)
#'(make-Function (list (make-arr* dom rng #:filters filters #:object object)))]
[(_ dom rst rng _:c filters)
#'(make-Function (list (make-arr* dom rng #:rest rst #:filters filters)))]
[(_ dom rst rng _:c filters : object)
#'(make-Function (list (make-arr* dom rng #:rest rst #:filters filters #:object object)))]))
(define-syntax (-> stx)
(define-syntax-class c

15
collects/typed-scheme/utils/utils.ss
View File

@ -23,7 +23,8 @@ at least theoretically.
in-syntax
symbol-append
custom-printer
rep utils typecheck infer env private)
rep utils typecheck infer env private
hashof)
(define-syntax (define-requirer stx)
(syntax-parse stx
@ -319,3 +320,15 @@ at least theoretically.
(if enable-contracts?
(list #'[contracted (nm cnt)])
(list #'nm))]))
(define (hashof k/c v/c)
(flat-named-contract
(format "#<hashof ~a ~a>" k/c v/c)
(lambda (h)
(define k/c? (if (flat-contract? k/c) (flat-contract-predicate k/c) k/c))
(define v/c? (if (flat-contract? v/c) (flat-contract-predicate v/c) v/c))
(and (hash? h)
(for/and ([(k v) h])
(and (k/c? k)
(v/c? v)))))))