From 3c31803c192ea9212f5f5f6be73cd1e62afa9853 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Wed, 13 Feb 2013 09:52:37 -0800 Subject: [PATCH] Add a simple-Union and Bottom, and have code use them. Requires splitting out the match expanders from base-abbrev. --- .../typed-racket/typecheck/tc-app-helper.rkt | 2 +- collects/typed-racket/types/abbrev.rkt | 6 +-- collects/typed-racket/types/base-abbrev.rkt | 53 ++++++++++--------- .../typed-racket/types/match-expanders.rkt | 40 ++++++++++++++ collects/typed-racket/types/numeric-tower.rkt | 16 +----- collects/typed-racket/types/subtype.rkt | 3 +- collects/typed-racket/types/tc-error.rkt | 13 +++-- collects/typed-racket/types/union.rkt | 6 +-- collects/typed-racket/types/utils.rkt | 15 ++---- 9 files changed, 90 insertions(+), 64 deletions(-) create mode 100644 collects/typed-racket/types/match-expanders.rkt diff --git a/collects/typed-racket/typecheck/tc-app-helper.rkt b/collects/typed-racket/typecheck/tc-app-helper.rkt index fd1db072d2..b2bed3094e 100644 --- a/collects/typed-racket/typecheck/tc-app-helper.rkt +++ b/collects/typed-racket/typecheck/tc-app-helper.rkt @@ -87,7 +87,7 @@ ;; Generates error messages when operand types don't match operator domains. (define/cond-contract (domain-mismatches f-stx args-stx ty doms rests drests rngs arg-tys tail-ty tail-bound - #:expected [expected #f] #:return [return (make-Union null)] + #:expected [expected #f] #:return [return -Bottom] #:msg-thunk [msg-thunk (lambda (dom) dom)]) ((syntax? syntax? Type/c (c:listof (c:listof Type/c)) (c:listof (c:or/c #f Type/c)) (c:listof (c:or/c #f (c:cons/c Type/c (c:or/c c:natural-number/c symbol?)))) diff --git a/collects/typed-racket/types/abbrev.rkt b/collects/typed-racket/types/abbrev.rkt index 2bb2bd3838..79cf4ed95d 100644 --- a/collects/typed-racket/types/abbrev.rkt +++ b/collects/typed-racket/types/abbrev.rkt @@ -4,7 +4,7 @@ (require (rename-in (rep type-rep object-rep filter-rep rep-utils) [make-Base make-Base*]) (utils tc-utils) - "base-abbrev.rkt" + "base-abbrev.rkt" "match-expanders.rkt" (types union numeric-tower) (env mvar-env) racket/list @@ -25,7 +25,7 @@ (provide (except-out (all-defined-out) make-Base) - (all-from-out "base-abbrev.rkt") + (all-from-out "base-abbrev.rkt" "match-expanders.rkt") (rename-out [make-Listof -lst] [make-MListof -mlst])) @@ -438,7 +438,7 @@ (define/cond-contract (-not-filter t i [p null]) (c:->* (Type/c name-ref/c) ((listof PathElem?)) Filter/c) - (if (or (type-equal? (make-Union null) t) (and (identifier? i) (is-var-mutated? i))) + (if (or (type-equal? -Bottom t) (and (identifier? i) (is-var-mutated? i))) -top (make-NotTypeFilter t p i))) diff --git a/collects/typed-racket/types/base-abbrev.rkt b/collects/typed-racket/types/base-abbrev.rkt index b40f2e1d24..235fe07e3b 100644 --- a/collects/typed-racket/types/base-abbrev.rkt +++ b/collects/typed-racket/types/base-abbrev.rkt @@ -4,15 +4,14 @@ (require "../utils/utils.rkt") (require (rep type-rep) - racket/match - (types resolve) - (for-template racket/base) - (for-syntax racket/base syntax/parse racket/list)) + racket/match racket/list + (for-template racket/base)) (provide (all-defined-out)) ;Top and error types (define Univ (make-Univ)) +(define -Bottom (make-Union null)) (define Err (make-Error)) ;A Type that corresponds to the any contract for the @@ -23,29 +22,31 @@ (define -Char (make-Base 'Char #'char? char? #'-Char #f)) -;;List expanders -(define-match-expander Listof: - (lambda (stx) - (syntax-parse stx - [(_ elem-pat (~optional var-pat #:defaults ([var-pat #'var]))) - (syntax/loc stx (Mu: var-pat (Union: (list (Value: '()) (Pair: elem-pat (F: var-pat))))))]))) +;; Simple union type, does not check for overlaps -(define-match-expander List: - (lambda (stx) - (syntax-parse stx - [(_ elem-pats) - #'(app untuple (? values elem-pats))]))) -(define (untuple t) - (match (resolve t) - [(Value: '()) null] - [(Pair: a b) (cond [(untuple b) => (lambda (l) (cons a l))] - [else #f])] - [_ #f])) +;; Union constructor +;; Normalizes representation by sorting types. +;; Type * -> Type +;; The input types can be union types, but should not have a complicated +;; overlap relationship. +(define simple-Un + (let () + ;; List[Type] -> Type + ;; Argument types should not overlap or be union types + (define (make-union* types) + (match types + [(list t) t] + [_ (make-Union types)])) -(define-match-expander MListof: - (lambda (stx) - (syntax-parse stx - [(_ elem-pat) - #'(Mu: var (Union: (list (Value: '()) (MPair: elem-pat (F: var)))))]))) + ;; Type -> List[Type] + (define (flat t) + (match t + [(Union: es) es] + [_ (list t)])) + (case-lambda + [() -Bottom] + [(t) t] + [args + (make-union* (remove-dups (sort (append-map flat args) type (or/c #f (listof Type/c)))]) + + +(define-match-expander Listof: + (lambda (stx) + (syntax-parse stx + [(_ elem-pat (~optional var-pat #:defaults ([var-pat #'var]))) + (syntax/loc stx (Mu: var-pat (Union: (list (Value: '()) (Pair: elem-pat (F: var-pat))))))]))) + +(define-match-expander List: + (lambda (stx) + (syntax-parse stx + [(_ elem-pats) + #'(app untuple (? values elem-pats))]))) + +(define (untuple t) + (match (resolve t) + [(Value: '()) null] + [(Pair: a b) (cond [(untuple b) => (lambda (l) (cons a l))] + [else #f])] + [_ #f])) + +(define-match-expander MListof: + (lambda (stx) + (syntax-parse stx + [(_ elem-pat) + #'(Mu: var (Union: (list (Value: '()) (MPair: elem-pat (F: var)))))]))) diff --git a/collects/typed-racket/types/numeric-tower.rkt b/collects/typed-racket/types/numeric-tower.rkt index 1a8404b693..5505f10902 100644 --- a/collects/typed-racket/types/numeric-tower.rkt +++ b/collects/typed-racket/types/numeric-tower.rkt @@ -2,7 +2,8 @@ (require "../utils/utils.rkt") -(require (types numeric-predicates) +(require (rename-in (types numeric-predicates base-abbrev) + [simple-Un *Un]) (rename-in (rep type-rep) [make-Base make-Base*]) racket/match racket/function @@ -26,19 +27,6 @@ (define (make-Base name contract predicate marshaled) (make-Base* name contract predicate marshaled #t)) -;; Simple union constructor. -;; Flattens nested unions and sorts types, but does not check for -;; overlapping subtypes. -(define-syntax *Un - (syntax-rules () - [(_ . args) (make-Union (remove-dups (sort (apply append (map flat (list . args))) type* . any/c)] + + [lookup-fail (identifier? . -> . Type/c)] + [lookup-type-fail (identifier? . -> . Type/c)]) (define (tc-error/expr msg - #:return [return (make-Union null)] + #:return [return -Bottom] #:stx [stx (current-orig-stx)] . rest) (apply tc-error/delayed #:stx stx msg rest) diff --git a/collects/typed-racket/types/union.rkt b/collects/typed-racket/types/union.rkt index f817a7360c..59f7fc54af 100644 --- a/collects/typed-racket/types/union.rkt +++ b/collects/typed-racket/types/union.rkt @@ -3,7 +3,7 @@ (require "../utils/utils.rkt" (rep type-rep) (prefix-in c: (contract-req)) - (types subtype) + (types subtype base-abbrev) racket/match racket/list) @@ -34,15 +34,13 @@ [(Union: es) es] [_ (list t)])) -(define empty-union (make-Union null)) - ;; Union constructor ;; Normalizes representation by sorting types. ;; Type * -> Type ;; The input types can overlap and be union types (define Un (case-lambda - [() empty-union] + [() -Bottom] [(t) t] [args (define ts (foldr merge '() diff --git a/collects/typed-racket/types/utils.rkt b/collects/typed-racket/types/utils.rkt index 007583ffee..32c93241a2 100644 --- a/collects/typed-racket/types/utils.rkt +++ b/collects/typed-racket/types/utils.rkt @@ -3,21 +3,16 @@ (require "../utils/utils.rkt" (rep type-rep filter-rep object-rep rep-utils) (utils tc-utils) - "substitute.rkt" "tc-result.rkt" + "substitute.rkt" "tc-result.rkt" "tc-error.rkt" (rep free-variance) (env index-env tvar-env) racket/match racket/set racket/list - (contract-req) - "tc-error.rkt") + (contract-req)) -;; Don't provide things that may be exported with a contract -(provide (except-out (all-from-out "tc-result.rkt" "tc-error.rkt") - tc-error/expr - lookup-fail - lookup-type-fail)) +(provide (all-from-out "tc-result.rkt" "tc-error.rkt")) ;; unfold : Type -> Type @@ -87,13 +82,9 @@ [instantiate-poly ((or/c Poly? PolyDots?) (listof Type/c) . -> . Type/c)] [instantiate-poly-dotted (PolyDots? (listof Type/c) Type/c symbol? . -> . Type/c)] - [tc-error/expr ((string?) (#:return any/c #:stx syntax?) #:rest (listof any/c) - . ->* . any/c)] [fv (Rep? . -> . (listof symbol?))] [fi (Rep? . -> . (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?))] )