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

More cleanup of struct type registration.

Browse Source
This commit is contained in:
Eric Dobson 2012-09-01 21:27:54 -07:00 committed by Sam Tobin-Hochstadt
parent d84391b695
commit 8ea7502c12
3 changed files with 88 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
collects/typed-racket/private/type-contract.rkt
View File

@ -48,6 +48,7 @@
(define maker? (typechecker:contract-def/maker stx)) (define maker? (typechecker:contract-def/maker stx))
(define flat? (typechecker:flat-contract-def stx)) (define flat? (typechecker:flat-contract-def stx))
(define typ (parse-type prop)) (define typ (parse-type prop))
(define kind (if flat? 'flat 'impersonator))
(syntax-parse stx #:literals (define-values) (syntax-parse stx #:literals (define-values)
[(define-values (n) _) [(define-values (n) _)
(let ([typ (if maker? (let ([typ (if maker?
@ -57,9 +58,9 @@
typ typ
;; this is for a `require/typed', so the value is not from the typed side ;; this is for a `require/typed', so the value is not from the typed side
#:typed-side #f #:typed-side #f
#:kind (if flat? 'flat 'impersonator) #:kind kind
(lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))]) (lambda () (tc-error/stx prop "Type ~a could not be converted to a contract." typ)))])
(quasisyntax/loc stx (define-values (n) cnt))))] (quasisyntax/loc stx (define-values (n) (recursive-contract cnt #,(contract-kind->keyword kind))))))]
[_ (int-err "should never happen - not a define-values: ~a" (syntax->datum stx))])) [_ (int-err "should never happen - not a define-values: ~a" (syntax->datum stx))]))
(define (change-contract-fixups forms) (define (change-contract-fixups forms)

189
collects/typed-racket/typecheck/tc-structs.rkt
View File

@ -70,7 +70,7 @@
(values #'v.name #f #f))])) (values #'v.name #f #f))]))
(struct struct-names (type-name struct-type constructor predicate getters setters)) (struct struct-names (type-name struct-type constructor predicate getters setters) #:transparent)
;; generate struct names given type name, field names ;; generate struct names given type name, field names
;; and optional constructor name ;; and optional constructor name
;; all have syntax loc of name ;; all have syntax loc of name
@ -87,136 +87,103 @@
(let-values ([(getters setters) (split getters/setters)]) (let-values ([(getters setters) (split getters/setters)])
(struct-names nm sty (or maker* maker) pred getters setters))])) (struct-names nm sty (or maker* maker) pred getters setters))]))
;;struct-fields: holds all the relevant information about a struct type's types
(struct struct-desc (parent-fields self-fields tvars mutable proc-ty) #:transparent)
(define (struct-desc-all-fields fields)
(append (struct-desc-parent-fields fields) (struct-desc-self-fields fields)))
(define (struct-desc-parent-count fields)
(length (struct-desc-parent-fields fields)))
;; gets the fields of the parent type, if they exist ;; gets the fields of the parent type, if they exist
;; Option[Struct-Ty] -> Listof[Type] ;; Option[Struct-Ty] -> Listof[Type]
(define (get-parent-flds p) (define/cond-contract (get-flds p)
(c-> (or/c Struct? #f) (listof fld?))
(match p (match p
[(Struct: _ _ flds _ _ _) flds] [(Struct: _ _ flds _ _ _) flds]
[#f null])) [#f null]))
;; Constructs the Struct value for a structure type
;; The returned value has free type variables
(define (mk/inner-struct-type names desc parent)
(c-> struct-names? struct-desc? (or/c Struct? #f) void?)
(let* ([this-flds (for/list ([t (in-list (struct-desc-self-fields desc))]
[g (in-list (struct-names-getters names))])
(make-fld t g (struct-desc-mutable desc)))]
[flds (append (get-flds parent) this-flds)])
(make-Struct (struct-names-type-name names)
parent flds (struct-desc-proc-ty desc)
(not (null? (struct-desc-tvars desc)))
(struct-names-predicate names))))
;; construct all the various types for structs, and then register the approriate names ;; construct all the various types for structs, and then register the approriate names
;; identifier listof[identifier] type listof[fld] listof[Type] boolean -> ;; identifier listof[identifier] type listof[fld] listof[Type] boolean ->
;; (values Type listof[Type] listof[Type]) ;; (values Type listof[Type] listof[Type])
(define/cond-contract (mk/register-sty names parent types (define/cond-contract (register-sty! sty names desc)
#:mutable [mutable #f] (c-> Struct? struct-names? struct-desc? void?)
#:proc-ty [proc-ty #f]
#:poly? [poly? null])
(c->* (struct-names? (or/c Struct? #f) (listof Type/c))
(#:mutable boolean?
#:proc-ty (or/c #f Type/c)
#:poly? (listof symbol?))
any/c)
(define sty (register-type-name (struct-names-type-name names)
(mk/inner-struct-type names parent types (make-Poly (struct-desc-tvars desc) sty)))
#:mutable mutable
#:proc-ty proc-ty
#:poly? poly?))
(register-type-name (struct-names-type-name names) (make-Poly poly? sty)))
(define (mk/inner-struct-type names parent types
#:mutable mutable
#:proc-ty proc-ty
#:poly? poly?)
(let* ([this-flds (for/list ([t (in-list types)]
[g (in-list (struct-names-getters names))])
(make-fld t g mutable))]
[flds (append (get-parent-flds parent) this-flds)]
[sty (make-Struct (struct-names-type-name names)
parent flds proc-ty (not (null? poly?))
(struct-names-predicate names)
values
(struct-names-constructor names))])
sty))
(define/cond-contract (mk/register-struct-bindings
names parent types
#:mutable [mutable #f]
#:proc-ty [proc-ty #f]
#:poly? [poly? null])
(c->* (struct-names? (or/c Struct? #f) (listof Type/c))
(#:mutable boolean?
#:proc-ty (or/c #f Type/c)
#:poly? (listof symbol?))
any/c)
(define sty
(mk/inner-struct-type names parent types
#:mutable mutable
#:proc-ty proc-ty
#:poly? poly?))
(let* ([this-flds (for/list ([t (in-list types)]
[g (in-list (struct-names-getters names))])
(make-fld t g mutable))]
[flds (append (get-parent-flds parent) this-flds)]
[external-fld-types/no-parent types]
[external-fld-types (map fld-t flds)])
(register-struct-types sty names external-fld-types
external-fld-types/no-parent mutable
#:poly? poly?)))
;; Register the approriate types to the struct bindings.
(define/cond-contract (register-struct-bindings! sty names desc)
(c-> Struct? struct-names? struct-desc? void?)
;; generate names, and register the approriate types give field types and structure type
;; optionally wrap things
;; identifier Type Listof[identifier] Listof[Type] Listof[Type]
;; #:maker identifier -> Void
(define/cond-contract (register-struct-types sty names external-fld-types
external-fld-types/no-parent mutable
#:poly? poly?)
(c-> Struct? struct-names? (listof Type/c) (listof Type/c) boolean?
#:poly? (listof symbol?)
void?)
;; the type name that is used in all the types (define tvars (struct-desc-tvars desc))
(define name (define all-fields (struct-desc-all-fields desc))
(if (null? poly?) (define self-fields (struct-desc-self-fields desc))
(define mutable (struct-desc-mutable desc))
(define parent-count (struct-desc-parent-count desc))
;; the base-type, with free type variables
(define poly-base
(if (null? tvars)
(make-Name (struct-names-type-name names)) (make-Name (struct-names-type-name names))
(make-App (make-Name (struct-names-type-name names)) (map make-F poly?) #f))) (make-App (make-Name (struct-names-type-name names)) (map make-F tvars) #f)))
(define (poly-wrapper t) (make-Poly poly? t))
;; is this structure covariant in *all* arguments? ;; is this structure covariant in *all* arguments?
(define covariant? (define covariant?
(for*/and ([var (in-list poly?)] (for*/and ([var (in-list tvars)]
[t (in-list external-fld-types)]) [t (in-list all-fields)])
(let ([variance (hash-ref (free-vars* t) var Constant)]) (let ([variance (hash-ref (free-vars* t) var Constant)])
(or (eq? variance Constant) (or (eq? variance Constant)
(and (not mutable) (eq? variance Covariant)))))) (and (not mutable) (eq? variance Covariant))))))
(define parent-count (- (length external-fld-types) (length external-fld-types/no-parent)))
(define (poly-wrapper t) (make-Poly tvars t))
;; the list of names w/ types ;; the list of names w/ types
(register-type (struct-names-struct-type names) (make-StructType sty)) (register-type (struct-names-struct-type names) (make-StructType sty))
(register-type (struct-names-constructor names) (poly-wrapper (->* external-fld-types name))) (register-type (struct-names-constructor names) (poly-wrapper (->* all-fields poly-base)))
(register-type (struct-names-predicate names) (register-type (struct-names-predicate names)
(make-pred-ty (if (not covariant?) (make-pred-ty (if (not covariant?)
(make-StructTop sty) (make-StructTop sty)
(subst-all (make-simple-substitution (subst-all (make-simple-substitution
poly? (map (const Univ) poly?)) name)))) tvars (map (const Univ) tvars)) poly-base))))
(for ([g (in-list (struct-names-getters names))] (for ([g (in-list (struct-names-getters names))]
[t (in-list external-fld-types/no-parent)] [t (in-list self-fields)]
[i (in-naturals parent-count)]) [i (in-naturals parent-count)])
(let* ([path (make-StructPE name i)] (let* ([path (make-StructPE poly-base i)]
[func (if mutable [func (poly-wrapper
(->* (list name) t) (if mutable
(->acc (list name) t (list path)))]) (->* (list poly-base) t)
(->acc (list poly-base) t (list path))))])
(add-struct-fn! g path #f) (add-struct-fn! g path #f)
(register-type g (poly-wrapper func)))) (register-type g func)))
(when mutable (when mutable
(for ([g (in-list (struct-names-setters names))] (for ([s (in-list (struct-names-setters names))]
[t (in-list external-fld-types/no-parent)] [t (in-list self-fields)]
[i (in-naturals parent-count)]) [i (in-naturals parent-count)])
(add-struct-fn! g (make-StructPE name i) #t) (add-struct-fn! s (make-StructPE poly-base i) #t)
(register-type g (poly-wrapper (->* (list name t) -Void)))))) (register-type s (poly-wrapper (->* (list poly-base t) -Void))))))
;; check and register types for a define struct ;; check and register types for a define struct
;; tc/struct : Listof[identifier] (U identifier (list identifier identifier)) ;; tc/struct : Listof[identifier] (U identifier (list identifier identifier))
@ -250,18 +217,21 @@
parent)) parent))
;; create the actual structure type, and the types of the fields ;; create the actual structure type, and the types of the fields
;; that the outside world will see ;; that the outside world will see
;; then register them ;; then register it
(define names (get-struct-names nm fld-names maker)) (define names (get-struct-names nm fld-names maker))
(mk/register-sty names concrete-parent types (define desc (struct-desc
#:mutable mutable (map fld-t (get-flds concrete-parent))
;; wrap everything in the approriate forall types
#:poly? tvars) tvars
mutable
(and proc-ty (parse-type proc-ty))))
(define sty (mk/inner-struct-type names desc concrete-parent))
(register-sty! sty names desc)
;; Register the struct bindings.
(unless type-only (unless type-only
(mk/register-struct-bindings names concrete-parent types (register-struct-bindings! sty names desc)))
#:mutable mutable
;; wrap everything in the approriate forall
#:poly? tvars)))
;; register a struct type ;; register a struct type
@ -275,13 +245,16 @@
(listof Type/c) (or/c #f identifier?) (listof Type/c) (or/c #f identifier?)
any/c) any/c)
(define parent-type (and parent (resolve-name (make-Name parent)))) (define parent-type (and parent (resolve-name (make-Name parent))))
(define parent-tys (map fld-t (get-parent-flds parent-type))) (define parent-tys (map fld-t (get-flds parent-type)))
(define names (get-struct-names nm fld-names #f))
(mk/register-sty names parent-type tys #:mutable #t) (define names (get-struct-names nm fld-names #f))
(mk/register-struct-bindings names parent-type tys #:mutable #t) (define desc (struct-desc parent-tys tys null #t #f))
(define sty (mk/inner-struct-type names desc parent-type))
(register-sty! sty names desc)
(register-struct-bindings! sty names desc)
(when kernel-maker (when kernel-maker
(register-type kernel-maker (λ () (->* (append parent-tys tys) (lookup-type-name nm)))))) (register-type kernel-maker (λ () (->* (struct-desc-all-fields desc) sty)))))
;; syntax for tc/builtin-struct ;; syntax for tc/builtin-struct
(define-syntax (d-s stx) (define-syntax (d-s stx)

2
collects/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -121,7 +121,7 @@
;; executable structs - this is a big hack ;; executable structs - this is a big hack
[(define-values () (begin (quote-syntax (define-typed-struct/exec-internal nm ([fld : ty] ...) proc-ty)) (#%plain-app values))) [(define-values () (begin (quote-syntax (define-typed-struct/exec-internal nm ([fld : ty] ...) proc-ty)) (#%plain-app values)))
(tc/struct null #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #'proc-ty)] (tc/struct null #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:proc-ty #'proc-ty)]
;; predicate assertion - needed for define-type b/c or doesn't work ;; predicate assertion - needed for define-type b/c or doesn't work
[(define-values () (begin (quote-syntax (assert-predicate-internal ty pred)) (#%plain-app values))) [(define-values () (begin (quote-syntax (assert-predicate-internal ty pred)) (#%plain-app values)))