Add a simple-Union and Bottom, and have code use them.

Requires splitting out the match expanders from base-abbrev.

original commit: 3c31803c192ea9212f5f5f6be73cd1e62afa9853

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?))))

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)))
 

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<?)))])))

collects/typed-racket/types/match-expanders.rkt

@@ -0,0 +1,40 @@
+#lang racket/base
+
+
+(require "../utils/utils.rkt")
+
+(require (rep type-rep)
+         racket/match
+         (types resolve)
+         (contract-req)
+         (for-syntax racket/base syntax/parse racket/list))
+
+(provide Listof: List: MListof:)
+(provide/cond-contract
+  [untuple (Type/c -> (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)))))])))

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<?)))]))
-
-(define (flat t)
-  (match t
-    [(Union: es) es]
-    [_ (list t)]))
-
-
 
 ;; Numeric hierarchy
 ;; All built as unions of non-overlapping base types.

collects/typed-racket/types/subtype.rkt

@@ -2,7 +2,8 @@
 (require (except-in "../utils/utils.rkt" infer)
          (rep type-rep filter-rep object-rep rep-utils)
          (utils tc-utils)
-         (types utils resolve base-abbrev numeric-tower substitute current-seen)
+         (types utils resolve base-abbrev match-expanders
+                numeric-tower substitute current-seen)
          (env type-name-env)
          racket/match unstable/match
          racket/function

collects/typed-racket/types/tc-error.rkt

@@ -2,13 +2,20 @@
 
 (require "../utils/utils.rkt"
          (rep type-rep filter-rep object-rep rep-utils)
-         (utils tc-utils)         
+         (utils tc-utils)
+         "base-abbrev.rkt"
+         (contract-req)
          racket/match)
 
-(provide tc-error/expr lookup-type-fail lookup-fail)
+(provide/cond-contract
+ [tc-error/expr ((string?) (#:return any/c #:stx syntax?) #:rest (listof any/c)
+                 . ->* . 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)

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 '()

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?))]
  )