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:
parent
b4beabc977
commit
3c31803c19
|
@ -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?))))
|
||||||
|
|
|
@ -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)))
|
||||||
|
|
||||||
|
|
|
@ -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<?)))])))
|
||||||
|
|
40
collects/typed-racket/types/match-expanders.rkt
Normal file
40
collects/typed-racket/types/match-expanders.rkt
Normal 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)))))])))
|
|
@ -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.
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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 '()
|
||||||
|
|
|
@ -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?))]
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue
Block a user