Attach useful metadata as syntax properties to some types
In order to make defining judgments like subytping and intersection more extensible, introduce a form for defining type constructors that describes: - how it behaves wrt intersction (product-like or container-like) - variances for subtyping - the type constructor transformer, for making new instances This eliminates a lot of very repetitive code, and should make things much more extensible
This commit is contained in:
parent
e3c7926b92
commit
c9a44ab45e
|
@ -48,10 +48,12 @@
|
||||||
require/typed
|
require/typed
|
||||||
require-struct
|
require-struct
|
||||||
)
|
)
|
||||||
|
(require (only-in turnstile
|
||||||
|
[define-type-constructor define-type-constructor-]))
|
||||||
|
|
||||||
(require (prefix-in syndicate: syndicate/actor-lang))
|
(require (prefix-in syndicate: syndicate/actor-lang))
|
||||||
|
|
||||||
(require (for-meta 2 macrotypes/stx-utils racket/list syntax/stx))
|
(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 racket/struct-info))
|
(require (for-syntax racket/struct-info))
|
||||||
(require macrotypes/postfix-in)
|
(require macrotypes/postfix-in)
|
||||||
|
@ -87,6 +89,136 @@
|
||||||
;; Types
|
;; Types
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
;; certain metadata needs to be associated with each type, for the purpose of
|
||||||
|
;; making certain judgments and metafunctions extensible.
|
||||||
|
|
||||||
|
;; a isect-desc describes how a type (constructor) behaves with respect to
|
||||||
|
;; intersection, and is one of
|
||||||
|
;; - BASE
|
||||||
|
;; - CONTAINER-LIKE
|
||||||
|
;; - PRODUCT-LIKE
|
||||||
|
(begin-for-syntax
|
||||||
|
(define BASE 'base)
|
||||||
|
(define CONTAINER-LIKE 'container-like)
|
||||||
|
(define PRODUCT-LIKE 'product-like)
|
||||||
|
|
||||||
|
;; syntax property key
|
||||||
|
(define isect-desc-key
|
||||||
|
'isect-desc-key)
|
||||||
|
|
||||||
|
(define-syntax-class isect-desc
|
||||||
|
#:attributes (val)
|
||||||
|
#:datum-literals (BASE CONTAINER-LIKE PRODUCT-LIKE)
|
||||||
|
(pattern BASE
|
||||||
|
#:attr val BASE)
|
||||||
|
(pattern CONTAINER-LIKE
|
||||||
|
#:attr val CONTAINER-LIKE)
|
||||||
|
(pattern PRODUCT-LIKE
|
||||||
|
#:attr val PRODUCT-LIKE))
|
||||||
|
|
||||||
|
;; Any -> Bool
|
||||||
|
;; recognize isect-descs
|
||||||
|
(define (isect-desc? x)
|
||||||
|
(member x (list BASE CONTAINER-LIKE PRODUCT-LIKE)))
|
||||||
|
|
||||||
|
;; syntax property key
|
||||||
|
;; syntax-transformer value
|
||||||
|
(define type-cons-key
|
||||||
|
'type-cons)
|
||||||
|
|
||||||
|
;; Type -> Bool
|
||||||
|
;; check if the type has a syntax property allowing us to create new instances
|
||||||
|
(define (reassemblable? t)
|
||||||
|
(and (syntax-property t type-cons-key) #t))
|
||||||
|
|
||||||
|
;; Type (Listof Type) -> Type
|
||||||
|
;; Create a new instance of the type with the given arguments
|
||||||
|
;; needs to have the type-cons-key
|
||||||
|
(define (reassemble-type ty args)
|
||||||
|
(define tycons (syntax-property ty type-cons-key))
|
||||||
|
(unless tycons
|
||||||
|
(error "expected to find type-cons-key"))
|
||||||
|
(type-eval #`(#,tycons #,@args))))
|
||||||
|
|
||||||
|
(define-syntax (define-type-constructor+ stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ Name:id
|
||||||
|
#:arity op arity
|
||||||
|
#:arg-variances variances
|
||||||
|
#:isect-desc desc:isect-desc
|
||||||
|
(~optional (~seq #:extra-info extra-info)))
|
||||||
|
#:with Name- (mk-- #'Name)
|
||||||
|
#:with NamePat (mk-~ #'Name)
|
||||||
|
#:with NamePat- (mk-~ #'Name-)
|
||||||
|
#:with mk (format-id #'Name "mk-~a-" (syntax-e #'Name))
|
||||||
|
#:with mk- (format-id #'Name- "mk-~a-" (syntax-e #'Name-))
|
||||||
|
(quasisyntax/loc stx
|
||||||
|
(begin-
|
||||||
|
(define-type-constructor- Name-
|
||||||
|
#:arity op arity
|
||||||
|
#:arg-variances variances
|
||||||
|
#,@(if (attribute extra-info)
|
||||||
|
#'(#:extra-info extra-info)
|
||||||
|
#'()))
|
||||||
|
(define-syntax (Name stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ t (... ...))
|
||||||
|
(set-stx-prop/preserved
|
||||||
|
(set-stx-prop/preserved
|
||||||
|
(syntax/loc stx
|
||||||
|
(Name- t (... ...)))
|
||||||
|
#,isect-desc-key
|
||||||
|
'#,(attribute desc.val))
|
||||||
|
type-cons-key
|
||||||
|
#'Name)]))
|
||||||
|
(begin-for-syntax
|
||||||
|
(define-syntax NamePat
|
||||||
|
(pattern-expander
|
||||||
|
(syntax-parser
|
||||||
|
[(_ p (... ...))
|
||||||
|
#'(NamePat- p (... ...))]))))
|
||||||
|
(define-for-syntax mk mk-)))]))
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
|
;; Syntax -> (Listof Variant)
|
||||||
|
;; make a list of the same length as the number of arguments of the given
|
||||||
|
;; (type) syntax, all covariant
|
||||||
|
(define (mk-covariant ts)
|
||||||
|
(for/list ([_ (sequence-tail (in-syntax ts) 1)])
|
||||||
|
covariant)))
|
||||||
|
|
||||||
|
;; Define a type constructor that acts like a container:
|
||||||
|
;; - covariant
|
||||||
|
;; - has an empty element (i.e. intersection always non-empty)
|
||||||
|
(define-syntax (define-container-type stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ Name:id #:arity op arity
|
||||||
|
(~optional (~seq #:extra-info extra-info)))
|
||||||
|
(quasisyntax/loc stx
|
||||||
|
(define-type-constructor+ Name
|
||||||
|
#:arity op arity
|
||||||
|
#:arg-variances mk-covariant
|
||||||
|
#:isect-desc CONTAINER-LIKE
|
||||||
|
#,@(if (attribute extra-info)
|
||||||
|
#'(#:extra-info extra-info)
|
||||||
|
#'())))]))
|
||||||
|
|
||||||
|
;; Define a type constructor that acts like a container:
|
||||||
|
;; - covariant
|
||||||
|
;; - does not have an empty element (i.e. intersection may be empty)
|
||||||
|
(define-syntax (define-product-type stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ Name:id #:arity op arity
|
||||||
|
(~optional (~seq #:extra-info extra-info)))
|
||||||
|
(quasisyntax/loc stx
|
||||||
|
(define-type-constructor+ Name
|
||||||
|
#:arity op arity
|
||||||
|
#:arg-variances mk-covariant
|
||||||
|
#:isect-desc PRODUCT-LIKE
|
||||||
|
#,@(if (attribute extra-info)
|
||||||
|
#'(#:extra-info extra-info)
|
||||||
|
#'())))]))
|
||||||
|
|
||||||
(define-binding-type Role #:arity >= 0 #:bvs = 1)
|
(define-binding-type Role #:arity >= 0 #:bvs = 1)
|
||||||
(define-type-constructor Shares #:arity = 1)
|
(define-type-constructor Shares #:arity = 1)
|
||||||
(define-type-constructor Sends #:arity = 1)
|
(define-type-constructor Sends #:arity = 1)
|
||||||
|
@ -94,7 +226,6 @@
|
||||||
(define-type-constructor Know #:arity = 1)
|
(define-type-constructor Know #:arity = 1)
|
||||||
(define-type-constructor ¬Know #:arity = 1)
|
(define-type-constructor ¬Know #:arity = 1)
|
||||||
(define-type-constructor Stop #:arity >= 1)
|
(define-type-constructor Stop #:arity >= 1)
|
||||||
(define-type-constructor Message #:arity = 1)
|
|
||||||
(define-type-constructor Field #:arity = 1)
|
(define-type-constructor Field #:arity = 1)
|
||||||
(define-type-constructor Bind #:arity = 1)
|
(define-type-constructor Bind #:arity = 1)
|
||||||
;; keep track of branches for facet effects
|
;; keep track of branches for facet effects
|
||||||
|
@ -104,16 +235,17 @@
|
||||||
(define-type-constructor Effs #:arity >= 0)
|
(define-type-constructor Effs #:arity >= 0)
|
||||||
(define-base-types OnStart OnStop OnDataflow MakesField)
|
(define-base-types OnStart OnStop OnDataflow MakesField)
|
||||||
(define-for-syntax field-prop-name 'fields)
|
(define-for-syntax field-prop-name 'fields)
|
||||||
|
|
||||||
(define-type-constructor Tuple #:arity >= 0)
|
|
||||||
(define-type-constructor Observe #:arity = 1)
|
|
||||||
(define-type-constructor Inbound #:arity = 1)
|
|
||||||
(define-type-constructor Outbound #:arity = 1)
|
|
||||||
(define-type-constructor Actor #:arity = 1)
|
(define-type-constructor Actor #:arity = 1)
|
||||||
(define-type-constructor AssertionSet #:arity = 1)
|
|
||||||
(define-type-constructor Patch #:arity = 2)
|
(define-product-type Message #:arity = 1)
|
||||||
(define-type-constructor List #:arity = 1)
|
(define-product-type Tuple #:arity >= 0)
|
||||||
(define-type-constructor Set #:arity = 1)
|
(define-product-type Observe #:arity = 1)
|
||||||
|
(define-product-type Inbound #:arity = 1)
|
||||||
|
(define-product-type Outbound #:arity = 1)
|
||||||
|
(define-container-type AssertionSet #:arity = 1)
|
||||||
|
(define-container-type Patch #:arity = 2)
|
||||||
|
(define-container-type List #:arity = 1)
|
||||||
|
(define-container-type Set #:arity = 1)
|
||||||
|
|
||||||
(define-type-constructor → #:arity > 0)
|
(define-type-constructor → #:arity > 0)
|
||||||
;; for describing the RHS
|
;; for describing the RHS
|
||||||
|
@ -226,7 +358,7 @@
|
||||||
(define-syntax (TypeConsExtraInfo stx)
|
(define-syntax (TypeConsExtraInfo stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
[(_ X (... ...)) #'('type-tag 'MakeTypeCons 'GetTypeParams)]))
|
[(_ X (... ...)) #'('type-tag 'MakeTypeCons 'GetTypeParams)]))
|
||||||
(define-type-constructor TypeCons
|
(define-product-type TypeCons
|
||||||
#:arity = #,arity
|
#:arity = #,arity
|
||||||
#:extra-info 'TypeConsExtraInfo)
|
#:extra-info 'TypeConsExtraInfo)
|
||||||
(define-syntax (MakeTypeCons stx)
|
(define-syntax (MakeTypeCons stx)
|
||||||
|
@ -448,7 +580,7 @@
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define-for-syntax (bot? t)
|
(define-for-syntax (bot? t)
|
||||||
(<: t (type-eval #'(U*))))
|
((current-typecheck-relation) t (type-eval #'(U*))))
|
||||||
|
|
||||||
(define-for-syntax (flat-type? τ)
|
(define-for-syntax (flat-type? τ)
|
||||||
(syntax-parse τ
|
(syntax-parse τ
|
||||||
|
@ -578,74 +710,79 @@
|
||||||
(type-eval #'★/t)]
|
(type-eval #'★/t)]
|
||||||
[(~U* τ ...)
|
[(~U* τ ...)
|
||||||
(type-eval #`(U #,@(stx-map replace-bind-and-discard-with-★ #'(τ ...))))]
|
(type-eval #`(U #,@(stx-map replace-bind-and-discard-with-★ #'(τ ...))))]
|
||||||
[(~Tuple τ ...)
|
[(~Any/bvs τ-cons () τ ...)
|
||||||
(type-eval #`(Tuple #,@(stx-map replace-bind-and-discard-with-★ #'(τ ...))))]
|
#:when (reassemblable? t)
|
||||||
[(~Observe τ)
|
(define subitems (for/list ([t (in-syntax #'(τ ...))])
|
||||||
(type-eval #`(Observe #,(replace-bind-and-discard-with-★ #'τ)))]
|
(replace-bind-and-discard-with-★ t)))
|
||||||
[(~Inbound τ)
|
(reassemble-type t subitems)]
|
||||||
(type-eval #`(Inbound #,(replace-bind-and-discard-with-★ #'τ)))]
|
|
||||||
[(~Outbound τ)
|
|
||||||
(type-eval #`(Outbound #,(replace-bind-and-discard-with-★ #'τ)))]
|
|
||||||
[(~Message τ)
|
|
||||||
(type-eval #`(Message #,(replace-bind-and-discard-with-★ #'τ)))]
|
|
||||||
[(~constructor-type _ τ ...)
|
|
||||||
(make-cons-type t (stx-map replace-bind-and-discard-with-★ #'(τ ...)))]
|
|
||||||
[_ t]))
|
[_ t]))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Subtyping and Judgments on Types
|
;; Subtyping and Judgments on Types
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
;; Type Type -> Bool
|
(begin-for-syntax
|
||||||
(define-for-syntax (<: t1 t2)
|
(define-syntax ~Base
|
||||||
(syntax-parse #`(#,t1 #,t2)
|
(pattern-expander
|
||||||
[((~U* τ1 ...) _)
|
(syntax-parser
|
||||||
(stx-andmap (lambda (t) (<: t t2)) #'(τ1 ...))]
|
[(_ nm:id)
|
||||||
[(_ (~U* τ2:type ...))
|
#'((~literal #%plain-app) nm)])))
|
||||||
(stx-ormap (lambda (t) (<: t1 t)) #'(τ2 ...))]
|
|
||||||
[((~Actor τ1) (~Actor τ2))
|
|
||||||
(and (<: #'τ1 #'τ2)
|
|
||||||
(<: (∩ (strip-? #'τ1) #'τ2) #'τ1))]
|
|
||||||
[((~AssertionSet τ1) (~AssertionSet τ2))
|
|
||||||
(<: #'τ1 #'τ2)]
|
|
||||||
[((~Set τ1) (~Set τ2))
|
|
||||||
(<: #'τ1 #'τ2)]
|
|
||||||
[((~Patch τ11 τ12) (~Patch τ21 τ22))
|
|
||||||
(and (<: #'τ11 #'τ21)
|
|
||||||
(<: #'τ12 #'τ22))]
|
|
||||||
[((~Tuple τ1:type ...) (~Tuple τ2:type ...))
|
|
||||||
#:when (stx-length=? #'(τ1 ...) #'(τ2 ...))
|
|
||||||
(stx-andmap <: #'(τ1 ...) #'(τ2 ...))]
|
|
||||||
[(_ ~★/t)
|
|
||||||
(flat-type? t1)]
|
|
||||||
[((~Observe τ1:type) (~Observe τ2:type))
|
|
||||||
(<: #'τ1 #'τ2)]
|
|
||||||
[((~Inbound τ1:type) (~Inbound τ2:type))
|
|
||||||
(<: #'τ1 #'τ2)]
|
|
||||||
[((~Outbound τ1:type) (~Outbound τ2:type))
|
|
||||||
(<: #'τ1 #'τ2)]
|
|
||||||
[((~Message τ1:type) (~Message τ2:type))
|
|
||||||
(<: #'τ1 #'τ2)]
|
|
||||||
[((~constructor-type t1 τ1:type ...) (~constructor-type t2 τ2:type ...))
|
|
||||||
#:when (tags-equal? #'t1 #'t2)
|
|
||||||
(and (stx-length=? #'(τ1 ...) #'(τ2 ...))
|
|
||||||
(stx-andmap <: #'(τ1 ...) #'(τ2 ...)))]
|
|
||||||
[((~→ τ-in1 ... τ-out1) (~→ τ-in2 ... τ-out2))
|
|
||||||
#:when (stx-length=? #'(τ-in1 ...) #'(τ-in2 ...))
|
|
||||||
(and (stx-andmap <: #'(τ-in2 ...) #'(τ-in1 ...))
|
|
||||||
(<: #'τ-out1 #'τ-out2))]
|
|
||||||
[(~Discard _)
|
|
||||||
#t]
|
|
||||||
;; TODO: clauses for Roles, and so on
|
|
||||||
;; should probably put this first.
|
|
||||||
[_ (type=? t1 t2)]))
|
|
||||||
|
|
||||||
;; shortcuts for mapping
|
;; Type Type -> Bool
|
||||||
(define-for-syntax ((<:l l) r)
|
;; subtyping
|
||||||
(<: l r))
|
(define (<: t1 t2)
|
||||||
|
(syntax-parse #`(#,t1 #,t2)
|
||||||
|
[(_ ~★/t)
|
||||||
|
(flat-type? t1)]
|
||||||
|
[((~U* τ1 ...) _)
|
||||||
|
(stx-andmap (lambda (t) (<: t t2)) #'(τ1 ...))]
|
||||||
|
[(_ (~U* τ2:type ...))
|
||||||
|
(stx-ormap (lambda (t) (<: t1 t)) #'(τ2 ...))]
|
||||||
|
[((~Actor τ1) (~Actor τ2))
|
||||||
|
(and (<: #'τ1 #'τ2)
|
||||||
|
(<: (∩ (strip-? #'τ1) #'τ2) #'τ1))]
|
||||||
|
[((~→ τ-in1 ... τ-out1) (~→ τ-in2 ... τ-out2))
|
||||||
|
#:when (stx-length=? #'(τ-in1 ...) #'(τ-in2 ...))
|
||||||
|
(and (stx-andmap <: #'(τ-in2 ...) #'(τ-in1 ...))
|
||||||
|
(<: #'τ-out1 #'τ-out2))]
|
||||||
|
[(~Discard _)
|
||||||
|
#t]
|
||||||
|
[((~Base τ1:id) (~Base τ2:id))
|
||||||
|
(free-identifier=? #'τ1 #'τ2)]
|
||||||
|
[((~Any/bvs τ-cons1 () τ1 ...) (~Any/bvs τ-cons2 () τ2 ...))
|
||||||
|
#:when (free-identifier=? #'τ-cons1 #'τ-cons2)
|
||||||
|
#:do [(define variances (syntax-property #'τ-cons1 'arg-variances))]
|
||||||
|
#:when variances
|
||||||
|
#:when (stx-length=? #'(τ1 ...) #'(τ2 ...))
|
||||||
|
(for/and ([ty1 (in-syntax #'(τ1 ...))]
|
||||||
|
[ty2 (in-syntax #'(τ2 ...))]
|
||||||
|
[var (in-list variances)])
|
||||||
|
(match var
|
||||||
|
[(== covariant)
|
||||||
|
(<: ty1 ty2)]
|
||||||
|
[(== contravariant)
|
||||||
|
(<: ty2 ty1)]
|
||||||
|
[(== invariant)
|
||||||
|
(and (<: ty1 ty2)
|
||||||
|
(<: ty2 ty1))]
|
||||||
|
[(== irrelevant)
|
||||||
|
#t]))]
|
||||||
|
;; TODO: clauses for Roles, and so on
|
||||||
|
[_ #f]))
|
||||||
|
|
||||||
(define-for-syntax ((<:r r) l)
|
;; shortcuts for mapping
|
||||||
(<: l r))
|
(define ((<:l l) r)
|
||||||
|
(<: l r))
|
||||||
|
|
||||||
|
(define ((<:r r) l)
|
||||||
|
(<: l r)))
|
||||||
|
|
||||||
|
;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
;; MODIFYING GLOBAL TYPECHECKING STATE!!!!!
|
||||||
|
;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||||
|
|
||||||
|
(begin-for-syntax
|
||||||
|
(current-typecheck-relation <:))
|
||||||
|
|
||||||
;; Flat-Type Flat-Type -> Type
|
;; Flat-Type Flat-Type -> Type
|
||||||
(define-for-syntax (∩ t1 t2)
|
(define-for-syntax (∩ t1 t2)
|
||||||
|
@ -656,9 +793,6 @@
|
||||||
t1]
|
t1]
|
||||||
[(~★/t _)
|
[(~★/t _)
|
||||||
t2]
|
t2]
|
||||||
[(_ _)
|
|
||||||
#:when (type=? t1 t2)
|
|
||||||
t1]
|
|
||||||
[((~U* τ1:type ...) _)
|
[((~U* τ1:type ...) _)
|
||||||
(type-eval #`(U #,@(stx-map (lambda (t) (∩ t t2)) #'(τ1 ...))))]
|
(type-eval #`(U #,@(stx-map (lambda (t) (∩ t t2)) #'(τ1 ...))))]
|
||||||
[(_ (~U* τ2:type ...))
|
[(_ (~U* τ2:type ...))
|
||||||
|
@ -666,78 +800,54 @@
|
||||||
[((~AssertionSet τ1) (~AssertionSet τ2))
|
[((~AssertionSet τ1) (~AssertionSet τ2))
|
||||||
#:with τ12 (∩ #'τ1 #'τ2)
|
#:with τ12 (∩ #'τ1 #'τ2)
|
||||||
(type-eval #'(AssertionSet τ12))]
|
(type-eval #'(AssertionSet τ12))]
|
||||||
[((~Set τ1) (~Set τ2))
|
|
||||||
#:with τ12 (∩ #'τ1 #'τ2)
|
|
||||||
(type-eval #'(Set τ12))]
|
|
||||||
[((~Patch τ11 τ12) (~Patch τ21 τ22))
|
|
||||||
#:with τ1 (∩ #'τ11 #'τ12)
|
|
||||||
#:with τ2 (∩ #'τ21 #'τ22)
|
|
||||||
(type-eval #'(Patch τ1 τ2))]
|
|
||||||
;; all of these fail-when/unless clauses are meant to cause this through to
|
|
||||||
;; the last case and result in ⊥.
|
|
||||||
;; Also, using <: is OK, even though <: refers to ∩, because <:'s use of ∩ is only
|
;; Also, using <: is OK, even though <: refers to ∩, because <:'s use of ∩ is only
|
||||||
;; in the Actor case.
|
;; in the Actor case.
|
||||||
[((~Tuple τ1:type ...) (~Tuple τ2:type ...))
|
[((~Base τ1:id) (~Base τ2:id))
|
||||||
#:fail-unless (stx-length=? #'(τ1 ...) #'(τ2 ...)) #f
|
#:when (free-identifier=? #'τ1 #'τ2)
|
||||||
#:with (τ ...) (stx-map ∩ #'(τ1 ...) #'(τ2 ...))
|
t1]
|
||||||
;; I don't think stx-ormap is part of the documented api of turnstile *shrug*
|
[((~Any/bvs τ-cons1 () τ1 ...) (~Any/bvs τ-cons2 () τ2 ...))
|
||||||
#:fail-when (stx-ormap (lambda (t) (<: t (type-eval #'(U)))) #'(τ ...)) #f
|
#:when (free-identifier=? #'τ-cons1 #'τ-cons2)
|
||||||
(type-eval #'(Tuple τ ...))]
|
#:when (stx-length=? #'(τ1 ...) #'(τ2 ...))
|
||||||
[((~constructor-type tag1 τ1:type ...) (~constructor-type tag2 τ2:type ...))
|
#:do [(define desc (syntax-property t1 isect-desc-key))]
|
||||||
#:when (tags-equal? #'tag1 #'tag2)
|
#:when desc
|
||||||
#:with (τ ...) (stx-map ∩ #'(τ1 ...) #'(τ2 ...))
|
(define slots (stx-map ∩ #'(τ1 ...) #'(τ2 ...)))
|
||||||
#:fail-when (stx-ormap (lambda (t) (<: t (type-eval #'(U)))) #'(τ ...)) #f
|
(match desc
|
||||||
(make-cons-type t1 #'(τ ...))]
|
[(== BASE)
|
||||||
;; these three are just the same :(
|
(error "this isn't right")]
|
||||||
[((~Observe τ1:type) (~Observe τ2:type))
|
[(== CONTAINER-LIKE)
|
||||||
#:with τ (∩ #'τ1 #'τ2)
|
(reassemble-type t1 slots)]
|
||||||
#:fail-when (<: #'τ (type-eval #'(U))) #f
|
[(== PRODUCT-LIKE)
|
||||||
(type-eval #'(Observe τ))]
|
(if (ormap bot? slots)
|
||||||
[((~Inbound τ1:type) (~Inbound τ2:type))
|
(type-eval #'(U))
|
||||||
#:with τ (∩ #'τ1 #'τ2)
|
(reassemble-type t1 slots))])]
|
||||||
#:fail-when (<: #'τ (type-eval #'(U))) #f
|
|
||||||
(type-eval #'(Inbound τ))]
|
|
||||||
[((~Outbound τ1:type) (~Outbound τ2:type))
|
|
||||||
#:with τ (∩ #'τ1 #'τ2)
|
|
||||||
#:fail-when (<: #'τ (type-eval #'(U))) #f
|
|
||||||
(type-eval #'(Outbound τ))]
|
|
||||||
[((~Message τ1:type) (~Message τ2:type))
|
|
||||||
#:with τ (∩ #'τ1 #'τ2)
|
|
||||||
#:fail-when (<: #'τ (type-eval #'(U))) #f
|
|
||||||
(type-eval #'(Message τ))]
|
|
||||||
[_ (type-eval #'(U))]))
|
[_ (type-eval #'(U))]))
|
||||||
|
|
||||||
;; Type Type -> Bool
|
;; Type Type -> Bool
|
||||||
;; first type is the contents of the set/dataspace
|
;; first type is the contents of the set/dataspace
|
||||||
;; second type is the type of a pattern
|
;; second type is the type of a pattern
|
||||||
(define-for-syntax (project-safe? t1 t2)
|
(define-for-syntax (project-safe? t1 t2)
|
||||||
;; TODO - messages
|
(define (project-safe* t1 t2)
|
||||||
(syntax-parse #`(#,t1 #,t2)
|
(syntax-parse #`(#,t1 #,t2)
|
||||||
[(_ (~Bind τ2:type))
|
[(_ (~Bind τ2:type))
|
||||||
(and (finite? t1) (<: t1 #'τ2))]
|
(and (finite? t1) (<: t1 #'τ2))]
|
||||||
[(_ ~Discard)
|
[(_ ~Discard)
|
||||||
#t]
|
#t]
|
||||||
[(_ ~★/t)
|
[(_ ~★/t)
|
||||||
#t]
|
#t]
|
||||||
[((~U* τ1:type ...) _)
|
[((~U* τ1:type ...) _)
|
||||||
(stx-andmap (lambda (t) (project-safe? t t2)) #'(τ1 ...))]
|
(stx-andmap (lambda (t) (project-safe? t t2)) #'(τ1 ...))]
|
||||||
[(_ (~U* τ2:type ...))
|
[(_ (~U* τ2:type ...))
|
||||||
(stx-andmap (lambda (t) (project-safe? t1 t)) #'(τ2 ...))]
|
(stx-andmap (lambda (t) (project-safe? t1 t)) #'(τ2 ...))]
|
||||||
[((~Tuple τ1:type ...) (~Tuple τ2:type ...))
|
[((~Any/bvs τ-cons1 () τ1 ...) (~Any/bvs τ-cons2 () τ2 ...))
|
||||||
#:when (overlap? t1 t2)
|
#:when (free-identifier=? #'τ-cons1 #'τ-cons2)
|
||||||
(stx-andmap project-safe? #'(τ1 ...) #'(τ2 ...))]
|
#:when (stx-length=? #'(τ1 ...) #'(τ2 ...))
|
||||||
[((~constructor-type _ τ1:type ...) (~constructor-type _ τ2:type ...))
|
#:do [(define desc (syntax-property t1 isect-desc-key))]
|
||||||
#:when (overlap? t1 t2)
|
#:when (equal? desc PRODUCT-LIKE)
|
||||||
(stx-andmap project-safe? #'(τ1 ...) #'(τ2 ...))]
|
(stx-andmap project-safe? #'(τ1 ...) #'(τ2 ...))]
|
||||||
[((~Observe τ1:type) (~Observe τ2:type))
|
[_ #t]))
|
||||||
(project-safe? #'τ1 #'τ2)]
|
(if (overlap? t1 t2)
|
||||||
[((~Inbound τ1:type) (~Inbound τ2:type))
|
(project-safe* t1 t2)
|
||||||
(project-safe? #'τ1 #'τ2)]
|
#t))
|
||||||
[((~Outbound τ1:type) (~Outbound τ2:type))
|
|
||||||
(project-safe? #'τ1 #'τ2)]
|
|
||||||
[((~Message τ1:type) (~Message τ2:type))
|
|
||||||
(project-safe? #'τ1 #'τ2)]
|
|
||||||
[_ #t]))
|
|
||||||
|
|
||||||
;; AssertionType PatternType -> Bool
|
;; AssertionType PatternType -> Bool
|
||||||
;; Is it possible for things of these two types to match each other?
|
;; Is it possible for things of these two types to match each other?
|
||||||
|
@ -752,21 +862,9 @@
|
||||||
[~★/t #f]
|
[~★/t #f]
|
||||||
[(~U* τ:type ...)
|
[(~U* τ:type ...)
|
||||||
(stx-andmap finite? #'(τ ...))]
|
(stx-andmap finite? #'(τ ...))]
|
||||||
[(~Tuple τ:type ...)
|
[(~Base _) #t]
|
||||||
(stx-andmap finite? #'(τ ...))]
|
[(~Any/bvs τ-cons () τ ...)
|
||||||
[(~constructor-type _ τ:type ...)
|
(stx-andmap finite? #'(τ ...))]))
|
||||||
(stx-andmap finite? #'(τ ...))]
|
|
||||||
[(~Observe τ:type)
|
|
||||||
(finite? #'τ)]
|
|
||||||
[(~Inbound τ:type)
|
|
||||||
(finite? #'τ)]
|
|
||||||
[(~Outbound τ:type)
|
|
||||||
(finite? #'τ)]
|
|
||||||
[(~Set τ:type)
|
|
||||||
(finite? #'τ)]
|
|
||||||
[(~Message τ:type)
|
|
||||||
(finite? #'τ)]
|
|
||||||
[_ #t]))
|
|
||||||
|
|
||||||
;; PatternType -> Type
|
;; PatternType -> Type
|
||||||
(define-for-syntax (pattern-matching-assertions t)
|
(define-for-syntax (pattern-matching-assertions t)
|
||||||
|
@ -777,18 +875,11 @@
|
||||||
(type-eval #'★/t)]
|
(type-eval #'★/t)]
|
||||||
[(~U* τ ...)
|
[(~U* τ ...)
|
||||||
(type-eval #`(U #,@(stx-map pattern-matching-assertions #'(τ ...))))]
|
(type-eval #`(U #,@(stx-map pattern-matching-assertions #'(τ ...))))]
|
||||||
[(~Tuple τ ...)
|
[(~Any/bvs τ-cons () τ ...)
|
||||||
(type-eval #`(Tuple #,@(stx-map pattern-matching-assertions #'(τ ...))))]
|
#:when (reassemblable? t)
|
||||||
[(~Observe τ)
|
(define subitems (for/list ([t (in-syntax #'(τ ...))])
|
||||||
(type-eval #`(Observe #,(pattern-matching-assertions #'τ)))]
|
(pattern-matching-assertions t)))
|
||||||
[(~Inbound τ)
|
(reassemble-type t subitems)]
|
||||||
(type-eval #`(Inbound #,(pattern-matching-assertions #'τ)))]
|
|
||||||
[(~Outbound τ)
|
|
||||||
(type-eval #`(Outbound #,(pattern-matching-assertions #'τ)))]
|
|
||||||
[(~Message τ)
|
|
||||||
(type-eval #`(Message #,(pattern-matching-assertions #'τ)))]
|
|
||||||
[(~constructor-type _ τ ...)
|
|
||||||
(make-cons-type t (stx-map pattern-matching-assertions #'(τ ...)))]
|
|
||||||
[_ 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
|
||||||
|
@ -1019,13 +1110,6 @@
|
||||||
(Reacts OnStart (Actor (U Int String)))))
|
(Reacts OnStart (Actor (U Int String)))))
|
||||||
)))
|
)))
|
||||||
|
|
||||||
;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
;; MODIFYING GLOBAL TYPECHECKING STATE!!!!!
|
|
||||||
;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
||||||
|
|
||||||
(begin-for-syntax
|
|
||||||
(current-typecheck-relation <:))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Effect Checking
|
;; Effect Checking
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue