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

Requires splitting out the match expanders from base-abbrev.

original commit: 3c31803c192ea9212f5f5f6be73cd1e62afa9853
This commit is contained in:
Eric Dobson 2013-02-13 09:52:37 -08:00 committed by Vincent St-Amour
parent 31397e96aa
commit 4c543e9a5d
9 changed files with 90 additions and 64 deletions

View File

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

View File

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

View File

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

View File

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

View File

@ -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.

View File

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

View File

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

View File

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

View File

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