suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Make numeric contracts in unions better.

Browse Source
This commit is contained in:
Eric Dobson 2014-01-14 22:52:18 -08:00
parent 4ad412d71c
commit 6d05e41a24
2 changed files with 16 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt
View File

@ -8,7 +8,8 @@
(rep type-rep filter-rep object-rep) (rep type-rep filter-rep object-rep)
(utils tc-utils) (utils tc-utils)
(env type-name-env) (env type-name-env)
(types resolve) (rep rep-utils)
(types resolve union)
(prefix-in t: (types abbrev numeric-tower)) (prefix-in t: (types abbrev numeric-tower))
(private parse-type syntax-properties) (private parse-type syntax-properties)
racket/match racket/syntax racket/list racket/match racket/syntax racket/list
@ -30,7 +31,7 @@
(#:typed-side boolean?) . c:->* . (c:or/c a static-contract?)))])) (#:typed-side boolean?) . c:->* . (c:or/c a static-contract?)))]))
(provide type->contract define/fixup-contract? change-contract-fixups (provide type->contract define/fixup-contract? change-contract-fixups
type->contract-fail) type->contract-fail any-wrap/sc)
;; These check if either the define form or the body form has the syntax ;; These check if either the define form or the body form has the syntax
;; property. Normally the define form will have the property but lifting an ;; property. Normally the define form will have the property but lifting an
@ -197,13 +198,16 @@
[(Univ:) (if (from-typed? typed-side) any-wrap/sc any/sc)] [(Univ:) (if (from-typed? typed-side) any-wrap/sc any/sc)]
[(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var))))) [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var)))))
(listof/sc (t->sc elem-ty))] (listof/sc (t->sc elem-ty))]
[t (=> fail) (or (numeric-type->static-contract t) (fail))]
[(Base: sym cnt _ _) [(Base: sym cnt _ _)
(flat/sc #`(flat-named-contract '#,sym (flat-contract-predicate #,cnt)) sym)] (flat/sc #`(flat-named-contract '#,sym (flat-contract-predicate #,cnt)) sym)]
[(Refinement: par p?) [(Refinement: par p?)
(and/sc (t->sc par) (flat/sc p?))] (and/sc (t->sc par) (flat/sc p?))]
[(Union: elems) [(Union: elems)
(apply or/sc (map t->sc elems))] (define-values (numeric non-numeric) (partition (λ (t) (equal? 'number (Type-key t))) elems ))
(define numeric-sc (numeric-type->static-contract (apply Un numeric)))
(if numeric-sc
(apply or/sc numeric-sc (map t->sc non-numeric))
(apply or/sc (map t->sc elems)))]
[(and t (Function: _)) (t->sc/fun t)] [(and t (Function: _)) (t->sc/fun t)]
[(Set: t) (set/sc (t->sc t))] [(Set: t) (set/sc (t->sc t))]
[(Sequence: ts) (apply sequence/sc (map t->sc ts))] [(Sequence: ts) (apply sequence/sc (map t->sc ts))]

6
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/contract-tests.rkt
View File

@ -6,6 +6,7 @@
(private type-contract) (private type-contract)
(rep type-rep) (rep type-rep)
(types abbrev numeric-tower union) (types abbrev numeric-tower union)
(static-contracts combinators optimize)
(submod typed-racket/private/type-contract numeric-contracts) (submod typed-racket/private/type-contract numeric-contracts)
rackunit) rackunit)
(provide tests) (provide tests)
@ -26,10 +27,11 @@
(let ([t e-t] [sc e-sc]) (let ([t e-t] [sc e-sc])
(with-check-info (['type t] ['expected sc]) (with-check-info (['type t] ['expected sc])
(define actual (define actual
(optimize
(type->static-contract (type->static-contract
t t
(λ (#:reason [reason #f]) (λ (#:reason [reason #f])
(fail-check (or reason "Type could not be converted to contract"))))) (fail-check (or reason "Type could not be converted to contract"))))))
(with-check-info (['actual actual]) (with-check-info (['actual actual])
(unless (equal? actual sc) (unless (equal? actual sc)
(fail-check "Static contract didn't match expected"))))))) (fail-check "Static contract didn't match expected")))))))
@ -122,5 +124,7 @@
(t-sc -Number number/sc) (t-sc -Number number/sc)
(t-sc -Integer integer/sc) (t-sc -Integer integer/sc)
(t-sc (-lst Univ) (listof/sc any-wrap/sc))
(t-sc (Un (-lst Univ) -Number) (or/sc number/sc (listof/sc any-wrap/sc)))
)) ))