Made free-variance have less special cases.

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,109 +50,105 @@
    ((== 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)
-
-
-;; 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))
+;;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)
 
-(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))
+
+;; Computed constructor
+(define (instantiate-frees name frees)
+  (combined-frees (hasheq) (list (app-frees name frees))))
 
-(define (free-vars-remove vars name)
-  (remove-frees vars name))
 
+;; 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)))))
-
-
-(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)))
-
+          ((eq? var Covariant) arg)
+          ((eq? var Contravariant) (flip-variances arg))
+          ((eq? var Invariant) (make-invariant arg))
+          ((eq? var Constant) (make-constant arg)))))))))
 
-(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

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)

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")
                                                  ""))))))]))
 

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) ...)

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

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?))]