suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Made free-variance have less special cases.

Browse Source 
original commit: cf4d43c04f031dd1f0ac9811e19755707d1d9c42
This commit is contained in:
Eric Dobson 2012-09-03 01:11:28 -07:00 committed by Sam Tobin-Hochstadt
parent 6fcac4b7ae
commit bfcd273225
6 changed files with 113 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

187
collects/typed-racket/rep/free-variance.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require "../utils/utils.rkt"
racket/match
racket/set
(for-syntax racket/base)
unstable/lazy-require
(contract-req))
@ -9,22 +10,28 @@
(lazy-require
("../env/type-name-env.rkt" (lookup-type-variance)))
(provide Covariant Contravariant Invariant Constant Dotted
combine-frees flip-variances without-below
fix-bound make-invariant make-constant variance?
instantiate-frees
empty-free-vars
single-free-var
free-vars-remove
free-vars-hash
free-vars-has-key?
variance->binding
(struct-out named-poly-variance))
(provide
;; Variances
Covariant Contravariant Invariant Constant Dotted
variance? variance->binding
;; Construcing frees
combine-frees flip-variances
make-invariant make-constant
instantiate-frees
empty-free-vars
single-free-var
free-vars-remove
;; Examining frees
free-vars-hash
free-vars-names
free-vars-has-key?)
;; this file contains support for calculating the free variables/indexes of types
;; actual computation is done in rep-utils.rkt and type-rep.rkt
(define-values (Covariant Contravariant Invariant Constant Dotted)
(define-values (variance? Covariant Contravariant Invariant Constant Dotted)
(let ()
(define-struct Variance () #:transparent)
(define-struct (Covariant Variance) () #:transparent)
@ -33,7 +40,7 @@
(define-struct (Constant Variance) () #:transparent)
;; not really a variance, but is disjoint with the others
(define-struct (Dotted Variance) () #:transparent)
(values (make-Covariant) (make-Contravariant) (make-Invariant) (make-Constant) (make-Dotted))))
(values Variance? (make-Covariant) (make-Contravariant) (make-Invariant) (make-Constant) (make-Dotted))))
(define (variance->binding var)
(match var
@ -43,110 +50,106 @@
((== Constant) #'Constant)
((== Dotted) #'Dotted)))
(define (variance? e)
(memq e (list Covariant Contravariant Invariant Constant Dotted)))
(define (flip-variance v)
(match v
((== Covariant) Contravariant)
((== Contravariant) Covariant)
(else v)))
;; Represents how a struct varies
(struct named-poly-variance (name) #:transparent)
(struct frees () #:transparent)
(struct empty-frees frees () #:transparent)
(struct single-frees frees (name bound) #:transparent)
(struct app-frees frees (variance args) #:transparent)
(struct combined-frees frees (inner) #:transparent)
(struct remove-frees frees (inner name) #:transparent)
(struct without-below-frees frees (inner bound) #:transparent)
(struct update-frees frees (inner name value) #:transparent)
(struct update-all-frees frees (inner value) #:transparent)
(struct flip-variance-frees frees (inner) #:transparent)
;;All of these are used internally
;;Only combined-frees is used externally
(struct combined-frees (table computed) #:transparent)
(struct app-frees (name args) #:transparent)
(struct remove-frees (inner name) #:transparent)
;; given a set of free variables, change bound to ...
;; (if bound wasn't free, this will add it as Dotted
;; appropriately so that things that expect to see
;; it as "free" will -- fixes the case where the
;; dotted pre-type base doesn't use the bound).
(define (fix-bound vs bound)
(update-frees vs bound Dotted))
;; frees -> frees
(define (flip-variances vs)
(flip-variance-frees vs))
(define (make-invariant vs)
(update-all-frees vs Invariant))
(define (make-constant vs)
(update-all-frees vs Constant))
(define (combine-frees frees)
(combined-frees frees))
(define (instantiate-frees variance frees)
(app-frees variance frees))
(define (without-below n frees)
(without-below-frees frees n))
;; Base constructors
(define (single-free-var name (variance Covariant))
(single-frees name variance))
(combined-frees (hasheq name variance) null))
(define empty-free-vars
(empty-frees))
(combined-frees (hasheq) null))
(define (free-vars-remove vars name)
(remove-frees vars name))
;; Computed constructor
(define (instantiate-frees name frees)
(combined-frees (hasheq) (list (app-frees name frees))))
;; frees -> frees
(define (flip-variances frees)
(match frees
((combined-frees hash computed)
(combined-frees
(for/hasheq (((k v) hash))
(values k (flip-variance v)))
(map flip-variances computed)))
((app-frees name args)
(app-frees name (map flip-variances args)))
((remove-frees inner name)
(remove-frees (flip-variances inner) name))))
(define (make-invariant frees)
(combined-frees
(for/hasheq ((name (free-vars-names frees)))
(values name Invariant))
null))
(define (make-constant frees)
(combined-frees
(for/hasheq ((name (free-vars-names frees)))
(values name Constant))
null))
;; Listof[frees] -> frees
(define (combine-frees freess)
(define-values (hash computed)
(for/fold ((hash (hasheq)) (computed null))
((frees freess))
(match frees
((combined-frees new-hash new-computed)
(values (combine-hashes (list hash new-hash))
(append new-computed computed))))))
(combined-frees hash computed))
(define (free-vars-remove frees name)
(match frees
((combined-frees hash computed)
(combined-frees (hash-remove hash name)
(map (λ (v) (remove-frees v name)) computed)))))
;;
(define (free-vars-names vars)
(match vars
((combined-frees hash computed)
(apply set-union
(list->seteq (hash-keys hash))
(map free-vars-names computed)))
((remove-frees inner name) (set-remove (free-vars-names inner) name))
((app-frees name args)
(apply set-union (map free-vars-names args)))))
(define (free-vars-has-key? vars key)
(hash-has-key? (free-vars-hash vars) key))
(set-member? (free-vars-names vars) key))
;; Only valid after full type resolution
(define (free-vars-hash vars)
(match vars
((empty-frees) (hasheq))
((single-frees name bound) (hasheq name bound))
((combined-frees inner) (combine-hashes (map free-vars-hash inner)))
((combined-frees hash computed)
(combine-hashes (cons hash (map free-vars-hash computed))))
((remove-frees inner name) (hash-remove (free-vars-hash inner) name))
((without-below-frees inner bound) (without-below-hash (free-vars-hash inner) bound))
((update-frees inner name value) (hash-set (free-vars-hash inner) name value))
((update-all-frees inner value)
(set-variance-hash (free-vars-hash inner) value))
((app-frees (named-poly-variance name) args)
((app-frees name args)
(combine-hashes
(for/list ((var (lookup-type-variance name)) (arg args))
(define hash (free-vars-hash arg))
(free-vars-hash
(cond
((eq? var Covariant) hash)
((eq? var Contravariant) (flip-variance-hash hash))
((eq? var Invariant) (set-variance-hash hash Invariant))
((eq? var Constant) (set-variance-hash hash Constant))))))
((flip-variance-frees inner)
(flip-variance-hash (free-vars-hash inner)))))
((eq? var Covariant) arg)
((eq? var Contravariant) (flip-variances arg))
((eq? var Invariant) (make-invariant arg))
((eq? var Constant) (make-constant arg)))))))))
(define (flip-variance-hash hash)
(for/hasheq (((k v) hash))
(values k (flip-variance v))))
(define (set-variance-hash hash value)
(for/hasheq (((k v) hash))
(values k value)))
(define (without-below-hash frees n)
(for/hasheq ([(k v) (in-hash frees)]
#:when (>= k n))
(values k v)))
;; frees = HT[Idx,Variance] where Idx is either Symbol or Number
;; (listof frees) -> frees
(define (combine-hashes hashes)

3
collects/typed-racket/rep/type-rep.rkt
View File

@ -68,8 +68,7 @@
[#:frees (λ (f)
(match rator
((Name: n)
(instantiate-frees (named-poly-variance n)
(map f rands)))
(instantiate-frees n (map f rands)))
(else (f (resolve-app rator rands stx)))))]
[#:fold-rhs (*App (type-rec-id rator)

7
collects/typed-racket/typecheck/tc-app-helper.rkt
View File

@ -2,6 +2,7 @@
(require "../utils/utils.rkt" racket/match unstable/list unstable/sequence
syntax/parse
racket/set
(only-in srfi/1 unzip4) (only-in racket/list make-list)
(prefix-in c: racket/contract)
"check-below.rkt" "tc-subst.rkt"
@ -311,7 +312,8 @@
(string-append
"Polymorphic " fcn-string " could not be applied to arguments:\n"
dom
(if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars)))
(if (not (subset? (apply set-union (seteq) (map fv/list msg-doms))
(list->seteq msg-vars)))
(string-append "Type Variables: " (stringify msg-vars) "\n")
""))))))]
[(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests kws) ...)))
@ -333,7 +335,8 @@
(string-append
"Polymorphic " fcn-string " could not be applied to arguments:\n"
dom
(if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars)))
(if (not (subset? (apply set-union (seteq) (map fv/list msg-doms))
(list->seteq msg-vars)))
(string-append "Type Variables: " (stringify msg-vars) "\n")
""))))))]))

