More struct work
original commit: d84391b6956f0eef2253d393dc9d05cf7efa5db4
This commit is contained in:
Eric Dobson
Sam Tobin-Hochstadt
parent
11df3e8261
commit
c73df4ed19
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user