diff --git a/collects/typed-racket/typecheck/tc-structs.rkt b/collects/typed-racket/typecheck/tc-structs.rkt index 6db3b89e..d328a9b3 100644 --- a/collects/typed-racket/typecheck/tc-structs.rkt +++ b/collects/typed-racket/typecheck/tc-structs.rkt @@ -25,7 +25,7 @@ (require (for-template racket/base "internal-forms.rkt")) -(provide tc/struct tc/poly-struct names-of-struct d-s) +(provide tc/struct names-of-struct d-s) (define-syntax-class parent #:attributes (name par) @@ -50,37 +50,43 @@ ;; parse name field of struct, determining whether a parent struct was specified -;; syntax -> (values identifier Option[Name] Option[Struct] Symbol Type) -(define (parse-parent nm/par) +;; syntax -> (values identifier Option[Name] Option[Struct]) +(define/cond-contract (parse-parent nm/par) + (c-> syntax? (values identifier? (or/c Name? #f) (or/c Mu? Poly? Struct? #f))) (syntax-parse nm/par [v:parent (if (attribute v.par) (let* ([parent0 (parse-type #'v.par)] - [parent (if (Name? parent0) - ;; TODO ensure this is a struct - (resolve-name parent0) - (tc-error/stx #'v.par "parent type not a valid structure name: ~a" - (syntax->datum #'v.par)))]) + ;; TODO ensure this is a struct + [parent (let loop ((parent parent0)) + (cond + ((Name? parent) (loop (resolve-name parent))) + ((or (Poly? parent) (Mu? parent) (Struct? parent)) + parent) + (else + (tc-error/stx #'v.par "parent type not a valid structure name: ~a" + (syntax->datum #'v.par)))))]) (values #'v.name parent0 parent)) (values #'v.name #f #f))])) -;; generate struct names given type name and field names -;; generate setters if setters? is true + +(struct struct-names (type-name struct-type constructor predicate getters setters)) +;; generate struct names given type name, field names +;; and optional constructor name ;; all have syntax loc of name -;; identifier listof[identifier] boolean -> -;; (values identifier identifier list[identifier] Option[list[identifier]]) -(define (struct-names nm flds setters?) +;; identifier listof[identifier] Option[identifier] -> +;; (values identifier identifier list[identifier] list[identifier]) +(define (get-struct-names nm flds maker*) (define (split l) (let loop ([l l] [getters '()] [setters '()]) (if (null? l) (values (reverse getters) (reverse setters)) (loop (cddr l) (cons (car l) getters) (cons (cadr l) setters))))) - (match (build-struct-names nm flds #f (not setters?) nm) + (match (build-struct-names nm flds #f #f nm) [(list sty maker pred getters/setters ...) - (if setters? - (let-values ([(getters setters) (split getters/setters)]) - (values sty maker pred getters setters)) - (values sty maker pred getters/setters #f))])) + (let-values ([(getters setters) (split getters/setters)]) + (struct-names nm sty (or maker* maker) pred getters setters))])) + ;; gets the fields of the parent type, if they exist ;; Option[Struct-Ty] -> Listof[Type] @@ -93,46 +99,70 @@ ;; construct all the various types for structs, and then register the approriate names ;; identifier listof[identifier] type listof[fld] listof[Type] boolean -> ;; (values Type listof[Type] listof[Type]) -(define/cond-contract (mk/register-sty nm flds parent parent-fields types - #:wrapper [wrapper values] - #:type-wrapper [type-wrapper values] - #:pred-wrapper [pred-wrapper values] - #:mutable [setters? #f] +(define/cond-contract (mk/register-sty names parent types + #:mutable [mutable #f] #:proc-ty [proc-ty #f] - #:maker [maker* #f] - #:poly? [poly? null] - #:type-only [type-only #f]) - (c->* (identifier? (listof identifier?) (or/c Type/c #f) (listof fld?) (listof Type/c)) - (#:wrapper procedure? - #:type-wrapper procedure? - #:pred-wrapper procedure? - #:mutable boolean? + #:poly? [poly? null]) + (c->* (struct-names? (or/c Struct? #f) (listof Type/c)) + (#:mutable boolean? #:proc-ty (or/c #f Type/c) - #:maker (or/c #f identifier?) - #:poly? (listof symbol?) - #:type-only boolean?) + #:poly? (listof symbol?)) any/c) - ;; create the approriate names that define-struct will bind - (define-values (_1 maker** pred getters _2) (struct-names nm flds setters?)) - (define maker (or maker* maker**)) - (let* ([fld-names flds] - [this-flds (for/list ([t (in-list types)] - [g (in-list getters)]) - (make-fld t g setters?))] - [flds (append parent-fields this-flds)] - [sty (make-Struct nm parent flds proc-ty (not (null? poly?)) pred)] + + (define sty + (mk/inner-struct-type names parent types + #: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-type-name nm (wrapper sty)) - (unless type-only - (register-struct-types nm sty fld-names external-fld-types - external-fld-types/no-parent setters? - #:wrapper wrapper - #:type-wrapper type-wrapper - #:pred-wrapper pred-wrapper - #:maker maker - #:poly? poly?)))) + + (register-struct-types sty names external-fld-types + external-fld-types/no-parent mutable + #:poly? poly?))) + @@ -140,61 +170,63 @@ ;; generate names, and register the approriate types give field types and structure type ;; optionally wrap things ;; identifier Type Listof[identifier] Listof[Type] Listof[Type] -;; #:wrapper (Type -> Type) #:maker identifier -> Void -(define/cond-contract (register-struct-types nm sty flds external-fld-types - external-fld-types/no-parent setters? - #:wrapper wrapper - #:type-wrapper type-wrapper - #:pred-wrapper pred-wrapper - #:maker maker +;; #:maker identifier -> Void +(define/cond-contract (register-struct-types sty names external-fld-types + external-fld-types/no-parent mutable #:poly? poly?) - (c-> identifier? Struct? (listof identifier?) (listof Type/c) (listof Type/c) boolean? - #:wrapper procedure? - #:type-wrapper procedure? - #:pred-wrapper procedure? - #:maker identifier? + (c-> Struct? struct-names? (listof Type/c) (listof Type/c) boolean? #:poly? (listof symbol?) void?) - ;; create the approriate names that define-struct will bind - (define-values (struct-type-id _2 pred getters setters) (struct-names nm flds setters?)) + ;; the type name that is used in all the types - (define name (type-wrapper (make-Name nm))) + (define name + (if (null? poly?) + (make-Name (struct-names-type-name names)) + (make-App (make-Name (struct-names-type-name names)) (map make-F poly?) #f))) + + (define (poly-wrapper t) (make-Poly poly? t)) ;; is this structure covariant in *all* arguments? (define covariant? (for*/and ([var (in-list poly?)] [t (in-list external-fld-types)]) (let ([variance (hash-ref (free-vars* t) var Constant)]) (or (eq? variance Constant) - (and (not setters?) (eq? variance Covariant)))))) + (and (not mutable) (eq? variance Covariant)))))) (define parent-count (- (length external-fld-types) (length external-fld-types/no-parent))) ;; the list of names w/ types - (register-type struct-type-id (make-StructType sty)) - (register-type maker (wrapper (->* external-fld-types name))) - (register-type pred + (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-predicate names) (make-pred-ty (if (not covariant?) (make-StructTop sty) - (pred-wrapper name)))) - (for ([g (in-list getters)] + (subst-all (make-simple-substitution + poly? (map (const Univ) poly?)) name)))) + + (for ([g (in-list (struct-names-getters names))] [t (in-list external-fld-types/no-parent)] [i (in-naturals parent-count)]) (let* ([path (make-StructPE name i)] - [func (if setters? + [func (if mutable (->* (list name) t) (->acc (list name) t (list path)))]) (add-struct-fn! g path #f) - (register-type g (wrapper func)))) - (when setters? - (for ([g (in-list setters)] + (register-type g (poly-wrapper func)))) + (when mutable + (for ([g (in-list (struct-names-setters names))] [t (in-list external-fld-types/no-parent)] [i (in-naturals parent-count)]) (add-struct-fn! g (make-StructPE name i) #t) - (register-type g (wrapper (->* (list name t) -Void)))))) + (register-type g (poly-wrapper (->* (list name t) -Void)))))) -;; check and register types for a polymorphic define struct -;; tc/poly-struct : Listof[identifier] (U identifier (list identifier identifier)) -;; Listof[identifier] Listof[syntax] -;; -> void -(define (tc/poly-struct vars nm/par flds tys #:maker [maker #f] #:mutable [mutable #f]) +;; check and register types for a define struct +;; tc/struct : Listof[identifier] (U identifier (list identifier identifier)) +;; Listof[identifier] Listof[syntax] +;; -> void +(define (tc/struct vars nm/par fld-names tys + #:proc-ty [proc-ty #f] + #:maker [maker #f] + #:mutable [mutable #f] + #:type-only [type-only #f]) ;; parent field types can't actually be determined here (define-values (nm parent-name parent) (parse-parent nm/par)) ;; create type variables for the new type parameters @@ -216,52 +248,21 @@ (length new-tvars)) (instantiate-poly parent (take new-tvars (Poly-n parent)))) parent)) - ;; get the fields of the parent, if it exists - (define parent-field-types (get-parent-flds concrete-parent)) ;; create the actual structure type, and the types of the fields ;; that the outside world will see ;; then register them - (mk/register-sty nm flds concrete-parent parent-field-types types - #:maker maker + (define names (get-struct-names nm fld-names maker)) + (mk/register-sty names concrete-parent types #:mutable mutable ;; wrap everything in the approriate forall - #:wrapper (λ (t) (make-Poly tvars t)) - #:type-wrapper (λ (t) (make-App t new-tvars #f)) - #:pred-wrapper (λ (t) (subst-all (make-simple-substitution - tvars (map (const Univ) tvars)) t)) - #:poly? tvars)) + #:poly? tvars) + (unless type-only + (mk/register-struct-bindings names concrete-parent types + #:mutable mutable + ;; wrap everything in the approriate forall + #:poly? tvars))) -;; typecheck a non-polymophic struct and register the approriate types -;; tc/struct : (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void -(define/cond-contract (tc/struct nm/par flds tys [proc-ty #f] - #:maker [maker #f] - #:mutable [mutable #f] - #:type-only [type-only #f]) - (c->* (syntax? (listof identifier?) (listof syntax?)) - ((or/c #f syntax?) - #:maker any/c - #:mutable boolean? - #:type-only boolean?) - any/c) - ;; get the parent info and create some types and type variables - (define-values (nm parent-name parent) (parse-parent nm/par)) - ;; parse the field types, and determine if the type is recursive - (define types (map parse-type tys)) - (define proc-ty-parsed (and proc-ty (parse-type proc-ty))) - - (when (Poly? parent) - (tc-error "Could not instantiate parent struct type. Required ~a type variables, recieved none." - (Poly-n parent))) - - ;; create the actual structure type, and the types of the fields - ;; that the outside world will see - (mk/register-sty nm flds parent (get-parent-flds parent) types - ;; procedure - #:proc-ty proc-ty-parsed - #:maker maker - #:mutable mutable - #:type-only type-only)) ;; register a struct type ;; convenience function for built-in structs @@ -269,20 +270,19 @@ ;; Listof[Type] Maybe[identifier] Listof[Type] ;; -> void ;; FIXME - figure out how to make this lots lazier -(define/cond-contract (tc/builtin-struct nm parent flds tys kernel-maker) +(define/cond-contract (tc/builtin-struct nm parent fld-names tys kernel-maker) (c-> identifier? (or/c #f identifier?) (listof identifier?) (listof Type/c) (or/c #f identifier?) any/c) - (define parent-name (and parent (make-Name parent))) - (define parent-type (and parent (lookup-type-name parent))) - (define parent-flds (get-parent-flds (and parent-name (resolve-name parent-name)))) + (define parent-type (and parent (resolve-name (make-Name parent)))) + (define parent-tys (map fld-t (get-parent-flds parent-type))) + (define names (get-struct-names nm fld-names #f)) - (define parent-tys (map fld-t parent-flds)) - (define defs (mk/register-sty nm flds parent-type parent-flds tys #:mutable #t)) + (mk/register-sty names parent-type tys #:mutable #t) + (mk/register-struct-bindings names parent-type tys #:mutable #t) (when kernel-maker (register-type kernel-maker (λ () (->* (append parent-tys tys) (lookup-type-name nm)))))) - ;; syntax for tc/builtin-struct (define-syntax (d-s stx) (define-splicing-syntax-class options diff --git a/collects/typed-racket/typecheck/tc-toplevel.rkt b/collects/typed-racket/typecheck/tc-toplevel.rkt index 17c25ca7..a64162fb 100644 --- a/collects/typed-racket/typecheck/tc-toplevel.rkt +++ b/collects/typed-racket/typecheck/tc-toplevel.rkt @@ -96,32 +96,32 @@ ;; 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 ...)))] + (tc/struct null #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))] [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:mutable)) (#%plain-app values))) - (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:mutable #t)] + (tc/struct null #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:mutable #t)] [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) fields:dtsi-fields)) (#%plain-app values))) - (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) + (tc/struct null #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:mutable (attribute fields.mutable) #:maker (attribute fields.maker) #:type-only (attribute fields.type-only))] ;; define-typed-struct w/ polymorphism [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...) #:maker m)) (#%plain-app values))) - (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m)] + (tc/struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m)] [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...) #:maker m #:mutable)) (#%plain-app values))) - (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m #:mutable #t)] + (tc/struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m #:mutable #t)] [(define-values () (begin (quote-syntax (define-typed-struct-internal (vars ...) nm ([fld : ty] ...) #:mutable)) (#%plain-app values))) - (tc/poly-struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:mutable #t)] + (tc/struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:mutable #t)] [(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 ...)))] + (tc/struct (syntax->list #'(vars ...)) #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))] ;; error in other cases [(define-values () (begin (quote-syntax (define-typed-struct-internal . _)) (#%plain-app values))) (int-err "unknown structure form")] ;; 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))) - (tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #'proc-ty)] + (tc/struct null #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #'proc-ty)] ;; 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))) diff --git a/collects/typed-racket/utils/utils.rkt b/collects/typed-racket/utils/utils.rkt index b1c9ed66..b7f2bef0 100644 --- a/collects/typed-racket/utils/utils.rkt +++ b/collects/typed-racket/utils/utils.rkt @@ -20,7 +20,7 @@ at least theoretically. rep utils typecheck infer env private types) (define optimize? (make-parameter #t)) -(define-for-syntax enable-contracts? #f) +(define-for-syntax enable-contracts? #t) (define-syntax do-contract-req (if enable-contracts?