diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index eedf52c5..35d24818 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -46,7 +46,7 @@ [null (-val null)] [number? (make-pred-ty N)] [char? (make-pred-ty -Char)] -[integer? (Univ . -> . B : (list (make-Latent-Restrict-Effect N)) (list (make-Latent-Remove-Effect -Integer)))] +[integer? (Univ . -> . B : (-LFS (list (-filter N)) (list (-not-filter -Integer))))] [exact-integer? (make-pred-ty -Integer)] [boolean? (make-pred-ty B)] [add1 (cl->* (-> -Integer -Integer) @@ -106,10 +106,7 @@ [((a b c . -> . c) c (-lst a) (-lst b)) c]))] [foldr (-poly (a b c) ((a b . -> . b) b (-lst a) . -> . b))] [filter (-poly (a b) (cl->* - ((a . -> . B - : - (list (make-Latent-Restrict-Effect b)) - (list (make-Latent-Remove-Effect b))) + ((make-pred-ty a B b) (-lst a) . -> . (-lst b)) diff --git a/collects/typed-scheme/private/env-lang.ss b/collects/typed-scheme/private/env-lang.ss index bbbfd3bd..1311e9ca 100644 --- a/collects/typed-scheme/private/env-lang.ss +++ b/collects/typed-scheme/private/env-lang.ss @@ -31,6 +31,6 @@ (provide #%module-begin require (all-from-out scheme/base) - (for-syntax - (types convenience union) + (for-syntax + (types-out convenience union) (all-from-out scheme/base))) diff --git a/collects/typed-scheme/types/abbrev.ss b/collects/typed-scheme/types/abbrev.ss index 0f02eb63..aa84eeb0 100644 --- a/collects/typed-scheme/types/abbrev.ss +++ b/collects/typed-scheme/types/abbrev.ss @@ -198,6 +198,11 @@ [(Function: as) as])) (make-Function (apply append (map funty-arities args)))) +(define-syntax cl-> + (syntax-parser + [(_ [(dom ...) rng] ...) + #'(cl->* (dom ... . -> . rng) ...)])) + (define-syntax (->key stx) (syntax-parse stx [(_ ty:expr ... (~or (k:keyword kty:expr opt:boolean)) ... rng) @@ -213,11 +218,17 @@ (define (-struct name parent flds [proc #f] [poly #f] [pred #'dummy] [cert values]) (make-Struct name parent flds proc poly pred cert)) +(define (-filter t [p null] [i 0]) + (make-LTypeFilter t p i)) + +(define (-not-filter t [p null] [i 0]) + (make-LNotTypeFilter t p i)) + (define make-pred-ty (case-lambda [(in out t) - (->* in out : (-LFS (list (make-LTypeFilter t null 0)) (list (make-LNotTypeFilter t null 0))))] + (->* in out : (-LFS (list (-filter t)) (list (-not-filter t))))] [(t) (make-pred-ty (list Univ) B t)])) diff --git a/collects/typed-scheme/types/convenience.ss b/collects/typed-scheme/types/convenience.ss index 702a4c0c..12184a72 100644 --- a/collects/typed-scheme/types/convenience.ss +++ b/collects/typed-scheme/types/convenience.ss @@ -1,7 +1,7 @@ #lang scheme/base (require "../utils/utils.ss") -(require (rep type-rep) +(require (rep type-rep filter-rep object-rep) (utils tc-utils) "abbrev.ss" (types comparison printer union subtype utils) @@ -15,7 +15,8 @@ (provide (all-defined-out) (all-from-out "abbrev.ss") ;; these should all eventually go away - make-Name make-ValuesDots make-Function) + make-Name make-ValuesDots make-Function + (rep-out filter-rep object-rep)) (define (one-of/c . args) (apply Un (map -val args)))