diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index 203fb4bd..f942dc8b 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -3,7 +3,7 @@ (require (utils tc-utils) "rep-utils.rkt" "object-rep.rkt" "filter-rep.rkt" "free-variance.rkt" - mzlib/trace scheme/match + mzlib/trace scheme/match mzlib/etc scheme/contract unstable/debug (for-syntax scheme/base syntax/parse)) @@ -63,6 +63,32 @@ (map type-rec-id rands) stx)]) +(define (get-variances t num-rands) + (match t + [(Name: v) (error 'fail)] + [(Poly: n scope) + (let ([t (free-idxs* scope)]) + (for/list ([i (in-range n)]) + (hash-ref t i)))] + [(PolyDots: n scope) + (let ([t (free-idxs* scope)] + [base-count (sub1 n)] + [extras (max 0 (- n num-rands))]) + (append + ;; variances of the fixed arguments + (for/list ([i (in-range base-count)]) + (hash-ref t i)) + ;; variance of the dotted arguments + (for/list ([i (in-range extras)]) + (hash-ref t n))))])) + +(define (apply-variance v tbl) + (evcase v + [(Constant) (make-constant tbl)] + [(Covariant) tbl] + [(Invariant) (make-invariant tbl)] + [(Contravariant) (flip-variances tbl)])) + ;; left and right are Types (dt Pair ([left Type/c] [right Type/c]) [#:key 'pair])