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

Requires splitting out the match expanders from base-abbrev.
This commit is contained in:
Eric Dobson 2013-02-13 09:52:37 -08:00 committed by Vincent St-Amour
parent b4beabc977
commit 3c31803c19
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. ;; 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 (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)]) #: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)) ((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?)))) (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*]) (require (rename-in (rep type-rep object-rep filter-rep rep-utils) [make-Base make-Base*])
(utils tc-utils) (utils tc-utils)
"base-abbrev.rkt" "base-abbrev.rkt" "match-expanders.rkt"
(types union numeric-tower) (types union numeric-tower)
(env mvar-env) (env mvar-env)
racket/list racket/list
@ -25,7 +25,7 @@
(provide (except-out (all-defined-out) make-Base) (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] (rename-out [make-Listof -lst]
[make-MListof -mlst])) [make-MListof -mlst]))
@ -438,7 +438,7 @@
(define/cond-contract (-not-filter t i [p null]) (define/cond-contract (-not-filter t i [p null])
(c:->* (Type/c name-ref/c) ((listof PathElem?)) Filter/c) (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 -top
(make-NotTypeFilter t p i))) (make-NotTypeFilter t p i)))

View File

@ -4,15 +4,14 @@
(require "../utils/utils.rkt") (require "../utils/utils.rkt")
(require (rep type-rep) (require (rep type-rep)
racket/match racket/match racket/list
(types resolve) (for-template racket/base))
(for-template racket/base)
(for-syntax racket/base syntax/parse racket/list))
(provide (all-defined-out)) (provide (all-defined-out))
;Top and error types ;Top and error types
(define Univ (make-Univ)) (define Univ (make-Univ))
(define -Bottom (make-Union null))
(define Err (make-Error)) (define Err (make-Error))
;A Type that corresponds to the any contract for the ;A Type that corresponds to the any contract for the
@ -23,29 +22,31 @@
(define -Char (make-Base 'Char #'char? char? #'-Char #f)) (define -Char (make-Base 'Char #'char? char? #'-Char #f))
;;List expanders ;; Simple union type, does not check for overlaps
(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) ;; Union constructor
(match (resolve t) ;; Normalizes representation by sorting types.
[(Value: '()) null] ;; Type * -> Type
[(Pair: a b) (cond [(untuple b) => (lambda (l) (cons a l))] ;; The input types can be union types, but should not have a complicated
[else #f])] ;; overlap relationship.
[_ #f])) (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: ;; Type -> List[Type]
(lambda (stx) (define (flat t)
(syntax-parse stx (match t
[(_ elem-pat) [(Union: es) es]
#'(Mu: var (Union: (list (Value: '()) (MPair: elem-pat (F: var)))))]))) [_ (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 "../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*]) (rename-in (rep type-rep) [make-Base make-Base*])
racket/match racket/match
racket/function racket/function
@ -26,19 +27,6 @@
(define (make-Base name contract predicate marshaled) (define (make-Base name contract predicate marshaled)
(make-Base* name contract predicate marshaled #t)) (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 ;; Numeric hierarchy
;; All built as unions of non-overlapping base types. ;; All built as unions of non-overlapping base types.

View File

@ -2,7 +2,8 @@
(require (except-in "../utils/utils.rkt" infer) (require (except-in "../utils/utils.rkt" infer)
(rep type-rep filter-rep object-rep rep-utils) (rep type-rep filter-rep object-rep rep-utils)
(utils tc-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) (env type-name-env)
racket/match unstable/match racket/match unstable/match
racket/function racket/function

View File

@ -3,12 +3,19 @@
(require "../utils/utils.rkt" (require "../utils/utils.rkt"
(rep type-rep filter-rep object-rep rep-utils) (rep type-rep filter-rep object-rep rep-utils)
(utils tc-utils) (utils tc-utils)
"base-abbrev.rkt"
(contract-req)
racket/match) 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 (define (tc-error/expr msg
#:return [return (make-Union null)] #:return [return -Bottom]
#:stx [stx (current-orig-stx)] #:stx [stx (current-orig-stx)]
. rest) . rest)
(apply tc-error/delayed #:stx stx msg rest) (apply tc-error/delayed #:stx stx msg rest)

View File

@ -3,7 +3,7 @@
(require "../utils/utils.rkt" (require "../utils/utils.rkt"
(rep type-rep) (rep type-rep)
(prefix-in c: (contract-req)) (prefix-in c: (contract-req))
(types subtype) (types subtype base-abbrev)
racket/match racket/match
racket/list) racket/list)
@ -34,15 +34,13 @@
[(Union: es) es] [(Union: es) es]
[_ (list t)])) [_ (list t)]))
(define empty-union (make-Union null))
;; Union constructor ;; Union constructor
;; Normalizes representation by sorting types. ;; Normalizes representation by sorting types.
;; Type * -> Type ;; Type * -> Type
;; The input types can overlap and be union types ;; The input types can overlap and be union types
(define Un (define Un
(case-lambda (case-lambda
[() empty-union] [() -Bottom]
[(t) t] [(t) t]
[args [args
(define ts (foldr merge '() (define ts (foldr merge '()

View File

@ -3,21 +3,16 @@
(require "../utils/utils.rkt" (require "../utils/utils.rkt"
(rep type-rep filter-rep object-rep rep-utils) (rep type-rep filter-rep object-rep rep-utils)
(utils tc-utils) (utils tc-utils)
"substitute.rkt" "tc-result.rkt" "substitute.rkt" "tc-result.rkt" "tc-error.rkt"
(rep free-variance) (rep free-variance)
(env index-env tvar-env) (env index-env tvar-env)
racket/match racket/match
racket/set racket/set
racket/list racket/list
(contract-req) (contract-req))
"tc-error.rkt")
;; Don't provide things that may be exported with a contract (provide (all-from-out "tc-result.rkt" "tc-error.rkt"))
(provide (except-out (all-from-out "tc-result.rkt" "tc-error.rkt")
tc-error/expr
lookup-fail
lookup-type-fail))
;; unfold : Type -> Type ;; unfold : Type -> Type
@ -87,13 +82,9 @@
[instantiate-poly ((or/c Poly? PolyDots?) (listof Type/c) . -> . Type/c)] [instantiate-poly ((or/c Poly? PolyDots?) (listof Type/c) . -> . Type/c)]
[instantiate-poly-dotted [instantiate-poly-dotted
(PolyDots? (listof Type/c) Type/c symbol? . -> . Type/c)] (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?))] [fv (Rep? . -> . (listof symbol?))]
[fi (Rep? . -> . (listof symbol?))] [fi (Rep? . -> . (listof symbol?))]
[fv/list ((listof Type/c) . -> . (set/c 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?))] [current-poly-struct (parameter/c (or/c #f poly?))]
) )