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

Enable require-typed-struct with substructures.

Browse Source 
Fixes PR 9053.
Move test to succeed.
Add some new bindings.

svn: r12709
This commit is contained in:
Sam Tobin-Hochstadt 2008-12-05 00:25:02 +00:00
parent 66a0c27703
commit e6eb482de4
8 changed files with 147 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

0
collects/tests/typed-scheme/fail/pr9053-fail.ss → collects/tests/typed-scheme/succeed/pr9053-2.ss
View File

60
collects/typed-scheme/private/base-env.ss
View File

@ -289,6 +289,57 @@
[(-Pattern -InpBts N ?N ) (optlist -Bytes)]
[(-Pattern -InpBts N ?N ?outp) (optlist -Bytes)]))]
[regexp-match*
(let ([?N (-opt N)]
[-StrRx (*Un -String -Regexp -PRegexp)]
[-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)]
[-InpBts (*Un -Input-Port -Bytes)])
(cl->*
(-StrRx -String [N ?N] . ->opt . (-lst -String))
(-BtsRx -String [N ?N] . ->opt . (-lst -Bytes))
(-Pattern -InpBts [N ?N] . ->opt . (-lst -Bytes))))]
[regexp-try-match
(let ([?outp (-opt -Output-Port)]
[?N (-opt N)]
[optlist (lambda (t) (-opt (-lst (-opt t))))])
(->opt -Pattern -Input-Port [N ?N ?outp] (optlist -Bytes)))]
[regexp-match-exact?
(-Pattern (Un -String -Bytes -Input-Port) . -> . B)]
[regexp-match-positions
(let ([?outp (-opt -Output-Port)]
[?N (-opt N)]
[optlist (lambda (t) (-opt (-lst (-opt t))))]
[-StrRx (*Un -String -Regexp -PRegexp)]
[-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)]
[-InpBts (*Un -Input-Port -Bytes)])
(->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (optlist (-pair -Nat -Nat))))]
[regexp-match-positions*
(let ([?outp (-opt -Output-Port)]
[?N (-opt N)]
[optlist (lambda (t) (-opt (-lst (-opt t))))]
[-StrRx (*Un -String -Regexp -PRegexp)]
[-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)]
[-InpBts (*Un -Input-Port -Bytes)])
(->opt -Pattern (Un -String -InpBts) [N ?N ?outp] (-lst (-pair -Nat -Nat))))]
#;
[regexp-match-peek-positions*]
#;
[regexp-split]
[regexp-quote (cl->*
(->opt -String [Univ] -String)
(->opt -Bytes [Univ] -Bytes))]
[regexp-replace-quote
(cl->*
[-> -String -String]
[-> -Bytes -Bytes])]
[number->string (N . -> . -String)]
[current-milliseconds (-> -Integer)]
@ -499,4 +550,11 @@
;; scheme/bool
[boolean=? (B B . -> . B)]
[symbol=? (Sym Sym . -> . B)]
[false? (make-pred-ty (-val #f))]
[false? (make-pred-ty (-val #f))]
;; with-stx.ss
[generate-temporaries ((Un (-Syntax Univ) (-lst Univ)) . -> . (-lst (-Syntax Sym)))]
[check-duplicate-identifier ((-lst (-Syntax Sym)) . -> . (-opt (-Syntax Sym)))]
;; string.ss
[real->decimal-string (N [-Nat] . ->opt . -String)]

5
collects/typed-scheme/private/parse-type.ss
View File

@ -26,7 +26,10 @@
(define (parse-type stx)
(parameterize ([current-orig-stx stx])
(syntax-case* stx ()
symbolic-identifier=?
symbolic-identifier=?
[t
(Type? (syntax-e #'t))
(syntax-e #'t)]
[(fst . rst)
(not (syntax->list #'rst))
(-pair (parse-type #'fst) (parse-type #'rst))]

44
collects/typed-scheme/private/prims.ss
View File

@ -57,6 +57,15 @@ This file defines two sorts of primitives. All of them are provided into any mod
(syntax-case* stx (rename) (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
[(_ lib [nm ty] ...)
#'(begin (require/typed nm ty lib) ...)]
[(_ nm ty lib #:struct-maker parent)
(with-syntax ([(cnt*) (generate-temporaries #'(nm))])
(quasisyntax/loc stx (begin
#,(syntax-property (syntax-property #'(define cnt* #f)
'typechecker:contract-def/maker #'ty)
'typechecker:ignore #t)
#,(internal #'(require/typed-internal nm ty #:struct-maker parent))
#,(syntax-property #'(require/contract nm cnt* lib)
'typechecker:ignore #t))))]
[(_ nm ty lib)
(identifier? #'nm)
(with-syntax ([(cnt*) (generate-temporaries #'(nm))])
@ -346,9 +355,8 @@ This file defines two sorts of primitives. All of them are provided into any mod
[(_ nm ([fld : ty] ...) lib)
(identifier? #'nm)
(with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
[(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]
[oty #'(Opaque pred)])
#'(begin
[(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))])
#`(begin
(require (only-in lib struct-info))
(define-syntax nm (make-struct-info
(lambda ()
@ -358,9 +366,33 @@ This file defines two sorts of primitives. All of them are provided into any mod
(list #'sel ...)
(list mut ...)
#f))))
(require/opaque-type nm pred lib #:name-exists)
(require/typed maker (ty ... -> oty) lib)
(require/typed sel (oty -> ty) lib) ...))]))
#,(internal #'(define-typed-struct-internal nm ([fld : ty] ...) #:type-only))
#,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
#,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
(require/typed maker nm lib #:struct-maker #f)
(require/typed lib
[sel (nm -> ty)]) ...))]
[(_ (nm parent) ([fld : ty] ...) lib)
(and (identifier? #'nm) (identifier? #'parent))
(with-syntax* ([(struct-info maker pred sel ...) (build-struct-names #'nm (syntax->list #'(fld ...)) #f #t)]
[(mut ...) (map (lambda _ #'#f) (syntax->list #'(sel ...)))]
#;[(parent-tys ...) (Struct-flds (parse-type #'parent))])
#`(begin
(require (only-in lib struct-info))
(define-syntax nm (make-struct-info
(lambda ()
(list #'struct-info
#'maker
#'pred
(list #'sel ...)
(list mut ...)
#f))))
#,(internal #'(define-typed-struct-internal (nm parent) ([fld : ty] ...) #:type-only))
#,(ignore #'(require/contract pred (any/c . c-> . boolean?) lib))
#,(internal #'(require/typed-internal pred (Any -> Boolean : nm)))
(require/typed maker nm lib #:struct-maker parent)
(require/typed lib
[sel (nm -> ty)]) ...))]))
(define-syntax (do: stx)
(syntax-case stx (:)

14
collects/typed-scheme/private/type-contract.ss
View File

@ -23,15 +23,21 @@
(for-template scheme/base scheme/contract (only-in scheme/class object% is-a?/c subclass?/c)))
(define (define/fixup-contract? stx)
(syntax-property stx 'typechecker:contract-def))
(or (syntax-property stx 'typechecker:contract-def)
(syntax-property stx 'typechecker:contract-def/maker)))
(define (generate-contract-def stx)
(define prop (syntax-property stx 'typechecker:contract-def))
(define prop (or (syntax-property stx 'typechecker:contract-def)
(syntax-property stx 'typechecker:contract-def/maker)))
(define maker? (syntax-property stx 'typechecker:contract-def/maker))
(define typ (parse-type prop))
(syntax-case stx (define-values)
[(_ (n) __)
(with-syntax ([cnt (type->contract typ (lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))])
(syntax/loc stx (define-values (n) cnt)))]
(let ([typ (if maker?
((Struct-flds (lookup-type-name (Name-id typ))) #f . t:->* . typ)
typ)])
(with-syntax ([cnt (type->contract typ (lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))])
(syntax/loc stx (define-values (n) cnt))))]
[_ (int-err "should never happen - not a define-values: ~a" (syntax->datum stx))]))
(define (change-contract-fixups forms)

11
collects/typed-scheme/private/type-effect-convenience.ss
View File

@ -3,6 +3,7 @@
(require (rep type-rep effect-rep)
(utils tc-utils)
scheme/list
scheme/match
"type-comparison.ss"
"type-effect-printer.ss"
@ -84,7 +85,7 @@
(define (funty-arities f)
(match f
[(Function: as) as]))
(make-Function (map car (map funty-arities args))))
(make-Function (apply append (map funty-arities args))))
(define-syntax (->key stx)
(syntax-parse stx
@ -143,6 +144,8 @@
(define Univ (make-Univ))
(define Err (make-Error))
(define -Nat -Integer)
(define-syntax -v
(syntax-rules ()
[(_ x) (make-F 'x)]))
@ -277,3 +280,9 @@
(define (opt-fn args opt-args result)
(apply cl->* (for/list ([i (in-range (add1 (length opt-args)))])
(make-Function (list (make-arr* (append args (take opt-args i)) result))))))
(define-syntax-rule (->opt args ... [opt ...] res)
(opt-fn (list args ...) (list opt ...) res))

24
collects/typed-scheme/typecheck/tc-structs.ss
View File

@ -91,7 +91,8 @@
#:proc-ty [proc-ty #f]
#:maker [maker* #f]
#:constructor-return [cret #f]
#:poly? [poly? #f])
#:poly? [poly? #f]
#:type-only [type-only #f])
;; create the approriate names that define-struct will bind
(define-values (maker pred getters setters) (struct-names nm flds setters?))
(let* ([name (syntax-e nm)]
@ -99,17 +100,19 @@
[sty (make-Struct name parent fld-types proc-ty poly? pred (syntax-local-certifier))]
[external-fld-types/no-parent types]
[external-fld-types fld-types])
(register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
#:wrapper wrapper
#:type-wrapper type-wrapper
#:maker (or maker* maker)
#:constructor-return cret)))
(if type-only
(register-type-name nm (wrapper sty))
(register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
#:wrapper wrapper
#:type-wrapper type-wrapper
#:maker (or maker* maker)
#:constructor-return cret))))
;; generate names, and register the approriate types give field types and structure type
;; optionally wrap things
;; identifier Type Listof[identifer] Listof[Type] Listof[Type] #:wrapper (Type -> Type) #:maker identifier
(define (register-struct-types nm sty flds external-fld-types external-fld-types/no-parent setters?
#:wrapper [wrapper (lambda (x) x)]
#:wrapper [wrapper values]
#:type-wrapper [type-wrapper values]
#:maker [maker* #f]
#:constructor-return [cret #f])
@ -168,7 +171,9 @@
;; typecheck a non-polymophic struct and register the approriate types
;; tc/struct : (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void
(define (tc/struct nm/par flds tys [proc-ty #f] #:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f])
(define (tc/struct nm/par flds tys [proc-ty #f]
#:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f]
#:type-only [type-only #f])
;; get the parent info and create some types and type variables
(define-values (nm parent-name parent name name-tvar) (parse-parent nm/par))
;; parse the field types, and determine if the type is recursive
@ -184,7 +189,8 @@
#:proc-ty proc-ty-parsed
#:maker maker
#:constructor-return (and cret (parse-type cret))
#:mutable mutable))
#:mutable mutable
#:type-only type-only))
;; register a struct type
;; convenience function for built-in structs

11
collects/typed-scheme/typecheck/tc-toplevel.ss
View File

@ -7,6 +7,7 @@
scheme/match
"signatures.ss"
"tc-structs.ss"
(rep type-rep)
(private type-utils type-effect-convenience parse-type type-annotation mutated-vars type-contract)
(env type-env init-envs type-name-env type-alias-env)
(utils tc-utils)
@ -44,6 +45,13 @@
(register-type #'nm t)
(list (make-def-binding #'nm t)))]
[(define-values () (begin (quote-syntax (require/typed-internal nm ty #:struct-maker parent)) (#%plain-app values)))
(let* ([t (parse-type #'ty)]
[flds (Struct-flds (lookup-type-name (Name-id t)))]
[mk-ty (flds #f . ->* . t)])
(register-type #'nm mk-ty)
(list (make-def-binding #'nm mk-ty)))]
;; define-typed-struct
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...))) (#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))]
@ -52,6 +60,9 @@
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:maker m #:constructor-return t))
(#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m #:constructor-return #'t)]
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:type-only))
(#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:type-only #t)]
;; define-typed-struct w/ polymorphism
[(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...))) (#%plain-app values)))
(tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))]