3
collects/typed-racket/typecheck/tc-app/tc-app-keywords.rkt
View File

@ -5,6 +5,7 @@
"signatures.rkt"
"utils.rkt"
syntax/parse racket/match
racket/set
syntax/parse/experimental/reflect
(typecheck signatures tc-app-helper tc-funapp tc-metafunctions)
(types abbrev utils union substitute subtype)
@ -33,7 +34,7 @@
(Poly: vars
(Function: (list (and ar (arr: dom rng (and rest #f) (and drest #f) kw-formals))))))
(=> fail)
(unless (null? (fv/list kw-formals))
(unless (set-empty? (fv/list kw-formals))
(fail))
(match (map single-value (syntax->list #'pos-args))
[(list (tc-result1: argtys-t) ...)

7
collects/typed-racket/types/substitute.rkt
View File

@ -6,6 +6,7 @@
(rep free-variance)
(env index-env tvar-env)
racket/match
racket/set
racket/contract
unstable/lazy-require)
(lazy-require ("union.rkt" (Un)))
@ -81,8 +82,8 @@
(define/cond-contract (substitute-dots images rimage name target)
((listof Type/c) (or/c #f Type/c) symbol? Type? . -> . Type?)
(define (sb t) (substitute-dots images rimage name t))
(if (or (hash-ref (free-vars-hash (free-idxs* target)) name #f)
(hash-ref (free-vars-hash (free-vars* target)) name #f))
(if (or (set-member? (free-vars-names (free-idxs* target)) name)
(set-member? (free-vars-names (free-vars* target)) name))
(type-case (#:Type sb #:Filter (sub-f sb)) target
[#:ListDots dty dbound
(if (eq? name dbound)
@ -128,7 +129,7 @@
;; substitute-dotted : Type Name Name Type -> Type
(define (substitute-dotted image image-bound name target)
(define (sb t) (substitute-dotted image image-bound name t))
(if (hash-ref (free-vars-hash (free-idxs* target)) name #f)
(if (set-member? (free-vars-names (free-idxs* target)) name)
(type-case (#:Type sb #:Filter (sub-f sb))
target
[#:ValuesDots types dty dbound

11
collects/typed-racket/types/utils.rkt
View File

@ -7,6 +7,7 @@
(rep free-variance)
(env index-env tvar-env)
racket/match
racket/set
racket/list
(contract-req)
"tc-error.rkt")
@ -60,12 +61,12 @@
;; fv : Type -> Listof[Symbol]
(define (fv t) (hash-map (free-vars-hash (free-vars* t)) (lambda (k v) k)))
(define (fi t) (for/list ([(k v) (in-hash (free-vars-hash (free-idxs* t)))]) k))
(define (fv t) (set->list (free-vars-names (free-vars* t))))
(define (fi t) (set->list (free-vars-names (free-idxs* t))))
;; fv/list : Listof[Type] -> Listof[Symbol]
;; fv/list : Listof[Type] -> Setof[Symbol]
(define (fv/list ts)
(hash-map (free-vars-hash (combine-frees (map free-vars* ts))) (lambda (k v) k)))
(apply set-union (seteq) (map (compose free-vars-names free-vars*) ts)))
;; a parameter for the current polymorphic structure being defined
;; to allow us to prevent non-regular datatypes
@ -90,7 +91,7 @@
. ->* . any/c)]
[fv (Rep? . -> . (listof symbol?))]
[fi (Rep? . -> . (listof symbol?))]
[fv/list ((listof Type/c) . -> . (listof symbol?))]
[fv/list ((listof Type/c) . -> . (set/c symbol?))]
[lookup-fail (identifier? . -> . Type/c)]
[lookup-type-fail (identifier? . -> . Type/c)]
[current-poly-struct (parameter/c (or/c #f poly?))]