Fix name of Type/c

Fix fold on Result.
Add comments.
New -struct constructor with opt args.
Fix tests to agree with contracts.

svn: r13934

original commit: 9d0ee637c74b0d7705d7b9fc60ee0712cac6b0f9
This commit is contained in:
Sam Tobin-Hochstadt 2009-03-03 23:18:00 +00:00
parent 0674606052
commit eb77d9debc
6 changed files with 22 additions and 13 deletions

View File

@ -8,7 +8,7 @@
(for-syntax scheme/base))
(require (types comparison type-utils)
(require (types comparison utils)
(schemeunit))
(provide private typecheck (rename-out [infer r:infer]) utils env rep types)

View File

@ -2,12 +2,12 @@
(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base))
(require (rep type-rep)
(types comparison type-abbrev)
(types comparison abbrev union)
(schemeunit))
(provide type-equal-tests)
(define (-base x) (make-Base x #f))
(define (-base x) (make-Base x #'dummy))
(define-syntax (te-tests stx)
@ -37,14 +37,12 @@
[(-mu x (Un N Sym x)) (-mu y (Un N Sym y))]
;; found bug
[FAIL (Un (-mu heap-node
(-struct 'heap-node #f (list (-base 'comparator) N (-v a) (Un heap-node (-base 'heap-empty))) #f #f #f values))
(-struct 'heap-node #f (list (-base 'comparator) N (-v a) (Un heap-node (-base 'heap-empty)))))
(-base 'heap-empty))
(Un (-mu heap-node
(-struct 'heap-node #f (list (-base 'comparator) N (-pair N N) (Un heap-node (-base 'heap-empty))) #f #f #f values))
(-struct 'heap-node #f (list (-base 'comparator) N (-pair N N) (Un heap-node (-base 'heap-empty)))))
(-base 'heap-empty))]))
(define-go
type-equal-tests)

View File

@ -12,7 +12,7 @@
(define Type/c
(flat-named-contract
"Type"
'Type
(λ (e)
(and (Type? e)
(not (Scope? e))
@ -129,7 +129,7 @@
(dt Result ([t Type/c] [f LFilterSet?] [o LatentObject?])
[#:frees (λ (frees) (combine-frees (map frees (list t f o))))]
[#:fold-rhs (*Result (type-rec-id t) (latentfilter-rec-id f) (latentobject-rec-id f))])
[#:fold-rhs (*Result (type-rec-id t) (latentfilter-rec-id f) (latentobject-rec-id o))])
;; types : Listof[Type]
(dt Values ([rs (listof Result?)])

View File

@ -19,7 +19,6 @@
(define -values make-Values)
(define -pair make-Pair)
(define -struct make-Struct)
(define -val make-Value)
(define -Param make-Param)
(define -box make-Box)
@ -211,6 +210,9 @@
(define (make-arr-dots dom rng dty dbound)
(make-arr* dom rng #:drest (cons dty dbound)))
(define (-struct name parent flds [proc #f] [poly #f] [pred #'dummy] [cert values])
(make-Struct name parent flds proc poly pred cert))
(define make-pred-ty
(case-lambda

View File

@ -1,4 +1,10 @@
#lang scheme/base
#|
This file is for utilities that are only useful for Typed Scheme, but
don't depend on any other portion of the system
|#
(provide (all-defined-out))
(require "syntax-traversal.ss" (for-syntax scheme/base stxclass) scheme/match)

View File

@ -1,5 +1,10 @@
#lang scheme/base
#|
This file is for utilities that are of general interest,
at least theoretically.
|#
(require (for-syntax scheme/base stxclass)
scheme/contract mzlib/plt-match scheme/require-syntax scheme/provide-syntax
mzlib/struct scheme/unit
@ -15,9 +20,7 @@
in-list-forever
extend
debug
in-syntax
;; require macros
rep utils typecheck infer env private types)
in-syntax)
(define-syntax (define-requirer stx)
(syntax-parse stx