Use a mutable, compile-time table for type metadata
This commit is contained in:
parent
a84b80a49b
commit
fc220a4e16
|
@ -11,7 +11,8 @@
|
||||||
(require (for-meta 2 macrotypes/stx-utils racket/list syntax/stx syntax/parse racket/base))
|
(require (for-meta 2 macrotypes/stx-utils racket/list syntax/stx syntax/parse racket/base))
|
||||||
(require (for-syntax turnstile/examples/util/filter-maximal))
|
(require (for-syntax turnstile/examples/util/filter-maximal))
|
||||||
(require (for-syntax macrotypes/type-constraints macrotypes/variance-constraints))
|
(require (for-syntax macrotypes/type-constraints macrotypes/variance-constraints))
|
||||||
(require (for-syntax racket/struct-info))
|
(require (for-syntax racket/struct-info
|
||||||
|
syntax/id-table))
|
||||||
(require macrotypes/postfix-in)
|
(require macrotypes/postfix-in)
|
||||||
(require (rename-in racket/math [exact-truncate exact-truncate-]))
|
(require (rename-in racket/math [exact-truncate exact-truncate-]))
|
||||||
(require (postfix-in - racket/list))
|
(require (postfix-in - racket/list))
|
||||||
|
@ -42,18 +43,39 @@
|
||||||
;; certain metadata needs to be associated with each type, for the purpose of
|
;; certain metadata needs to be associated with each type, for the purpose of
|
||||||
;; making certain judgments and metafunctions extensible.
|
;; making certain judgments and metafunctions extensible.
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
|
(struct type-metadata (isec cons) #:transparent)
|
||||||
|
;; (IdTable type-metadata)
|
||||||
|
(define TypeInfo# (make-free-id-table))
|
||||||
|
;; Identifier isect-desc TypeCons -> Void
|
||||||
|
(define (set-type-info! ty-cons isec cons)
|
||||||
|
(free-id-table-set! TypeInfo#
|
||||||
|
ty-cons
|
||||||
|
(type-metadata isec cons)))
|
||||||
|
;; Identifier -> (U #f type-metadata)
|
||||||
|
(define (get-type-info ty-cons)
|
||||||
|
(free-id-table-ref TypeInfo# ty-cons #f))
|
||||||
|
|
||||||
|
;; Identifier -> (U #f isec-desc)
|
||||||
|
(define (get-type-isec-desc ty-cons)
|
||||||
|
(define result? (get-type-info ty-cons))
|
||||||
|
(and result? (type-metadata-isec result?)))
|
||||||
|
;; Identifier -> (U #f TypeCons)
|
||||||
|
(define (get-type-cons ty-cons)
|
||||||
|
(define result? (get-type-info ty-cons))
|
||||||
|
(and result? (type-metadata-cons result?)))
|
||||||
|
|
||||||
;; a isect-desc describes how a type (constructor) behaves with respect to
|
;; a isect-desc describes how a type (constructor) behaves with respect to
|
||||||
;; intersection, and is one of
|
;; intersection, and is one of
|
||||||
;; - BASE
|
;; - BASE
|
||||||
;; - CONTAINER-LIKE
|
;; - CONTAINER-LIKE
|
||||||
;; - PRODUCT-LIKE
|
;; - PRODUCT-LIKE
|
||||||
(begin-for-syntax
|
|
||||||
(define BASE 'base)
|
(define BASE 'base)
|
||||||
(define CONTAINER-LIKE 'container-like)
|
(define CONTAINER-LIKE 'container-like)
|
||||||
(define PRODUCT-LIKE 'product-like)
|
(define PRODUCT-LIKE 'product-like)
|
||||||
|
|
||||||
;; syntax property key
|
;; syntax property key
|
||||||
(define isect-desc-key
|
#;(define isect-desc-key
|
||||||
'isect-desc-key)
|
'isect-desc-key)
|
||||||
|
|
||||||
(define-syntax-class isect-desc
|
(define-syntax-class isect-desc
|
||||||
|
@ -76,19 +98,19 @@
|
||||||
(define type-cons-key
|
(define type-cons-key
|
||||||
'type-cons)
|
'type-cons)
|
||||||
|
|
||||||
;; Type -> Bool
|
;; Identifier -> Bool
|
||||||
;; check if the type has a syntax property allowing us to create new instances
|
;; check if the type has a syntax property allowing us to create new instances
|
||||||
(define (reassemblable? t)
|
(define (reassemblable? t)
|
||||||
(and (syntax-property t type-cons-key) #t))
|
(and (get-type-cons t) #t))
|
||||||
|
|
||||||
;; Type (Listof Type) -> Type
|
;; Identifier (Listof Type) -> Type
|
||||||
;; Create a new instance of the type with the given arguments
|
;; Create a new instance of the type with the given arguments
|
||||||
;; needs to have the type-cons-key
|
;; needs to have the type-cons-key
|
||||||
(define (reassemble-type ty args)
|
(define (reassemble-type ty args)
|
||||||
(define tycons (syntax-property ty type-cons-key))
|
(define tycons (get-type-cons ty))
|
||||||
(unless tycons
|
(unless tycons
|
||||||
(error "expected to find type-cons-key"))
|
(error "expected to find type-cons-key"))
|
||||||
(type-eval #`(#,tycons #,@args))))
|
(tycons args)))
|
||||||
|
|
||||||
(define-syntax (define-type-constructor+ stx)
|
(define-syntax (define-type-constructor+ stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
|
@ -113,15 +135,10 @@
|
||||||
(define-syntax (Name stx)
|
(define-syntax (Name stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ t (... ...))
|
[(_ t (... ...))
|
||||||
(set-stx-prop/preserved
|
|
||||||
(set-stx-prop/preserved
|
|
||||||
(syntax/loc stx
|
(syntax/loc stx
|
||||||
(Name- t (... ...)))
|
(Name- t (... ...)))]))
|
||||||
#,isect-desc-key
|
|
||||||
'#,(attribute desc.val))
|
|
||||||
type-cons-key
|
|
||||||
#'Name)]))
|
|
||||||
(begin-for-syntax
|
(begin-for-syntax
|
||||||
|
(set-type-info! #'Name- '#,(attribute desc.val) #'mk-)
|
||||||
(define-syntax NamePat
|
(define-syntax NamePat
|
||||||
(pattern-expander
|
(pattern-expander
|
||||||
(syntax-parser
|
(syntax-parser
|
||||||
|
@ -701,10 +718,10 @@
|
||||||
[(~U* τ ...)
|
[(~U* τ ...)
|
||||||
(mk-U- (stx-map replace-bind-and-discard-with-★ #'(τ ...)))]
|
(mk-U- (stx-map replace-bind-and-discard-with-★ #'(τ ...)))]
|
||||||
[(~Any/bvs τ-cons () τ ...)
|
[(~Any/bvs τ-cons () τ ...)
|
||||||
#:when (reassemblable? t)
|
#:when (reassemblable? #'τ-cons)
|
||||||
(define subitems (for/list ([t (in-syntax #'(τ ...))])
|
(define subitems (for/list ([t (in-syntax #'(τ ...))])
|
||||||
(replace-bind-and-discard-with-★ t)))
|
(replace-bind-and-discard-with-★ t)))
|
||||||
(reassemble-type t subitems)]
|
(reassemble-type #'τ-cons subitems)]
|
||||||
[_ t]))
|
[_ t]))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
@ -809,18 +826,18 @@
|
||||||
[((~Any/bvs τ-cons1 () τ1 ...) (~Any/bvs τ-cons2 () τ2 ...))
|
[((~Any/bvs τ-cons1 () τ1 ...) (~Any/bvs τ-cons2 () τ2 ...))
|
||||||
#:when (free-identifier=? #'τ-cons1 #'τ-cons2)
|
#:when (free-identifier=? #'τ-cons1 #'τ-cons2)
|
||||||
#:when (stx-length=? #'(τ1 ...) #'(τ2 ...))
|
#:when (stx-length=? #'(τ1 ...) #'(τ2 ...))
|
||||||
#:do [(define desc (syntax-property t1 isect-desc-key))]
|
#:do [(define desc (get-type-isec-desc #'τ-cons1))]
|
||||||
#:when desc
|
#:when desc
|
||||||
(define slots (stx-map ∩ #'(τ1 ...) #'(τ2 ...)))
|
(define slots (stx-map ∩ #'(τ1 ...) #'(τ2 ...)))
|
||||||
(match desc
|
(match desc
|
||||||
[(== BASE)
|
[(== BASE)
|
||||||
(error "this isn't right")]
|
(error "this isn't right")]
|
||||||
[(== CONTAINER-LIKE)
|
[(== CONTAINER-LIKE)
|
||||||
(reassemble-type t1 slots)]
|
(reassemble-type #'τ-cons1 slots)]
|
||||||
[(== PRODUCT-LIKE)
|
[(== PRODUCT-LIKE)
|
||||||
(if (ormap bot? slots)
|
(if (ormap bot? slots)
|
||||||
(type-eval #'(U))
|
(type-eval #'(U))
|
||||||
(reassemble-type t1 slots))])]
|
(reassemble-type #'τ-cons1 slots))])]
|
||||||
[_ (type-eval #'(U))]))
|
[_ (type-eval #'(U))]))
|
||||||
|
|
||||||
;; Type Type -> Bool
|
;; Type Type -> Bool
|
||||||
|
@ -843,7 +860,7 @@
|
||||||
[((~Any/bvs τ-cons1 () τ1 ...) (~Any/bvs τ-cons2 () τ2 ...))
|
[((~Any/bvs τ-cons1 () τ1 ...) (~Any/bvs τ-cons2 () τ2 ...))
|
||||||
#:when (free-identifier=? #'τ-cons1 #'τ-cons2)
|
#:when (free-identifier=? #'τ-cons1 #'τ-cons2)
|
||||||
#:when (stx-length=? #'(τ1 ...) #'(τ2 ...))
|
#:when (stx-length=? #'(τ1 ...) #'(τ2 ...))
|
||||||
#:do [(define desc (syntax-property t1 isect-desc-key))]
|
#:do [(define desc (get-type-isec-desc #'τ-cons1))]
|
||||||
#:when (equal? desc PRODUCT-LIKE)
|
#:when (equal? desc PRODUCT-LIKE)
|
||||||
(stx-andmap project-safe? #'(τ1 ...) #'(τ2 ...))]
|
(stx-andmap project-safe? #'(τ1 ...) #'(τ2 ...))]
|
||||||
[_ #t]))
|
[_ #t]))
|
||||||
|
@ -881,10 +898,10 @@
|
||||||
[(~U* τ ...)
|
[(~U* τ ...)
|
||||||
(type-eval #`(U #,@(stx-map pattern-matching-assertions #'(τ ...))))]
|
(type-eval #`(U #,@(stx-map pattern-matching-assertions #'(τ ...))))]
|
||||||
[(~Any/bvs τ-cons () τ ...)
|
[(~Any/bvs τ-cons () τ ...)
|
||||||
#:when (reassemblable? t)
|
#:when (reassemblable? #'τ-cons)
|
||||||
(define subitems (for/list ([t (in-syntax #'(τ ...))])
|
(define subitems (for/list ([t (in-syntax #'(τ ...))])
|
||||||
(pattern-matching-assertions t)))
|
(pattern-matching-assertions t)))
|
||||||
(reassemble-type t subitems)]
|
(reassemble-type #'τ-cons subitems)]
|
||||||
[_ t]))
|
[_ t]))
|
||||||
|
|
||||||
;; it's ok for x to respond to strictly more events than y
|
;; it's ok for x to respond to strictly more events than y
|
||||||
|
|
Loading…
Reference in New Issue