From bfcd2732251a8321665ce2d2b8ebd8ff6e76e6ee Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Mon, 3 Sep 2012 01:11:28 -0700 Subject: [PATCH] Made free-variance have less special cases. original commit: cf4d43c04f031dd1f0ac9811e19755707d1d9c42 --- collects/typed-racket/rep/free-variance.rkt | 187 +++++++++--------- collects/typed-racket/rep/type-rep.rkt | 3 +- .../typed-racket/typecheck/tc-app-helper.rkt | 7 +- .../typecheck/tc-app/tc-app-keywords.rkt | 3 +- collects/typed-racket/types/substitute.rkt | 7 +- collects/typed-racket/types/utils.rkt | 11 +- 6 files changed, 113 insertions(+), 105 deletions(-) diff --git a/collects/typed-racket/rep/free-variance.rkt b/collects/typed-racket/rep/free-variance.rkt index e9368a84..8ded52ed 100644 --- a/collects/typed-racket/rep/free-variance.rkt +++ b/collects/typed-racket/rep/free-variance.rkt @@ -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) diff --git a/collects/typed-racket/rep/type-rep.rkt b/collects/typed-racket/rep/type-rep.rkt index 5e2a55f8..3a226538 100644 --- a/collects/typed-racket/rep/type-rep.rkt +++ b/collects/typed-racket/rep/type-rep.rkt @@ -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) diff --git a/collects/typed-racket/typecheck/tc-app-helper.rkt b/collects/typed-racket/typecheck/tc-app-helper.rkt index 5ff5efcb..bb3eca8e 100644 --- a/collects/typed-racket/typecheck/tc-app-helper.rkt +++ b/collects/typed-racket/typecheck/tc-app-helper.rkt @@ -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") ""))))))])) diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-keywords.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-keywords.rkt index 77228bce..ef35e321 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-keywords.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-keywords.rkt @@ -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) ...) diff --git a/collects/typed-racket/types/substitute.rkt b/collects/typed-racket/types/substitute.rkt index 5799793d..0f642e71 100644 --- a/collects/typed-racket/types/substitute.rkt +++ b/collects/typed-racket/types/substitute.rkt @@ -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 diff --git a/collects/typed-racket/types/utils.rkt b/collects/typed-racket/types/utils.rkt index fefd100d..007583ff 100644 --- a/collects/typed-racket/types/utils.rkt +++ b/collects/typed-racket/types/utils.rkt @@ -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?))]