Fix instantiate and abstract to handle bounds properly.
NEW INVARIANT - only use instantiate w/ names
This commit is contained in:
Sam Tobin-Hochstadt
parent
a7c63840e4
commit
017f756c77
|
|
@ -5,7 +5,7 @@
|
|||
|
||||
(require "unify.ss" "type-comparison.ss" "type-rep.ss" "effect-rep.ss" "subtype.ss"
|
||||
"planet-requires.ss" "tc-utils.ss" "union.ss"
|
||||
"resolve-type.ss"
|
||||
"resolve-type.ss" "type-utils.ss"
|
||||
"type-effect-convenience.ss"
|
||||
(lib "trace.ss")
|
||||
(lib "plt-match.ss")
|
||||
|
|
|
|||
|
|
@ -1,34 +1,34 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "planet-requires.ss" "rep-utils.ss" "effect-rep.ss" "tc-utils.ss"
|
||||
(require "planet-requires.ss" "rep-utils.ss" "effect-rep.ss" "tc-utils.ss"
|
||||
"free-variance.ss"
|
||||
mzlib/trace scheme/match
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(define name-table (make-weak-hasheq))
|
||||
(define name-table (make-weak-hasheq))
|
||||
|
||||
;; Name = Symbol
|
||||
;; Name = Symbol
|
||||
|
||||
;; Type is defined in rep-utils.ss
|
||||
;; Type is defined in rep-utils.ss
|
||||
|
||||
;; t must be a Type
|
||||
(dt Scope (t))
|
||||
;; t must be a Type
|
||||
(dt Scope (t))
|
||||
|
||||
;; i is an nat
|
||||
(dt B (i)
|
||||
;; i is an nat
|
||||
(dt B (i)
|
||||
[#:frees empty-hash-table (make-immutable-hasheq (list (cons i Covariant)))]
|
||||
[#:fold-rhs #:base])
|
||||
|
||||
;; n is a Name
|
||||
(dt F (n) [#:frees (make-immutable-hasheq (list (cons n Covariant))) empty-hash-table] [#:fold-rhs #:base])
|
||||
;; n is a Name
|
||||
(dt F (n) [#:frees (make-immutable-hasheq (list (cons n Covariant))) empty-hash-table] [#:fold-rhs #:base])
|
||||
|
||||
;; id is an Identifier
|
||||
(dt Name (id) [#:intern (hash-id id)] [#:frees #f] [#:fold-rhs #:base])
|
||||
;; id is an Identifier
|
||||
(dt Name (id) [#:intern (hash-id id)] [#:frees #f] [#:fold-rhs #:base])
|
||||
|
||||
;; rator is a type
|
||||
;; rands is a list of types
|
||||
;; stx is the syntax of the pair of parens
|
||||
(dt App (rator rands stx)
|
||||
;; rator is a type
|
||||
;; rands is a list of types
|
||||
;; stx is the syntax of the pair of parens
|
||||
(dt App (rator rands stx)
|
||||
[#:intern (list rator rands)]
|
||||
[#:frees (combine-frees (map free-vars* (cons rator rands)))
|
||||
(combine-frees (map free-idxs* (cons rator rands)))]
|
||||
|
|
@ -36,49 +36,49 @@
|
|||
(map type-rec-id rands)
|
||||
stx)])
|
||||
|
||||
;; left and right are Types
|
||||
(dt Pair (left right))
|
||||
;; left and right are Types
|
||||
(dt Pair (left right))
|
||||
|
||||
;; elem is a Type
|
||||
(dt Vector (elem) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))])
|
||||
;; elem is a Type
|
||||
(dt Vector (elem) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))])
|
||||
|
||||
;; elem is a Type
|
||||
(dt Box (elem) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))])
|
||||
;; elem is a Type
|
||||
(dt Box (elem) [#:frees (make-invariant (free-vars* elem)) (make-invariant (free-idxs* elem))])
|
||||
|
||||
;; name is a Symbol (not a Name)
|
||||
(dt Base (name) [#:frees #f] [#:fold-rhs #:base])
|
||||
;; name is a Symbol (not a Name)
|
||||
(dt Base (name) [#:frees #f] [#:fold-rhs #:base])
|
||||
|
||||
;; body is a Scope
|
||||
(dt Mu (body) #:no-provide [#:frees (free-vars* body) (without-below 1 (free-idxs* body))]
|
||||
;; body is a Scope
|
||||
(dt Mu (body) #:no-provide [#:frees (free-vars* body) (without-below 1 (free-idxs* body))]
|
||||
[#:fold-rhs (*Mu (*Scope (type-rec-id (Scope-t body))))])
|
||||
|
||||
;; n is how many variables are bound here
|
||||
;; body is a Scope
|
||||
(dt Poly (n body) #:no-provide
|
||||
;; n is how many variables are bound here
|
||||
;; body is a Scope
|
||||
(dt Poly (n body) #:no-provide
|
||||
[#:frees (free-vars* body) (without-below n (free-idxs* body))]
|
||||
[#:fold-rhs (let ([body* (remove-scopes n body)])
|
||||
(*Poly n (add-scopes n (type-rec-id body*))))])
|
||||
|
||||
;; n is how many variables are bound here
|
||||
;; there are n-1 'normal' vars and 1 ... var
|
||||
;; body is a Scope
|
||||
(dt PolyDots (n body) #:no-provide
|
||||
;; n is how many variables are bound here
|
||||
;; there are n-1 'normal' vars and 1 ... var
|
||||
;; body is a Scope
|
||||
(dt PolyDots (n body) #:no-provide
|
||||
[#:frees (free-vars* body) (without-below n (free-idxs* body))]
|
||||
[#:fold-rhs (let ([body* (remove-scopes n body)])
|
||||
(*PolyDots n (add-scopes n (type-rec-id body*))))])
|
||||
|
||||
;; pred : identifier
|
||||
;; cert : syntax certifier
|
||||
(dt Opaque (pred cert) [#:intern (hash-id pred)] [#:frees #f] [#:fold-rhs #:base])
|
||||
;; pred : identifier
|
||||
;; cert : syntax certifier
|
||||
(dt Opaque (pred cert) [#:intern (hash-id pred)] [#:frees #f] [#:fold-rhs #:base])
|
||||
|
||||
;; name : symbol
|
||||
;; parent : Struct
|
||||
;; flds : Listof[Type]
|
||||
;; proc : Function Type
|
||||
;; poly? : is this a polymorphic type?
|
||||
;; pred-id : identifier for the predicate of the struct
|
||||
;; cert : syntax certifier for pred-id
|
||||
(dt Struct (name parent flds proc poly? pred-id cert)
|
||||
;; name : symbol
|
||||
;; parent : Struct
|
||||
;; flds : Listof[Type]
|
||||
;; proc : Function Type
|
||||
;; poly? : is this a polymorphic type?
|
||||
;; pred-id : identifier for the predicate of the struct
|
||||
;; cert : syntax certifier for pred-id
|
||||
(dt Struct (name parent flds proc poly? pred-id cert)
|
||||
[#:intern (list name parent flds proc)]
|
||||
[#:frees (combine-frees (map free-vars* (append (if proc (list proc) null) (if parent (list parent) null) flds)))
|
||||
(combine-frees (map free-idxs* (append (if proc (list proc) null) (if parent (list parent) null) flds)))]
|
||||
|
|
@ -90,15 +90,15 @@
|
|||
pred-id
|
||||
cert)])
|
||||
|
||||
;; dom : Listof[Type]
|
||||
;; rng : Type
|
||||
;; rest : Option[Type]
|
||||
;; drest : Option[Cons[Type,Name or nat]]
|
||||
;; rest and drest NOT both true
|
||||
;; thn-eff : Effect
|
||||
;; els-eff : Effect
|
||||
;; arr is NOT a Type
|
||||
(dt arr (dom rng rest drest thn-eff els-eff)
|
||||
;; dom : Listof[Type]
|
||||
;; rng : Type
|
||||
;; rest : Option[Type]
|
||||
;; drest : Option[Cons[Type,Name or nat]]
|
||||
;; rest and drest NOT both true
|
||||
;; thn-eff : Effect
|
||||
;; els-eff : Effect
|
||||
;; arr is NOT a Type
|
||||
(dt arr (dom rng rest drest thn-eff els-eff)
|
||||
[#:frees (combine-frees (append (map flip-variances (map free-vars* (append (if rest (list rest) null) dom)))
|
||||
(match drest
|
||||
[(cons t (? symbol? bnd))
|
||||
|
|
@ -126,45 +126,45 @@
|
|||
(map effect-rec-id thn-eff)
|
||||
(map effect-rec-id els-eff))])
|
||||
|
||||
;; top-arr is the supertype of all function types
|
||||
(dt top-arr ()
|
||||
;; top-arr is the supertype of all function types
|
||||
(dt top-arr ()
|
||||
[#:frees #f] [#:fold-rhs #:base])
|
||||
|
||||
;; arities : Listof[arr]
|
||||
(dt Function (arities) [#:frees (combine-frees (map free-vars* arities))
|
||||
;; arities : Listof[arr]
|
||||
(dt Function (arities) [#:frees (combine-frees (map free-vars* arities))
|
||||
(combine-frees (map free-idxs* arities))]
|
||||
[#:fold-rhs (*Function (map type-rec-id arities))])
|
||||
|
||||
;; v : Scheme Value
|
||||
(dt Value (v) [#:frees #f] [#:fold-rhs #:base])
|
||||
;; v : Scheme Value
|
||||
(dt Value (v) [#:frees #f] [#:fold-rhs #:base])
|
||||
|
||||
;; elems : Listof[Type]
|
||||
(dt Union (elems) [#:frees (combine-frees (map free-vars* elems))
|
||||
;; elems : Listof[Type]
|
||||
(dt Union (elems) [#:frees (combine-frees (map free-vars* elems))
|
||||
(combine-frees (map free-idxs* elems))]
|
||||
[#:fold-rhs ((unbox union-maker) (map type-rec-id elems))])
|
||||
|
||||
(dt Univ () [#:frees #f] [#:fold-rhs #:base])
|
||||
(dt Univ () [#:frees #f] [#:fold-rhs #:base])
|
||||
|
||||
;; types : Listof[Type]
|
||||
(dt Values (types) [#:frees (combine-frees (map free-vars* types))
|
||||
;; types : Listof[Type]
|
||||
(dt Values (types) [#:frees (combine-frees (map free-vars* types))
|
||||
(combine-frees (map free-idxs* types))]
|
||||
[#:fold-rhs (*Values (map type-rec-id types))])
|
||||
|
||||
;; in : Type
|
||||
;; out : Type
|
||||
(dt Param (in out))
|
||||
;; in : Type
|
||||
;; out : Type
|
||||
(dt Param (in out))
|
||||
|
||||
;; key : Type
|
||||
;; value : Type
|
||||
(dt Hashtable (key value))
|
||||
;; key : Type
|
||||
;; value : Type
|
||||
(dt Hashtable (key value))
|
||||
|
||||
;; t : Type
|
||||
(dt Syntax (t))
|
||||
;; t : Type
|
||||
(dt Syntax (t))
|
||||
|
||||
;; pos-flds : (Listof Type)
|
||||
;; name-flds : (Listof (Tuple Symbol Type Boolean))
|
||||
;; methods : (Listof (Tuple Symbol Function))
|
||||
(dt Class (pos-flds name-flds methods)
|
||||
;; pos-flds : (Listof Type)
|
||||
;; name-flds : (Listof (Tuple Symbol Type Boolean))
|
||||
;; methods : (Listof (Tuple Symbol Function))
|
||||
(dt Class (pos-flds name-flds methods)
|
||||
[#:frees (combine-frees
|
||||
(map free-vars* (append pos-flds
|
||||
(map cadr name-flds)
|
||||
|
|
@ -186,30 +186,30 @@
|
|||
(map type-rec-id init-tys))
|
||||
(map list mname (map type-rec-id mty)))])])
|
||||
|
||||
;; cls : Class
|
||||
(dt Instance (cls))
|
||||
;; cls : Class
|
||||
(dt Instance (cls))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Ugly hack - should use units
|
||||
;; Ugly hack - should use units
|
||||
|
||||
(define union-maker (box #f))
|
||||
(define union-maker (box #f))
|
||||
|
||||
(define (set-union-maker! v) (set-box! union-maker v))
|
||||
(define (set-union-maker! v) (set-box! union-maker v))
|
||||
|
||||
(provide set-union-maker!)
|
||||
(provide set-union-maker!)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; remove-dups: List[Type] -> List[Type]
|
||||
;; removes duplicate types from a SORTED list
|
||||
(define (remove-dups types)
|
||||
;; remove-dups: List[Type] -> List[Type]
|
||||
;; removes duplicate types from a SORTED list
|
||||
(define (remove-dups types)
|
||||
(cond [(null? types) types]
|
||||
[(null? (cdr types)) types]
|
||||
[(type-equal? (car types) (cadr types)) (remove-dups (cdr types))]
|
||||
[else (cons (car types) (remove-dups (cdr types)))]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; type/effect fold
|
||||
|
||||
|
|
@ -261,27 +261,27 @@
|
|||
|
||||
(provide type-case effect-case)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
;; sub-eff : (Type -> Type) Eff -> Eff
|
||||
(define (sub-eff sb eff)
|
||||
;; sub-eff : (Type -> Type) Eff -> Eff
|
||||
(define (sub-eff sb eff)
|
||||
(effect-case sb eff))
|
||||
|
||||
(define (add-scopes n t)
|
||||
(define (add-scopes n t)
|
||||
(if (zero? n) t
|
||||
(add-scopes (sub1 n) (*Scope t))))
|
||||
|
||||
(define (remove-scopes n sc)
|
||||
(define (remove-scopes n sc)
|
||||
(if (zero? n)
|
||||
sc
|
||||
(match sc
|
||||
[(Scope: sc*) (remove-scopes (sub1 n) sc*)]
|
||||
[_ (int-err "Tried to remove too many scopes: ~a" sc)])))
|
||||
|
||||
;; abstract-many : Names Type -> Scope^n
|
||||
;; where n is the length of names
|
||||
(define (abstract-many names ty)
|
||||
;; abstract-many : Names Type -> Scope^n
|
||||
;; where n is the length of names
|
||||
(define (abstract-many names ty)
|
||||
(define (nameTo name count type)
|
||||
(let loop ([outer 0] [ty type])
|
||||
(define (sb t) (loop outer t))
|
||||
|
|
@ -290,6 +290,17 @@
|
|||
[#:F name* (if (eq? name name*) (*B (+ count outer)) ty)]
|
||||
;; necessary to avoid infinite loops
|
||||
[#:Union elems (*Union (remove-dups (sort (map sb elems) type<?)))]
|
||||
;; functions
|
||||
[#:arr dom rng rest drest thn-eff els-eff
|
||||
(*arr (map sb dom)
|
||||
(sb rng)
|
||||
(if rest (sb rest) #f)
|
||||
(if drest
|
||||
(cons (sb (car drest))
|
||||
(if (eq? (cdr drest) name) (+ count outer) (cdr drest)))
|
||||
#f)
|
||||
(map (lambda (e) (sub-eff sb e)) thn-eff)
|
||||
(map (lambda (e) (sub-eff sb e)) els-eff))]
|
||||
[#:Mu (Scope: body) (*Mu (*Scope (loop (add1 outer) body)))]
|
||||
[#:PolyDots n body*
|
||||
(let ([body (remove-scopes n body*)])
|
||||
|
|
@ -305,9 +316,10 @@
|
|||
(cdr names)
|
||||
(sub1 count))))))
|
||||
|
||||
;; instantiate-many : List[Type] Scope^n -> Type
|
||||
;; where n is the length of types
|
||||
(define (instantiate-many images sc)
|
||||
;; instantiate-many : List[Type] Scope^n -> Type
|
||||
;; where n is the length of types
|
||||
;; all of the types MUST be Fs
|
||||
(define (instantiate-many images sc)
|
||||
(define (replace image count type)
|
||||
(let loop ([outer 0] [ty type])
|
||||
(define (sb t) (loop outer t))
|
||||
|
|
@ -318,6 +330,17 @@
|
|||
ty)]
|
||||
;; necessary to avoid infinite loops
|
||||
[#:Union elems (*Union (remove-dups (sort (map sb elems) type<?)))]
|
||||
;; functions
|
||||
[#:arr dom rng rest drest thn-eff els-eff
|
||||
(*arr (map sb dom)
|
||||
(sb rng)
|
||||
(if rest (sb rest) #f)
|
||||
(if drest
|
||||
(cons (sb (car drest))
|
||||
(if (= (cdr drest) (+ count outer)) (F-n image) (cdr drest)))
|
||||
#f)
|
||||
(map (lambda (e) (sub-eff sb e)) thn-eff)
|
||||
(map (lambda (e) (sub-eff sb e)) els-eff))]
|
||||
[#:Mu (Scope: body) (*Mu (*Scope (loop (add1 outer) body)))]
|
||||
[#:PolyDots n body*
|
||||
(let ([body (remove-scopes n body*)])
|
||||
|
|
@ -333,74 +356,74 @@
|
|||
(cdr images)
|
||||
(sub1 count))))))
|
||||
|
||||
(define (abstract name ty)
|
||||
(define (abstract name ty)
|
||||
(abstract-many (list name) ty))
|
||||
|
||||
(define (instantiate type sc)
|
||||
(define (instantiate type sc)
|
||||
(instantiate-many (list type) sc))
|
||||
|
||||
#;(trace instantiate-many abstract-many)
|
||||
#;(trace instantiate-many abstract-many)
|
||||
|
||||
;; the 'smart' constructor
|
||||
(define (Mu* name body)
|
||||
;; the 'smart' constructor
|
||||
(define (Mu* name body)
|
||||
(let ([v (*Mu (abstract name body))])
|
||||
(hash-set! name-table v name)
|
||||
v))
|
||||
|
||||
;; the 'smart' destructor
|
||||
(define (Mu-body* name t)
|
||||
;; the 'smart' destructor
|
||||
(define (Mu-body* name t)
|
||||
(match t
|
||||
[(Mu: scope)
|
||||
(instantiate (*F name) scope)]))
|
||||
|
||||
;; the 'smart' constructor
|
||||
(define (Poly* names body)
|
||||
;; the 'smart' constructor
|
||||
(define (Poly* names body)
|
||||
(if (null? names) body
|
||||
(let ([v (*Poly (length names) (abstract-many names body))])
|
||||
(hash-set! name-table v names)
|
||||
v)))
|
||||
|
||||
;; the 'smart' destructor
|
||||
(define (Poly-body* names t)
|
||||
;; the 'smart' destructor
|
||||
(define (Poly-body* names t)
|
||||
(match t
|
||||
[(Poly: n scope)
|
||||
(unless (= (length names) n)
|
||||
(error "Wrong number of names"))
|
||||
(instantiate-many (map *F names) scope)]))
|
||||
|
||||
;; the 'smart' constructor
|
||||
(define (PolyDots* names body)
|
||||
;; the 'smart' constructor
|
||||
(define (PolyDots* names body)
|
||||
(if (null? names) body
|
||||
(let ([v (*PolyDots (length names) (abstract-many names body))])
|
||||
(hash-set! name-table v names)
|
||||
v)))
|
||||
|
||||
;; the 'smart' destructor
|
||||
(define (PolyDots-body* names t)
|
||||
;; the 'smart' destructor
|
||||
(define (PolyDots-body* names t)
|
||||
(match t
|
||||
[(PolyDots: n scope)
|
||||
(unless (= (length names) n)
|
||||
(error "Wrong number of names"))
|
||||
(instantiate-many (map *F names) scope)]))
|
||||
|
||||
(print-struct #t)
|
||||
(print-struct #t)
|
||||
|
||||
(define-match-expander Mu-unsafe:
|
||||
(define-match-expander Mu-unsafe:
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ bp) #'(? Mu? (app (lambda (t) (Scope-t (Mu-body t))) bp))])))
|
||||
|
||||
(define-match-expander Poly-unsafe:
|
||||
(define-match-expander Poly-unsafe:
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ n bp) #'(? Poly? (app (lambda (t) (list (Poly-n t) (Poly-body t))) (list n bp)))])))
|
||||
|
||||
(define-match-expander PolyDots-unsafe:
|
||||
(define-match-expander PolyDots-unsafe:
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ n bp) #'(? PolyDots? (app (lambda (t) (list (PolyDots-n t) (PolyDots-body t))) (list n bp)))])))
|
||||
|
||||
(define-match-expander Mu:*
|
||||
(define-match-expander Mu:*
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ np bp)
|
||||
|
|
@ -409,7 +432,7 @@
|
|||
(list sym (Mu-body* sym t))))
|
||||
(list np bp)))])))
|
||||
|
||||
(define-match-expander Mu-name:
|
||||
(define-match-expander Mu-name:
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ np bp)
|
||||
|
|
@ -418,9 +441,9 @@
|
|||
(list sym (Mu-body* sym t))))
|
||||
(list np bp)))])))
|
||||
|
||||
;; This match expander wraps the smart constructor
|
||||
;; names are generated with gensym
|
||||
(define-match-expander Poly:*
|
||||
;; This match expander wraps the smart constructor
|
||||
;; names are generated with gensym
|
||||
(define-match-expander Poly:*
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ nps bp)
|
||||
|
|
@ -431,8 +454,8 @@
|
|||
(list syms (Poly-body* syms t))))
|
||||
(list nps bp)))])))
|
||||
|
||||
;; This match expander uses the names from the hashtable
|
||||
(define-match-expander Poly-names:
|
||||
;; This match expander uses the names from the hashtable
|
||||
(define-match-expander Poly-names:
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ nps bp)
|
||||
|
|
@ -443,9 +466,9 @@
|
|||
(list syms (Poly-body* syms t))))
|
||||
(list nps bp)))])))
|
||||
|
||||
;; This match expander wraps the smart constructor
|
||||
;; names are generated with gensym
|
||||
(define-match-expander PolyDots:*
|
||||
;; This match expander wraps the smart constructor
|
||||
;; names are generated with gensym
|
||||
(define-match-expander PolyDots:*
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ nps bp)
|
||||
|
|
@ -456,8 +479,8 @@
|
|||
(list syms (PolyDots-body* syms t))))
|
||||
(list nps bp)))])))
|
||||
|
||||
;; This match expander uses the names from the hashtable
|
||||
(define-match-expander PolyDots-names:
|
||||
;; This match expander uses the names from the hashtable
|
||||
(define-match-expander PolyDots-names:
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ nps bp)
|
||||
|
|
@ -468,30 +491,22 @@
|
|||
(list syms (PolyDots-body* syms t))))
|
||||
(list nps bp)))])))
|
||||
|
||||
;; unfold : Type -> Type
|
||||
;; must be applied to a Mu
|
||||
(define (unfold t)
|
||||
(match t
|
||||
[(Mu: sc) (instantiate t sc)]
|
||||
[_ (int-err "unfold: requires Mu type, got ~a" t)]))
|
||||
;; type equality
|
||||
(define type-equal? eq?)
|
||||
|
||||
;; type equality
|
||||
(define type-equal? eq?)
|
||||
;; inequality - good
|
||||
|
||||
;; inequality - good
|
||||
|
||||
(define (type<? s t)
|
||||
(define (type<? s t)
|
||||
(< (Type-seq s) (Type-seq t)))
|
||||
|
||||
(define (type-compare s t)
|
||||
(define (type-compare s t)
|
||||
(cond [(eq? s t) 0]
|
||||
[(type<? s t) 1]
|
||||
[else -1]))
|
||||
|
||||
;(trace subst subst-all)
|
||||
;(trace subst subst-all)
|
||||
|
||||
(provide
|
||||
unfold
|
||||
(provide
|
||||
Mu-name: Poly-names:
|
||||
PolyDots-names:
|
||||
Type-seq Effect-seq
|
||||
|
|
@ -514,5 +529,5 @@
|
|||
[Poly-body* Poly-body]
|
||||
[PolyDots-body* PolyDots-body]))
|
||||
|
||||
;(trace unfold)
|
||||
;(trace unfold)
|
||||
|
||||
|
|
|
|||
|
|
@ -17,7 +17,8 @@
|
|||
tc-result:
|
||||
tc-result-equal?
|
||||
effects-equal?
|
||||
tc-result-t)
|
||||
tc-result-t
|
||||
unfold)
|
||||
|
||||
|
||||
;; substitute : Type Name Type -> Type
|
||||
|
|
@ -35,7 +36,12 @@
|
|||
(foldr (lambda (e acc) (substitute (cadr e) (car e) acc)) t s))
|
||||
|
||||
|
||||
|
||||
;; unfold : Type -> Type
|
||||
;; must be applied to a Mu
|
||||
(define (unfold t)
|
||||
(match t
|
||||
[(Mu: name b) (substitute t name b)]
|
||||
[_ (int-err "unfold: requires Mu type, got ~a" t)]))
|
||||
|
||||
(define (instantiate-poly t types)
|
||||
(match t
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user