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:
parent
31397e96aa
commit
4c543e9a5d
|
@ -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?))))
|
||||
|
|
|
@ -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)))
|
||||
|
||||
|
|
|
@ -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<?)))])))
|
||||
|
|
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 (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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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 '()
|
||||
|
|
|
@ -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?))]
|
||||
)
|
||||
|
||||
|
|
Loading…
Reference in New Issue
Block a user