diff --git a/collects/typed-scheme/env/type-environments.ss b/collects/typed-scheme/env/type-environments.ss index 0f159ec0bd..8095c8063c 100644 --- a/collects/typed-scheme/env/type-environments.ss +++ b/collects/typed-scheme/env/type-environments.ss @@ -12,7 +12,7 @@ (require (prefix-in r: "../utils/utils.ss")) (require scheme/match - (r:utils tc-utils)) + (except-in (r:utils tc-utils) make-env)) ;; eq? has the type of equal?, and l is an alist (with conses!) (define-struct env (eq? l)) diff --git a/collects/typed-scheme/infer/constraints.ss b/collects/typed-scheme/infer/constraints.ss index 3dff2c088a..cacc1863b2 100644 --- a/collects/typed-scheme/infer/constraints.ss +++ b/collects/typed-scheme/infer/constraints.ss @@ -1,7 +1,7 @@ #lang scheme/unit (require (except-in "../utils/utils.ss" extend)) -(require (private type-effect-convenience type-utils union subtype) +(require (types convenience utils union subtype) (rep type-rep) (utils tc-utils) "signatures.ss" "constraint-structs.ss" diff --git a/collects/typed-scheme/infer/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss index bcfc0e85fb..6b84ee4899 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -1,11 +1,11 @@ #lang scheme/unit (require (except-in "../utils/utils.ss")) -(require (rep free-variance type-rep effect-rep rep-utils) - (private type-effect-convenience union subtype remove-intersect) - (utils tc-utils) +(require (rep free-variance type-rep filter-rep rep-utils) + (types convenience union subtype remove-intersect) + (except-in (utils tc-utils) make-env) (env type-name-env) - (except-in (private type-utils) Dotted) + (except-in (types utils) Dotted) "constraint-structs.ss" "signatures.ss" (only-in (env type-environments) lookup current-tvars) @@ -100,6 +100,8 @@ (define (cgen/eff V X t s) (match* (t s) [(e e) (empty-cset X)] + ;; FIXME - do something here + #;#; [((Latent-Restrict-Effect: t) (Latent-Restrict-Effect: s)) (cset-meet (cgen V X t s) (cgen V X s t))] [((Latent-Remove-Effect: t) (Latent-Remove-Effect: s)) diff --git a/collects/typed-scheme/infer/promote-demote.ss b/collects/typed-scheme/infer/promote-demote.ss index 8705122937..1eb261f135 100644 --- a/collects/typed-scheme/infer/promote-demote.ss +++ b/collects/typed-scheme/infer/promote-demote.ss @@ -1,10 +1,10 @@ #lang scheme/unit (require "../utils/utils.ss") -(require (rep type-rep) - (private type-effect-convenience union type-utils) +(require (rep type-rep rep-utils) + (types convenience union utils) "signatures.ss" - scheme/list) + scheme/list scheme/match) (import) (export promote-demote^) @@ -13,10 +13,15 @@ (for/or ([e (append* (map fv ts))]) (memq e V))) +(define (get-filters rng) + (match rng + [(Values: (list (Result: _ lf _) ...)) lf] + [(ValuesDots: (list (Result: _ lf _) ...) _ _) lf])) + (define (var-promote T V) (define (vp t) (var-promote t V)) (define (inv t) (if (V-in? V t) Univ t)) - (type-case vp T + (type-case (#:Type vp #:LatentFilter (sub-lf vp)) T [#:F name (if (memq name V) Univ T)] [#:Vector t (make-Vector (inv t))] [#:Box t (make-Box (inv t))] @@ -27,19 +32,16 @@ [#:Param in out (make-Param (var-demote in V) (vp out))] - [#:arr dom rng rest drest kws thn els - (cond - [(apply V-in? V (append thn els)) - (make-arr null (Un) Univ #f null null)] + [#:arr dom rng rest drest kws + (cond + [(apply V-in? V (get-filters rng)) + (make-top-arr)] [(and drest (memq (cdr drest) V)) (make-arr (for/list ([d dom]) (var-demote d V)) (vp rng) (var-demote (car drest) V) #f - (for/list ([(kw kwt) (in-pairs kws)]) - (cons kw (var-demote kwt V))) - thn - els)] + (for/list ([k kws]) (var-demote k V)))] [else (make-arr (for/list ([d dom]) (var-demote d V)) (vp rng) @@ -47,15 +49,12 @@ (and drest (cons (var-demote (car drest) V) (cdr drest))) - (for/list ([(kw kwt) (in-pairs kws)]) - (cons kw (var-demote kwt V))) - thn - els)])])) + (for/list ([k kws]) (var-demote k V)))])])) (define (var-demote T V) (define (vd t) (var-demote t V)) (define (inv t) (if (V-in? V t) (Un) t)) - (type-case vd T + (type-case (#:Type vd #:LatentFilter (sub-lf vd)) T [#:F name (if (memq name V) (Un) T)] [#:Vector t (make-Vector (inv t))] [#:Box t (make-Box (inv t))] @@ -66,19 +65,16 @@ [#:Param in out (make-Param (var-promote in V) (vd out))] - [#:arr dom rng rest drest kws thn els + [#:arr dom rng rest drest kws (cond - [(apply V-in? V (append thn els)) - (make-arr null (Un) Univ #f null null)] + [(apply V-in? V (get-filters rng)) + (make-top-arr)] [(and drest (memq (cdr drest) V)) (make-arr (for/list ([d dom]) (var-promote d V)) (vd rng) (var-promote (car drest) V) #f - (for/list ([(kw kwt) (in-pairs kws)]) - (cons kw (var-promote kwt V))) - thn - els)] + (for/list ([k kws]) (var-demote k V)))] [else (make-arr (for/list ([d dom]) (var-promote d V)) (vd rng) @@ -86,7 +82,4 @@ (and drest (cons (var-promote (car drest) V) (cdr drest))) - (for/list ([(kw kwt) (in-pairs kws)]) - (cons kw (var-promote kwt V))) - thn - els)])])) + (for/list ([k kws]) (var-demote k V)))])])) diff --git a/collects/typed-scheme/infer/restrict.ss b/collects/typed-scheme/infer/restrict.ss index 4d2d26380c..140e276db5 100644 --- a/collects/typed-scheme/infer/restrict.ss +++ b/collects/typed-scheme/infer/restrict.ss @@ -2,7 +2,7 @@ (require "../utils/utils.ss") (require (rep type-rep) - (private type-utils union remove-intersect subtype) + (types utils union subtype remove-intersect) "signatures.ss" scheme/match) diff --git a/collects/typed-scheme/private/remove-intersect.ss b/collects/typed-scheme/types/remove-intersect.ss similarity index 96% rename from collects/typed-scheme/private/remove-intersect.ss rename to collects/typed-scheme/types/remove-intersect.ss index ca2b264c01..c7a1b219ee 100644 --- a/collects/typed-scheme/private/remove-intersect.ss +++ b/collects/typed-scheme/types/remove-intersect.ss @@ -2,7 +2,7 @@ (require (except-in "../utils/utils.ss" extend)) (require (rep type-rep) - (private union subtype resolve-type type-effect-convenience type-utils) + (types union subtype resolve convenience utils) scheme/match mzlib/trace) (provide (rename-out [*remove remove]) overlap)