suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Compare commits

base: suzanne.soy:master
Branches Tags
suzanne.soy:master
suzanne.soy:fix-539
suzanne.soy:fix-434
suzanne.soy:typo-splite3
suzanne.soy:remove-tests-output-pr323
suzanne.soy:fix-define-typed-untyped-identifier-issue-315
suzanne.soy:fix-coverage-vector-access
suzanne.soy:improve-error-messages
suzanne.soy:fix-promise-provide
suzanne.soy:fix-assoc-and-member-types-squashed
suzanne.soy:fix-assoc-and-member-types
suzanne.soy:simplify-let-syntax-error
suzanne.soy:sudo-false
suzanne.soy:v6.2
..
compare: suzanne.soy:remove-tests-output-pr323
Branches Tags
suzanne.soy:fix-539
suzanne.soy:fix-434
suzanne.soy:typo-splite3
suzanne.soy:master
suzanne.soy:remove-tests-output-pr323
suzanne.soy:fix-define-typed-untyped-identifier-issue-315
suzanne.soy:fix-coverage-vector-access
suzanne.soy:improve-error-messages
suzanne.soy:fix-promise-provide
suzanne.soy:fix-assoc-and-member-types-squashed
suzanne.soy:fix-assoc-and-member-types
suzanne.soy:simplify-let-syntax-error
suzanne.soy:sudo-false
suzanne.soy:v6.2

1 Commits
master ... remove-tes

Author SHA1 Message Date
Georges Dupéron
579c68daa2 Remove debugging output from test case in typed-racket-test/succeed/define-typed-untyped-identifier-syntax-properties.rkt 2016-04-07 12:17:54 +02:00
125 changed files with 2405 additions and 3371 deletions
Show Stats Expand all files Collapse all files

2
typed-racket-compatibility/info.rkt
View File

@ -11,4 +11,4 @@
(define pkg-authors '(samth stamourv))
(define version "1.5")
(define version "1.3")

4
typed-racket-doc/info.rkt
View File

@ -12,7 +12,7 @@
"at-exp-lib"
("scribble-lib" #:version "1.16")
"pict-lib"
("typed-racket-lib" #:version "1.5")
("typed-racket-lib" #:version "1.3")
"typed-racket-compatibility"
"typed-racket-more"
"racket-doc"
@ -24,4 +24,4 @@
(define pkg-authors '(samth stamourv))
(define version "1.5")
(define version "1.3")

26
typed-racket-doc/typed-racket/scribblings/guide/occurrence.scrbl
View File

@ -51,7 +51,7 @@ have based on a predicate check in a conditional expression, it can
narrow the type of the variable within the appropriate branch of the
conditional.
@section[#:tag "propositions-and-predicates"]{Propositions and Predicates}
@section[#:tag "filters-and-predicates"]{Filters and Predicates}
In the previous section, we demonstrated that a Typed Racket programmer
can take advantage of occurrence typing to type-check functions
@ -59,7 +59,7 @@ with union types and conditionals. This may raise the question: how
does Typed Racket know how to narrow the type based on the predicate?
The answer is that predicate types in Typed Racket are annotated
with logical @deftech{propositions} that tell the typechecker what additional
with @deftech{filters} that tell the typechecker what additional
information is gained when a predicate check succeeds or fails.
For example, consider the REPL's type printout for @racket[string?]:
@ -69,20 +69,16 @@ For example, consider the REPL's type printout for @racket[string?]:
The type @racket[(-> Any Boolean : String)] has three parts. The first
two are the same as any other function type and indicate that the
predicate takes any value and returns a boolean. The third part, after
the @racket[_:], represents the logical @tech{propositions}
the typechecker learns from the result of applying the function:
the @racket[_:], is a @tech{filter} that tells the typechecker two
things:
@itemlist[#:style 'ordered
@item{If the predicate check succeeds, the argument variable has type @racket[String]}
@item{If the predicate check fails, the argument variable @emph{does not} have type @racket[String]}
]
@item{If the predicate check succeeds (i.e. produces a
non-@racket[#f] value), the argument variable has type
@racket[String]}
@item{If the predicate check fails (i.e. produces @racket[#f]), the
argument variable @emph{does not} have type @racket[String]} ]
Predicates for all built-in types are annotated with similar propositions
that allow the type system to reason logically about predicate checks.
Predicates for all built-in types are annotated with similar filters
that allow the type system to reason about predicate checks.
@section{Other conditionals and assertions}
@ -128,8 +124,8 @@ using an @emph{assertion}. For example,
(define d (assert (- b a) positive?))
]
Using the logical propositions on @racket[positive?], Typed Racket can
assign the type @racket[Positive-Integer] to the whole @racket[assert]
Using the filter on @racket[positive?], Typed Racket can assign the
type @racket[Positive-Integer] to the whole @racket[assert]
expression. This type-checks, but note that the assertion may raise
an exception at run-time if the predicate returns @racket[#f].

10
typed-racket-doc/typed-racket/scribblings/internals.txt
View File

@ -1,17 +1,17 @@
Data Structures used in Typechecking.
The main data structure used in typechecking is a tc-results/c.
This currently has two variants
(struct/c tc-results ((listof (struct/c tc-result (Type/c PropSet? Object?)))
(struct/c tc-results ((listof (struct/c tc-result (Type/c FilterSet? Object?)))
(or/c #f (cons/c Type/c symbol?))))
(struct/c tc-any-results (or/c Prop? #f))
(struct/c tc-any-results (or/c Filter/c NoFilter?))
The first represents a fixed number of values with optional dotted return values.
The second represents an unknown number of values.
A value has three main parts: a Type, a PropSet, and an Object. For dotted values we do no store a
PropSet or an Object because they would almost never be useful. They are thus implicitly -tt-propset
A value has three main parts: a Type, a FilterSet, and an Object. For dotted values we do no store a
FilterSet or an Object because they would almost never be useful. They are thus implicitly -top-filter
and -empty-obj. In the tc-any-results case since we don't know the number of values, we do not store
the Type or the Object, but we do store a proposition. This is useful in cases like
the Type or the Object, but we do store a filter. This is useful in cases like
(let ((x (read)))
(unless (number? x) (error 'bad-input))
(do-stuff x))

17
typed-racket-doc/typed-racket/scribblings/reference/libraries.scrbl
View File

@ -51,11 +51,8 @@ Other libraries can be used with Typed Racket via
The following libraries are included with Typed Racket in the
@racketfont{typed} collection:
@(define-syntax-rule @defmodule/incl[name rest ...]
(list
(section #:style '(hidden toc-hidden unnumbered)
(string-append "Typed for " (symbol->string 'name)))
@defmodule[name rest ...]))
@(define-syntax-rule @defmodule/incl[name]
@defmodule[name #:no-declare])
@(define-syntax-rule (deftype name . parts)
(defidform #:kind "type" name . parts))
@ -171,11 +168,11 @@ and the @racket[URL] and @racket[Path/Param] types from
@defmodule/incl[typed/openssl/md5]
@defmodule/incl[typed/openssl/sha1]
@defmodule/incl[typed/racket/async-channel @history[#:added "1.1"]]
@defmodule/incl[typed/pict]
@defmodule[typed/racket/async-channel #:no-declare @history[#:added "1.1"]]
@defmodule/incl[typed/racket/date]
@defmodule/incl[typed/racket/draw]
@defmodule/incl[typed/racket/gui]
@defmodule/incl[typed/racket/random @history[#:added "1.5"]]
@defmodule/incl[typed/racket/sandbox]
@defmodule/incl[typed/racket/snip]
@defmodule/incl[typed/racket/system]
@ -213,11 +210,7 @@ written in Typed Racket or have adapter modules that are typed:
@defmodule[name #:no-declare #:link-target? #f #:indirect])
@defmodule/also[math]
@defmodule/also[plot]
@defmodule/incl[typed/pict]
@defmodule/also[images/flomap]
@defmodule/incl[typed/images/logos]
@defmodule/incl[typed/images/icons]
@defmodule/also[plot/typed]
@section{Porting Untyped Modules to Typed Racket}

18
typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl
View File

@ -541,18 +541,9 @@ returned by @racket[e], protected by a contract ensuring that it has type
@ex[(cast 3 Integer)
(eval:error (cast 3 String))
(cast (lambda ([x : Any]) x) (String -> String))
((cast (lambda ([x : Any]) x) (String -> String)) "hello")
(cast (lambda: ([x : Any]) x) (String -> String))
]
The value is actually protected with two contracts. The second contract checks
the new type, but the first contract is put there to enforce the old type, to
protect higher-order uses of the value.
@ex[
((cast (lambda ([s : String]) s) (Any -> Any)) "hello")
(eval:error ((cast (lambda ([s : String]) s) (Any -> Any)) 5))
]}
}
@defform*[[(inst e t ...)
(inst e t ... t ooo bound)]]{
@ -700,6 +691,7 @@ but provides additional annotations to assist the typechecker.
prompt tag. If the wrapped value is used in untyped code, a contract error
will be raised.
@;{
@ex[
(module typed typed/racket
(provide do-abort)
@ -716,8 +708,8 @@ but provides additional annotations to assist the typechecker.
(default-continuation-prompt-tag)
(code:comment "the function cannot be passed an argument")
(λ (f) (f 3))))
(eval:error (require 'untyped))
]
(require 'untyped)
]}
}
@defform[(#%module-begin form ...)]{

70
typed-racket-doc/typed-racket/scribblings/reference/types.scrbl
View File

@ -568,33 +568,29 @@ functions and continuation mark functions.
@section{Other Type Constructors}
@defform*/subs[#:id -> #:literals (|@| * ... ! and or implies car cdr)
[(-> dom ... rng opt-proposition)
[(-> dom ... rng optional-filter)
(-> dom ... rest * rng)
(-> dom ... rest ooo bound rng)
(dom ... -> rng opt-proposition)
(dom ... -> rng optional-filter)
(dom ... rest * -> rng)
(dom ... rest ooo bound -> rng)]
([ooo #,(racket ...)]
[dom type
mandatory-kw
opt-kw]
optional-kw]
[mandatory-kw (code:line keyword type)]
[opt-kw [keyword type]]
[opt-proposition (code:line)
[optional-kw [keyword type]]
[optional-filter (code:line)
(code:line : type)
(code:line : pos-proposition
neg-proposition
object)]
[pos-proposition (code:line)
(code:line #:+ proposition ...)]
[neg-proposition (code:line)
(code:line #:- proposition ...)]
(code:line : pos-filter neg-filter object)]
[pos-filter (code:line)
(code:line #:+ proposition ...)]
[neg-filter (code:line)
(code:line #:- proposition ...)]
[object (code:line)
(code:line #:object index)]
[proposition Top
Bot
type
[proposition type
(! type)
(type |@| path-elem ... index)
(! type |@| path-elem ... index)
@ -608,15 +604,15 @@ functions and continuation mark functions.
The type of functions from the (possibly-empty)
sequence @racket[dom ....] to the @racket[rng] type.
@ex[(λ ([x : Number]) x)
(λ () 'hello)]
@ex[(λ: ([x : Number]) x)
(λ: () 'hello)]
The second form specifies a uniform rest argument of type @racket[rest], and the
third form specifies a non-uniform rest argument of type
@racket[rest] with bound @racket[bound]. The bound refers to the type variable
that is in scope within the rest argument type.
@ex[(λ ([x : Number] . [y : String *]) (length y))
@ex[(λ: ([x : Number] . [y : String *]) (length y))
ormap]
In the third form, the @racket[...] introduced by @racket[ooo] is literal,
@ -633,24 +629,20 @@ functions and continuation mark functions.
(is-zero? 2 #:equality =)
(is-zero? 2 #:equality eq? #:zero 2.0)]
When @racket[opt-proposition] is provided, it specifies the
@emph{proposition} for the function type (for an introduction to
propositions in Typed Racket, see
@tr-guide-secref["propositions-and-predicates"]). For almost all use
cases, only the simplest form of propositions, with a single type after a
When @racket[optional-filter] is provided, it specifies the @emph{filter} for the
function type (for an introduction to filters, see @tr-guide-secref["filters-and-predicates"]).
For almost all use cases, only the simplest form of filters, with a single type after a
@racket[:], are necessary:
@ex[string?]
The proposition specifies that when @racket[(string? x)] evaluates to a
true value for a conditional branch, the variable @racket[x] in that
branch can be assumed to have type @racket[String]. Likewise, if the
expression evaluates to @racket[#f] in a branch, the variable
@emph{does not} have type @racket[String].
The filter specifies that when @racket[(string? x)] evaluates to a true value for
a conditional branch, the variable @racket[x] in that branch can be assumed to have
type @racket[String]. Likewise, if the expression evaluates to @racket[#f] in a branch,
the variable @emph{does not} have type @racket[String].
In some cases, asymmetric type information is useful in the
propositions. For example, the @racket[filter] function's first
argument is specified with only a positive proposition:
In some cases, asymmetric type information is useful in filters. For example, the
@racket[filter] function's first argument is specified with only a positive filter:
@ex[filter]
@ -661,7 +653,7 @@ functions and continuation mark functions.
Conversely, @racket[#:-] specifies that a function provides information for the
false branch of a conditional.
The other proposition cases are rarely needed, but the grammar documents them
The other filter proposition cases are rarely needed, but the grammar documents them
for completeness. They correspond to logical operations on the propositions.
The type of functions can also be specified with an @emph{infix} @racket[->]
@ -703,7 +695,7 @@ functions and continuation mark functions.
@ex[(: +all (->* (Integer) #:rest Integer (Listof Integer)))
(define (+all inc . rst)
(map (λ ([x : Integer]) (+ x inc)) rst))
(map (λ: ([x : Integer]) (+ x inc)) rst))
(+all 20 1 2 3)]
Both the mandatory and optional argument lists may contain keywords paired
@ -718,9 +710,9 @@ functions and continuation mark functions.
@deftogether[(
@defidform[Top]
@defidform[Bot])]{ These are propositions that can be used with @racket[->].
@racket[Top] is the propositions with no information.
@racket[Bot] is the propositions which means the result cannot happen.
@defidform[Bot])]{ These are filters that can be used with @racket[->].
@racket[Top] is the filter with no information.
@racket[Bot] is the filter which means the result cannot happen.
}
@ -742,11 +734,7 @@ functions and continuation mark functions.
@defform[(U t ...)]{is the union of the types @racket[t ...].
@ex[(λ ([x : Real]) (if (> 0 x) "yes" 'no))]}
@defform[(∩ t ...)]{is the intersection of the types @racket[t ...].
@ex[((λ #:forall (A) ([x : (∩ Symbol A)]) x) 'foo)]}
@ex[(λ: ([x : Real])(if (> 0 x) "yes" 'no))]}
@defform[(case-> fun-ty ...)]{is a function that behaves like all of
the @racket[fun-ty]s, considered in order from first to last. The @racket[fun-ty]s must all be function
types constructed with @racket[->].

2
typed-racket-lib/info.rkt
View File

@ -12,4 +12,4 @@
(define pkg-authors '(samth stamourv))
(define version "1.5")
(define version "1.4")

5
typed-racket-lib/typed-racket/HISTORY.txt
View File

@ -1,8 +1,3 @@
6.5
- Added `simple-result->` to improve generated contract performance.
- Improve error message printing.
- Add `typed/racket/random`.
- Internal: populate type table unconditionally, for use in tooltips.
6.4
- Contract performance improvements, including generating code that
the contract system can optimize

702
typed-racket-lib/typed-racket/base-env/base-env-numeric.rkt
View File

@ -41,11 +41,11 @@
;; for fixnum-specific operations. if they return at all, we know
;; their args were fixnums. otherwise, an error would have been thrown
;; for the moment, this is only useful if the result is used as a test
;; once we have a set of props that are true/false based on reaching
;; once we have a set of filters that are true/false based on reaching
;; a certain point, this will be more useful
(define (fx-from-cases . cases)
(apply from-cases (map (lambda (x)
(add-unconditional-prop-all-args
(add-unconditional-filter-all-args
x -Fixnum))
(flatten cases))))
@ -70,14 +70,14 @@
(-> t1 t2 B))
;; simple case useful with equality predicates.
;; if the equality is true, we know that general arg is in fact of specific type.
(define (commutative-equality/prop general specific)
(list (-> general specific B : (-PS (-is-type 0 specific) -tt))
(-> specific general B : (-PS (-is-type 1 specific) -tt))))
(define (commutative-equality/filter general specific)
(list (-> general specific B : (-FS (-filter specific 0) -top))
(-> specific general B : (-FS (-filter specific 1) -top))))
;; if in addition if the equality is false, we know that general arg is not of the specific type.
(define (commutative-equality/strict-prop general specific)
(list (-> general specific B : (-PS (-is-type 0 specific) (-not-type 0 specific)))
(-> specific general B : (-PS (-is-type 1 specific) (-not-type 1 specific)))))
(define (commutative-equality/strict-filter general specific)
(list (-> general specific B : (-FS (-filter specific 0) (-not-filter specific 0)))
(-> specific general B : (-FS (-filter specific 1) (-not-filter specific 1)))))
(define round-type ; also used for truncate
@ -118,8 +118,8 @@
(define fx+-type
(lambda ()
(fx-from-cases
(-> -Zero -Int -Fixnum : -true-propset : (-arg-path 1))
(-> -Int -Zero -Fixnum : -true-propset : (-arg-path 0))
(-> -Zero -Int -Fixnum : -true-filter : (-arg-path 1))
(-> -Int -Zero -Fixnum : -true-filter : (-arg-path 0))
(commutative-binop -PosByte -Byte -PosIndex)
(binop -Byte -Index)
;; in other cases, either we stay within fixnum range, or we error
@ -132,7 +132,7 @@
(define fx--type
(lambda ()
(fx-from-cases
(-> -Int -Zero -Fixnum : -true-propset : (-arg-path 0))
(-> -Int -Zero -Fixnum : -true-filter : (-arg-path 0))
(-One -One . -> . -Zero)
(-PosByte -One . -> . -Byte)
(-PosIndex -One . -> . -Index)
@ -147,8 +147,8 @@
(define fx*-type
(lambda ()
(fx-from-cases
(-> -One -Int -Fixnum : -true-propset : (-arg-path 1))
(-> -Int -One -Fixnum : -true-propset : (-arg-path 0))
(-> -One -Int -Fixnum : -true-filter : (-arg-path 1))
(-> -Int -One -Fixnum : -true-filter : (-arg-path 0))
(commutative-binop -Int -Zero)
(-PosByte -PosByte . -> . -PosIndex)
(-Byte -Byte . -> . -Index)
@ -163,7 +163,7 @@
(lambda ()
(fx-from-cases
(-Zero -Int . -> . -Zero)
(-> -Int -One -Fixnum : -true-propset : (-arg-path 0))
(-> -Int -One -Fixnum : -true-filter : (-arg-path 0))
(-Byte -Nat . -> . -Byte)
(-Index -Nat . -> . -Index)
(-Nat -Nat . -> . -NonNegFixnum)
@ -193,133 +193,133 @@
(define fxabs-type
(lambda ()
(fx-from-cases
(-> -Nat -NonNegFixnum : -true-propset : (-arg-path 0))
(-> -Nat -NonNegFixnum : -true-filter : (-arg-path 0))
((Un -PosInt -NegInt) . -> . -PosFixnum)
(-Int . -> . -NonNegFixnum))))
(define fx=-type
(lambda ()
(fx-from-cases
;; we could rule out cases like (= Pos Neg), but we currently don't
(commutative-equality/strict-prop -Int -Zero)
(map (lambda (t) (commutative-equality/prop -Int t))
(commutative-equality/strict-filter -Int -Zero)
(map (lambda (t) (commutative-equality/filter -Int t))
(list -One -PosByte -Byte -PosIndex -Index -PosFixnum -NonNegFixnum -NegFixnum -NonPosFixnum))
(comp -Int))))
(define fx<-type
(lambda ()
(fx-from-cases
(-> -Int -One B : (-PS (-is-type 0 -NonPosFixnum) (-is-type 0 -PosFixnum)))
(-> -Int -Zero B : (-PS (-is-type 0 -NegFixnum) (-is-type 0 -NonNegFixnum)))
(-> -Zero -Int B : (-PS (-is-type 1 -PosFixnum) (-is-type 1 -NonPosFixnum)))
(-> -Int -One B : (-FS (-filter -NonPosFixnum 0) (-filter -PosFixnum 0)))
(-> -Int -Zero B : (-FS (-filter -NegFixnum 0) (-filter -NonNegFixnum 0)))
(-> -Zero -Int B : (-FS (-filter -PosFixnum 1) (-filter -NonPosFixnum 1)))
(-> -Byte -PosByte B : (-PS -tt (-is-type 0 -PosByte)))
(-> -Byte -Byte B : (-PS (-is-type 1 -PosByte) -tt))
(-> -Pos -Byte B : (-PS (-and (-is-type 0 -PosByte) (-is-type 1 -PosByte)) -tt))
(-> -Byte -Pos B : (-PS -tt (-and (-is-type 0 -PosByte) (-is-type 1 -PosByte))))
(-> -Byte -Nat B : (-PS -tt (-is-type 1 -Byte)))
(-> -Index -PosIndex B : (-PS -tt (-is-type 0 -PosIndex)))
(-> -Index -Index B : (-PS (-is-type 1 -PosIndex) -tt))
(-> -Pos -Index B : (-PS (-and (-is-type 0 -PosIndex) (-is-type 1 -PosIndex)) -tt))
(-> -Index -Pos B : (-PS -tt (-and (-is-type 0 -PosIndex) (-is-type 1 -PosIndex))))
(-> -Nat -Byte B : (-PS (-and (-is-type 0 -Byte) (-is-type 1 -PosByte)) -tt))
(-> -Nat -Index B : (-PS (-and (-is-type 0 -Index) (-is-type 1 -PosIndex)) -tt))
(-> -Index -Nat B : (-PS -tt (-is-type 1 -Index)))
(-> -Byte -PosByte B : (-FS -top (-filter -PosByte 0)))
(-> -Byte -Byte B : (-FS (-filter -PosByte 1) -top))
(-> -Pos -Byte B : (-FS (-and (-filter -PosByte 0) (-filter -PosByte 1)) -top))
(-> -Byte -Pos B : (-FS -top (-and (-filter -PosByte 0) (-filter -PosByte 1))))
(-> -Byte -Nat B : (-FS -top (-filter -Byte 1)))
(-> -Index -PosIndex B : (-FS -top (-filter -PosIndex 0)))
(-> -Index -Index B : (-FS (-filter -PosIndex 1) -top))
(-> -Pos -Index B : (-FS (-and (-filter -PosIndex 0) (-filter -PosIndex 1)) -top))
(-> -Index -Pos B : (-FS -top (-and (-filter -PosIndex 0) (-filter -PosIndex 1))))
(-> -Nat -Byte B : (-FS (-and (-filter -Byte 0) (-filter -PosByte 1)) -top))
(-> -Nat -Index B : (-FS (-and (-filter -Index 0) (-filter -PosIndex 1)) -top))
(-> -Index -Nat B : (-FS -top (-filter -Index 1)))
;; general integer cases
(-> -Int -PosInt B : (-PS -tt (-is-type 0 -PosFixnum)))
(-> -Int -Nat B : (-PS -tt (-is-type 0 -NonNegFixnum)))
(-> -Nat -Int B : (-PS (-is-type 1 -PosFixnum) -tt))
(-> -Int -NonPosInt B : (-PS (-is-type 0 -NegFixnum) -tt))
(-> -NegInt -Int B : (-PS -tt (-is-type 1 -NegFixnum)))
(-> -NonPosInt -Int B : (-PS -tt (-is-type 1 -NonPosFixnum)))
(-> -Int -PosInt B : (-FS -top (-filter -PosFixnum 0)))
(-> -Int -Nat B : (-FS -top (-filter -NonNegFixnum 0)))
(-> -Nat -Int B : (-FS (-filter -PosFixnum 1) -top))
(-> -Int -NonPosInt B : (-FS (-filter -NegFixnum 0) -top))
(-> -NegInt -Int B : (-FS -top (-filter -NegFixnum 1)))
(-> -NonPosInt -Int B : (-FS -top (-filter -NonPosFixnum 1)))
(comp -Int))))
(define fx>-type
(lambda ()
(fx-from-cases
(-> -One -Int B : (-PS (-is-type 1 -NonPosFixnum) (-is-type 1 -PosFixnum)))
(-> -Zero -Int B : (-PS (-is-type 1 -NegFixnum) (-is-type 1 -NonNegFixnum)))
(-> -Int -Zero B : (-PS (-is-type 0 -PosFixnum) (-is-type 0 -NonPosFixnum)))
(-> -One -Int B : (-FS (-filter -NonPosFixnum 1) (-filter -PosFixnum 1)))
(-> -Zero -Int B : (-FS (-filter -NegFixnum 1) (-filter -NonNegFixnum 1)))
(-> -Int -Zero B : (-FS (-filter -PosFixnum 0) (-filter -NonPosFixnum 0)))
(-> -PosByte -Byte B : (-PS -tt (-is-type 1 -PosByte)))
(-> -Byte -Byte B : (-PS (-is-type 0 -PosByte) -tt))
(-> -Byte -Pos B : (-PS (-and (-is-type 0 -PosByte) (-is-type 1 -PosByte)) -tt))
(-> -Pos -Byte B : (-PS -tt (-and (-is-type 0 -PosByte) (-is-type 1 -PosByte))))
(-> -Byte -Nat B : (-PS (-and (-is-type 0 -PosByte) (-is-type 1 -Byte)) -tt))
(-> -PosIndex -Index B : (-PS -tt (-is-type 1 -PosIndex)))
(-> -Index -Index B : (-PS (-is-type 0 -PosIndex) -tt))
(-> -Index -Pos B : (-PS (-and (-is-type 0 -PosIndex) (-is-type 1 -PosIndex)) -tt))
(-> -Pos -Index B : (-PS -tt (-and (-is-type 0 -PosIndex) (-is-type 1 -PosIndex))))
(-> -Index -Nat B : (-PS (-and (-is-type 0 -PosIndex) (-is-type 1 -Index)) -tt))
(-> -Nat -Byte B : (-PS -tt (-is-type 0 -Byte)))
(-> -Nat -Index B : (-PS -tt (-is-type 0 -Index)))
(-> -PosByte -Byte B : (-FS -top (-filter -PosByte 1)))
(-> -Byte -Byte B : (-FS (-filter -PosByte 0) -top))
(-> -Byte -Pos B : (-FS (-and (-filter -PosByte 0) (-filter -PosByte 1)) -top))
(-> -Pos -Byte B : (-FS -top (-and (-filter -PosByte 0) (-filter -PosByte 1))))
(-> -Byte -Nat B : (-FS (-and (-filter -PosByte 0) (-filter -Byte 1)) -top))
(-> -PosIndex -Index B : (-FS -top (-filter -PosIndex 1)))
(-> -Index -Index B : (-FS (-filter -PosIndex 0) -top))
(-> -Index -Pos B : (-FS (-and (-filter -PosIndex 0) (-filter -PosIndex 1)) -top))
(-> -Pos -Index B : (-FS -top (-and (-filter -PosIndex 0) (-filter -PosIndex 1))))
(-> -Index -Nat B : (-FS (-and (-filter -PosIndex 0) (-filter -Index 1)) -top))
(-> -Nat -Byte B : (-FS -top (-filter -Byte 0)))
(-> -Nat -Index B : (-FS -top (-filter -Index 0)))
;; general integer cases
(-> -PosInt -Int B : (-PS -tt (-is-type 1 -PosFixnum)))
(-> -Nat -Int B : (-PS -tt (-is-type 1 -NonNegFixnum)))
(-> -Int -Nat B : (-PS (-is-type 0 -PosFixnum) -tt))
(-> -NonPosInt -Int B : (-PS (-is-type 1 -NegFixnum) -tt))
(-> -Int -NegInt B : (-PS -tt (-is-type 0 -NegFixnum)))
(-> -Int -NonPosInt B : (-PS -tt (-is-type 0 -NonPosFixnum)))
(-> -PosInt -Int B : (-FS -top (-filter -PosFixnum 1)))
(-> -Nat -Int B : (-FS -top (-filter -NonNegFixnum 1)))
(-> -Int -Nat B : (-FS (-filter -PosFixnum 0) -top))
(-> -NonPosInt -Int B : (-FS (-filter -NegFixnum 1) -top))
(-> -Int -NegInt B : (-FS -top (-filter -NegFixnum 0)))
(-> -Int -NonPosInt B : (-FS -top (-filter -NonPosFixnum 0)))
(comp -Int))))
(define fx<=-type
(lambda ()
(fx-from-cases
(-> -Int -One B : (-PS (-is-type 0 (Un -NonPosFixnum -One)) (-is-type 0 -PosFixnum)))
(-> -One -Int B : (-PS (-is-type 1 -PosFixnum) (-is-type 1 -NonPosFixnum)))
(-> -Int -Zero B : (-PS (-is-type 0 -NonPosFixnum) (-is-type 0 -PosFixnum)))
(-> -Zero -Int B : (-PS (-is-type 1 -NonNegFixnum) (-is-type 1 -NegFixnum)))
(-> -Int -One B : (-FS (-filter (Un -NonPosFixnum -One) 0) (-filter -PosFixnum 0)))
(-> -One -Int B : (-FS (-filter -PosFixnum 1) (-filter -NonPosFixnum 1)))
(-> -Int -Zero B : (-FS (-filter -NonPosFixnum 0) (-filter -PosFixnum 0)))
(-> -Zero -Int B : (-FS (-filter -NonNegFixnum 1) (-filter -NegFixnum 1)))
(-> -PosByte -Byte B : (-PS (-is-type 1 -PosByte) -tt))
(-> -Byte -Byte B : (-PS -tt (-is-type 0 -PosByte)))
(-> -Pos -Byte B : (-PS (-and (-is-type 0 -PosByte) (-is-type 1 -PosByte)) -tt))
(-> -Byte -Pos B : (-PS -tt (-and (-is-type 0 -PosByte) (-is-type 1 -PosByte))))
(-> -Byte -Nat B : (-PS -tt (-and (-is-type 0 -PosByte) (-is-type 1 -Byte))))
(-> -PosIndex -Index B : (-PS (-is-type 1 -PosIndex) -tt))
(-> -Index -Index B : (-PS -tt (-is-type 0 -PosIndex)))
(-> -Pos -Index B : (-PS (-and (-is-type 0 -PosIndex) (-is-type 1 -PosIndex)) -tt))
(-> -Index -Pos B : (-PS -tt (-and (-is-type 0 -PosIndex) (-is-type 1 -PosIndex))))
(-> -Nat -Byte B : (-PS (-is-type 0 -Byte) -tt))
(-> -Nat -Index B : (-PS (-is-type 0 -Index) -tt))
(-> -Index -Nat B : (-PS -tt (-and (-is-type 0 -PosIndex) (-is-type 1 -Index))))
(-> -PosByte -Byte B : (-FS (-filter -PosByte 1) -top))
(-> -Byte -Byte B : (-FS -top (-filter -PosByte 0)))
(-> -Pos -Byte B : (-FS (-and (-filter -PosByte 0) (-filter -PosByte 1)) -top))
(-> -Byte -Pos B : (-FS -top (-and (-filter -PosByte 0) (-filter -PosByte 1))))
(-> -Byte -Nat B : (-FS -top (-and (-filter -PosByte 0) (-filter -Byte 1))))
(-> -PosIndex -Index B : (-FS (-filter -PosIndex 1) -top))
(-> -Index -Index B : (-FS -top (-filter -PosIndex 0)))
(-> -Pos -Index B : (-FS (-and (-filter -PosIndex 0) (-filter -PosIndex 1)) -top))
(-> -Index -Pos B : (-FS -top (-and (-filter -PosIndex 0) (-filter -PosIndex 1))))
(-> -Nat -Byte B : (-FS (-filter -Byte 0) -top))
(-> -Nat -Index B : (-FS (-filter -Index 0) -top))
(-> -Index -Nat B : (-FS -top (-and (-filter -PosIndex 0) (-filter -Index 1))))
;; general integer cases
(-> -PosInt -Int B : (-PS (-is-type 1 -PosFixnum) -tt))
(-> -Int -Nat B : (-PS -tt (-is-type 0 -PosFixnum)))
(-> -Nat -Int B : (-PS (-is-type 1 -NonNegFixnum) -tt))
(-> -Int -NegInt B : (-PS (-is-type 0 -NegFixnum) -tt))
(-> -Int -NonPosInt B : (-PS (-is-type 0 -NonPosFixnum) -tt))
(-> -NonPosInt -Int B : (-PS -tt (-is-type 1 -NegFixnum)))
(-> -PosInt -Int B : (-FS (-filter -PosFixnum 1) -top))
(-> -Int -Nat B : (-FS -top (-filter -PosFixnum 0)))
(-> -Nat -Int B : (-FS (-filter -NonNegFixnum 1) -top))
(-> -Int -NegInt B : (-FS (-filter -NegFixnum 0) -top))
(-> -Int -NonPosInt B : (-FS (-filter -NonPosFixnum 0) -top))
(-> -NonPosInt -Int B : (-FS -top (-filter -NegFixnum 1)))
(comp -Int))))
(define fx>=-type
(lambda ()
(fx-from-cases
(-> -One -Int B : (-PS (-is-type 1 (Un -One -NonPosInt)) (-is-type 1 -PosFixnum)))
(-> -Int -One B : (-PS (-is-type 0 -PosFixnum) (-is-type 0 -NonPosFixnum)))
(-> -Zero -Int B : (-PS (-is-type 1 -NonPosFixnum) (-is-type 1 -PosFixnum)))
(-> -Int -Zero B : (-PS (-is-type 0 -NonNegFixnum) (-is-type 0 -NegFixnum)))
(-> -One -Int B : (-FS (-filter (Un -One -NonPosInt) 1) (-filter -PosFixnum 1)))
(-> -Int -One B : (-FS (-filter -PosFixnum 0) (-filter -NonPosFixnum 0)))
(-> -Zero -Int B : (-FS (-filter -NonPosFixnum 1) (-filter -PosFixnum 1)))
(-> -Int -Zero B : (-FS (-filter -NonNegFixnum 0) (-filter -NegFixnum 0)))
(-> -Byte -PosByte B : (-PS (-is-type 0 -PosByte) -tt))
(-> -Byte -Byte B : (-PS -tt (-is-type 1 -PosByte)))
(-> -Byte -Pos B : (-PS (-and (-is-type 1 -PosByte) (-is-type 0 -PosByte)) -tt))
(-> -Pos -Byte B : (-PS -tt (-and (-is-type 1 -PosByte) (-is-type 0 -PosByte))))
(-> -Byte -Nat B : (-PS (-is-type 1 -Byte) -tt))
(-> -Zero -Index B : (-PS (-is-type 1 -Zero) (-is-type 1 -PosIndex)))
(-> -Index -PosIndex B : (-PS (-is-type 0 -PosIndex) -tt))
(-> -Index -Index B : (-PS -tt (-is-type 1 -PosIndex)))
(-> -Index -Pos B : (-PS (-and (-is-type 0 -PosIndex) (-is-type 1 -PosIndex)) -tt))
(-> -Pos -Index B : (-PS -tt (-and (-is-type 0 -PosIndex) (-is-type 1 -PosIndex))))
(-> -Index -Nat B : (-PS (-is-type 1 -Index) -tt))
(-> -Nat -Byte B : (-PS -tt (-and (-is-type 0 -Byte) (-is-type 1 -PosByte))))
(-> -Nat -Index B : (-PS -tt (-and (-is-type 0 -Index) (-is-type 1 -PosIndex))))
(-> -Byte -PosByte B : (-FS (-filter -PosByte 0) -top))
(-> -Byte -Byte B : (-FS -top (-filter -PosByte 1)))
(-> -Byte -Pos B : (-FS (-and (-filter -PosByte 1) (-filter -PosByte 0)) -top))
(-> -Pos -Byte B : (-FS -top (-and (-filter -PosByte 1) (-filter -PosByte 0))))
(-> -Byte -Nat B : (-FS (-filter -Byte 1) -top))
(-> -Zero -Index B : (-FS (-filter -Zero 1) (-filter -PosIndex 1)))
(-> -Index -PosIndex B : (-FS (-filter -PosIndex 0) -top))
(-> -Index -Index B : (-FS -top (-filter -PosIndex 1)))
(-> -Index -Pos B : (-FS (-and (-filter -PosIndex 0) (-filter -PosIndex 1)) -top))
(-> -Pos -Index B : (-FS -top (-and (-filter -PosIndex 0) (-filter -PosIndex 1))))
(-> -Index -Nat B : (-FS (-filter -Index 1) -top))
(-> -Nat -Byte B : (-FS -top (-and (-filter -Byte 0) (-filter -PosByte 1))))
(-> -Nat -Index B : (-FS -top (-and (-filter -Index 0) (-filter -PosIndex 1))))
;; general integer cases
(-> -Int -PosInt B : (-PS (-is-type 0 -PosFixnum) -tt))
(-> -Nat -Int B : (-PS -tt (-is-type 1 -PosFixnum)))
(-> -Int -Nat B : (-PS (-is-type 0 -NonNegFixnum) -tt))
(-> -NegInt -Int B : (-PS (-is-type 1 -NegFixnum) -tt))
(-> -NonPosInt -Int B : (-PS (-is-type 1 -NonPosFixnum) -tt))
(-> -Int -NonPosInt B : (-PS -tt (-is-type 0 -NegFixnum)))
(-> -Int -PosInt B : (-FS (-filter -PosFixnum 0) -top))
(-> -Nat -Int B : (-FS -top (-filter -PosFixnum 1)))
(-> -Int -Nat B : (-FS (-filter -NonNegFixnum 0) -top))
(-> -NegInt -Int B : (-FS (-filter -NegFixnum 1) -top))
(-> -NonPosInt -Int B : (-FS (-filter -NonPosFixnum 1) -top))
(-> -Int -NonPosInt B : (-FS -top (-filter -NegFixnum 0)))
(comp -Int))))
(define fxmin-type
(lambda ()
(fx-from-cases
(-> -Nat -NonPosInt -NonPosFixnum : -true-propset : (-arg-path 1))
(-> -NonPosInt -Nat -NonPosFixnum : -true-propset : (-arg-path 0))
(-> -Nat -NonPosInt -NonPosFixnum : -true-filter : (-arg-path 1))
(-> -NonPosInt -Nat -NonPosFixnum : -true-filter : (-arg-path 0))
(-> -Zero -Int -NonPosFixnum)
(-> -Int -Zero -NonPosFixnum)
@ -335,8 +335,8 @@
(define fxmax-type
(lambda ()
(fx-from-cases
(-> -NonPosInt -Nat -NonNegFixnum : -true-propset : (-arg-path 1))
(-> -Nat -NonPosInt -NonNegFixnum : -true-propset : (-arg-path 0))
(-> -NonPosInt -Nat -NonNegFixnum : -true-filter : (-arg-path 1))
(-> -Nat -NonPosInt -NonNegFixnum : -true-filter : (-arg-path 0))
(-> -Zero -Int -NonNegFixnum)
(-> -Int -Zero -NonNegFixnum)
@ -360,8 +360,8 @@
(define fxior-type
(lambda ()
(fx-from-cases
(-> -Zero -Int -Fixnum : -true-propset : (-arg-path 1))
(-> -Int -Zero -Fixnum : -true-propset : (-arg-path 0))
(-> -Zero -Int -Fixnum : -true-filter : (-arg-path 1))
(-> -Int -Zero -Fixnum : -true-filter : (-arg-path 0))
(commutative-binop -PosByte -Byte -PosByte)
(binop -Byte)
@ -374,8 +374,8 @@
(define fxxor-type
(lambda ()
(fx-from-cases
(-> -Zero -Int -Fixnum : -true-propset : (-arg-path 1))
(-> -Int -Zero -Fixnum : -true-propset : (-arg-path 0))
(-> -Zero -Int -Fixnum : -true-filter : (-arg-path 1))
(-> -Int -Zero -Fixnum : -true-filter : (-arg-path 0))
(binop -One -Zero)
(binop -Byte)
@ -394,7 +394,7 @@
(define fxlshift-type
(lambda ()
(fx-from-cases
(-> -Int -Zero -Fixnum : -true-propset : (-arg-path 0))
(-> -Int -Zero -Fixnum : -true-filter : (-arg-path 0))
(-> -PosInt -Int -PosFixnum) ; negative 2nd arg errors, so we can't reach 0
(-> -Nat -Int -NonNegFixnum)
(-> -NegInt -Int -NegFixnum)
@ -403,7 +403,7 @@
(define fxrshift-type
(lambda ()
(fx-from-cases
(-> -Int -Zero -Fixnum : -true-propset : (-arg-path 0))
(-> -Int -Zero -Fixnum : -true-filter : (-arg-path 0))
(-> -Nat -Int -NonNegFixnum) ; can reach 0
(-> -NegInt -Int -NegFixnum) ; can't reach 0
(-> -NonPosInt -Int -NonPosFixnum)
@ -495,8 +495,8 @@
(binop -Fl))))
(define fl=-type
(fl-type-lambda
(from-cases (commutative-equality/strict-prop -Fl (Un -FlPosZero -FlNegZero))
(map (lambda (t) (commutative-equality/prop -Fl t))
(from-cases (commutative-equality/strict-filter -Fl (Un -FlPosZero -FlNegZero))
(map (lambda (t) (commutative-equality/filter -Fl t))
(list -FlZero -PosFl -NonNegFl
-NegFl -NonPosFl))
(comp -Fl))))
@ -504,30 +504,30 @@
(fl-type-lambda
(from-cases
;; false case, we know nothing, lhs may be NaN. same for all comparison that can involve floats
(-> -NonNegFl -Fl B : (-PS (-is-type 1 -PosFl) -tt))
(-> -Fl -NonPosFl B : (-PS (-is-type 0 -NegFl) -tt))
(-> -NonNegFl -Fl B : (-FS (-filter -PosFl 1) -top))
(-> -Fl -NonPosFl B : (-FS (-filter -NegFl 0) -top))
(comp -Fl))))
(define fl>-type
(fl-type-lambda
(from-cases
(-> -NonPosFl -Fl B : (-PS (-is-type 1 -NegFl) -tt))
(-> -Fl -NonNegFl B : (-PS (-is-type 0 -PosFl) -tt))
(-> -NonPosFl -Fl B : (-FS (-filter -NegFl 1) -top))
(-> -Fl -NonNegFl B : (-FS (-filter -PosFl 0) -top))
(comp -Fl))))
(define fl<=-type
(fl-type-lambda
(from-cases
(-> -PosFl -Fl B : (-PS (-is-type 1 -PosFl) -tt))
(-> -NonNegFl -Fl B : (-PS (-is-type 1 -NonNegFl) -tt))
(-> -Fl -NegFl B : (-PS (-is-type 0 -NegFl) -tt))
(-> -Fl -NonPosFl B : (-PS (-is-type 0 -NonPosFl) -tt))
(-> -PosFl -Fl B : (-FS (-filter -PosFl 1) -top))
(-> -NonNegFl -Fl B : (-FS (-filter -NonNegFl 1) -top))
(-> -Fl -NegFl B : (-FS (-filter -NegFl 0) -top))
(-> -Fl -NonPosFl B : (-FS (-filter -NonPosFl 0) -top))
(comp -Fl))))
(define fl>=-type
(fl-type-lambda
(from-cases
(-> -Fl -PosFl B : (-PS (-is-type 0 -PosFl) -tt))
(-> -Fl -NonNegFl B : (-PS (-is-type 0 -NonNegFl) -tt))
(-> -NegFl -Fl B : (-PS (-is-type 1 -NegFl) -tt))
(-> -NonPosFl -Fl B : (-PS (-is-type 1 -NonPosFl) -tt))
(-> -Fl -PosFl B : (-FS (-filter -PosFl 0) -top))
(-> -Fl -NonNegFl B : (-FS (-filter -NonNegFl 0) -top))
(-> -NegFl -Fl B : (-FS (-filter -NegFl 1) -top))
(-> -NonPosFl -Fl B : (-FS (-filter -NonPosFl 1) -top))
(comp -Fl))))
(define flmin-type
(fl-type-lambda
@ -595,44 +595,44 @@
(define flrandom-type (lambda () (-Pseudo-Random-Generator . -> . -Flonum)))
;; There's a repetitive pattern in the types of each comparison operator.
;; As explained below, this is because props don't do intersections.
;; As explained below, this is because filters don't do intersections.
(define (<-type-pattern base pos non-neg neg non-pos [zero -RealZero])
(list (-> base zero B : (-PS (-is-type 0 neg) (-is-type 0 non-neg)))
(-> zero base B : (-PS (-is-type 1 pos) (-is-type 1 non-pos)))
(-> base -PosReal B : (-PS -tt (-is-type 0 pos)))
(-> base -NonNegReal B : (-PS -tt (-is-type 0 non-neg)))
(-> -NonNegReal base B : (-PS (-is-type 1 pos) -tt))
(-> base -NonPosReal B : (-PS (-is-type 0 neg) -tt))
(-> -NegReal base B : (-PS -tt (-is-type 1 neg)))
(-> -NonPosReal base B : (-PS -tt (-is-type 1 non-pos)))))
(list (-> base zero B : (-FS (-filter neg 0) (-filter non-neg 0)))
(-> zero base B : (-FS (-filter pos 1) (-filter non-pos 1)))
(-> base -PosReal B : (-FS -top (-filter pos 0)))
(-> base -NonNegReal B : (-FS -top (-filter non-neg 0)))
(-> -NonNegReal base B : (-FS (-filter pos 1) -top))
(-> base -NonPosReal B : (-FS (-filter neg 0) -top))
(-> -NegReal base B : (-FS -top (-filter neg 1)))
(-> -NonPosReal base B : (-FS -top (-filter non-pos 1)))))
(define (>-type-pattern base pos non-neg neg non-pos [zero -RealZero])
(list (-> base zero B : (-PS (-is-type 0 pos) (-is-type 0 non-pos)))
(-> zero base B : (-PS (-is-type 1 neg) (-is-type 1 non-neg)))
(-> base -NonNegReal B : (-PS (-is-type 0 pos) -tt))
(-> -PosReal base B : (-PS -tt (-is-type 1 pos)))
(-> -NonNegReal base B : (-PS -tt (-is-type 1 non-neg)))
(-> -NonPosReal base B : (-PS (-is-type 1 neg) -tt))
(-> base -NegReal B : (-PS -tt (-is-type 0 neg)))
(-> base -NonPosReal B : (-PS -tt (-is-type 0 non-pos)))))
;; this is > with flipped props
(list (-> base zero B : (-FS (-filter pos 0) (-filter non-pos 0)))
(-> zero base B : (-FS (-filter neg 1) (-filter non-neg 1)))
(-> base -NonNegReal B : (-FS (-filter pos 0) -top))
(-> -PosReal base B : (-FS -top (-filter pos 1)))
(-> -NonNegReal base B : (-FS -top (-filter non-neg 1)))
(-> -NonPosReal base B : (-FS (-filter neg 1) -top))
(-> base -NegReal B : (-FS -top (-filter neg 0)))
(-> base -NonPosReal B : (-FS -top (-filter non-pos 0)))))
;; this is > with flipped filters
(define (<=-type-pattern base pos non-neg neg non-pos [zero -RealZero])
(list (-> base zero B : (-PS (-is-type 0 non-pos) (-is-type 0 pos)))
(-> zero base B : (-PS (-is-type 1 non-neg) (-is-type 1 neg)))
(-> base -NonNegReal B : (-PS -tt (-is-type 0 pos)))
(-> -PosReal base B : (-PS (-is-type 1 pos) -tt))
(-> -NonNegReal base B : (-PS (-is-type 1 non-neg) -tt))
(-> -NonPosReal base B : (-PS -tt (-is-type 1 neg)))
(-> base -NegReal B : (-PS (-is-type 0 neg) -tt))
(-> base -NonPosReal B : (-PS (-is-type 0 non-pos) -tt))))
(list (-> base zero B : (-FS (-filter non-pos 0) (-filter pos 0)))
(-> zero base B : (-FS (-filter non-neg 1) (-filter neg 1)))
(-> base -NonNegReal B : (-FS -top (-filter pos 0)))
(-> -PosReal base B : (-FS (-filter pos 1) -top))
(-> -NonNegReal base B : (-FS (-filter non-neg 1) -top))
(-> -NonPosReal base B : (-FS -top (-filter neg 1)))
(-> base -NegReal B : (-FS (-filter neg 0) -top))
(-> base -NonPosReal B : (-FS (-filter non-pos 0) -top))))
(define (>=-type-pattern base pos non-neg neg non-pos [zero -RealZero])
(list (-> base zero B : (-PS (-is-type 0 non-neg) (-is-type 0 neg)))
(-> zero base B : (-PS (-is-type 1 non-pos) (-is-type 1 pos)))
(-> base -PosReal B : (-PS (-is-type 0 pos) -tt))
(-> base -NonNegReal B : (-PS (-is-type 0 non-neg) -tt))
(-> -NonNegReal base B : (-PS -tt (-is-type 1 pos)))
(-> base -NonPosReal B : (-PS -tt (-is-type 0 neg)))
(-> -NegReal base B : (-PS (-is-type 1 neg) -tt))
(-> -NonPosReal base B : (-PS (-is-type 1 non-pos) -tt))))
(list (-> base zero B : (-FS (-filter non-neg 0) (-filter neg 0)))
(-> zero base B : (-FS (-filter non-pos 1) (-filter pos 1)))
(-> base -PosReal B : (-FS (-filter pos 0) -top))
(-> base -NonNegReal B : (-FS (-filter non-neg 0) -top))
(-> -NonNegReal base B : (-FS -top (-filter pos 1)))
(-> base -NonPosReal B : (-FS -top (-filter neg 0)))
(-> -NegReal base B : (-FS (-filter neg 1) -top))
(-> -NonPosReal base B : (-FS (-filter non-pos 1) -top))))
(define (negation-pattern pos neg non-neg non-pos)
(list (-> pos neg)
@ -654,7 +654,7 @@
(define abs-cases ; used both for abs and magnitude
(list
;; abs is not the identity on negative zeros.
((Un -Zero -PosReal) . -> . (Un -Zero -PosReal) : -true-propset : (-arg-path 0))
((Un -Zero -PosReal) . -> . (Un -Zero -PosReal) : -true-filter : (-arg-path 0))
;; but we know that we at least get *some* zero, and that it preserves exactness
(map unop (list -FlonumZero -SingleFlonumZero -RealZero))
;; abs may not be closed on fixnums. (abs min-fixnum) is not a fixnum
@ -713,12 +713,12 @@
;; There are 25 values that answer true to zero?. They are either reals, or inexact complexes.
;; Note -RealZero contains NaN and zero? returns #f on it
[zero?
(-> N B : (-PS (-is-type 0 (Un -RealZeroNoNan -InexactComplex -InexactImaginary))
(-not-type 0 -RealZeroNoNan)))]
(-> N B : (-FS (-filter (Un -RealZeroNoNan -InexactComplex -InexactImaginary) 0)
(-not-filter -RealZeroNoNan 0)))]
[number? (make-pred-ty N)]
[integer? (asym-pred Univ B (-PS (-is-type 0 (Un -Int -Flonum -SingleFlonum)) ; inexact-integers exist...
(-not-type 0 -Int)))]
[integer? (asym-pred Univ B (-FS (-filter (Un -Int -Flonum -SingleFlonum) 0) ; inexact-integers exist...
(-not-filter -Int 0)))]
[exact-integer? (make-pred-ty -Int)]
[real? (make-pred-ty -Real)]
[flonum? (make-pred-ty -Flonum)]
@ -727,78 +727,78 @@
[inexact-real? (make-pred-ty -InexactReal)]
[complex? (make-pred-ty N)]
;; `rational?' includes all Reals, except infinities and NaN.
[rational? (asym-pred Univ B (-PS (-is-type 0 -Real) (-not-type 0 -Rat)))]
[rational? (asym-pred Univ B (-FS (-filter -Real 0) (-not-filter -Rat 0)))]
[exact? (make-pred-ty -ExactNumber)]
[inexact? (make-pred-ty (Un -InexactReal -InexactImaginary -InexactComplex))]
[fixnum? (make-pred-ty -Fixnum)]
[index? (make-pred-ty -Index)]
[positive? (-> -Real B : (-PS (-is-type 0 -PosReal) (-is-type 0 -NonPosReal)))]
[negative? (-> -Real B : (-PS (-is-type 0 -NegReal) (-is-type 0 -NonNegReal)))]
[positive? (-> -Real B : (-FS (-filter -PosReal 0) (-filter -NonPosReal 0)))]
[negative? (-> -Real B : (-FS (-filter -NegReal 0) (-filter -NonNegReal 0)))]
[exact-positive-integer? (make-pred-ty -Pos)]
[exact-nonnegative-integer? (make-pred-ty -Nat)]
[odd? (-> -Int B : (-PS (-not-type 0 -Zero) (-not-type 0 -One)))]
[even? (-> -Int B : (-PS (-not-type 0 -One) (-not-type 0 -Zero)))]
[odd? (-> -Int B : (-FS (-not-filter -Zero 0) (-not-filter -One 0)))]
[even? (-> -Int B : (-FS (-not-filter -One 0) (-not-filter -Zero 0)))]
[=
(from-cases
(-> -Real -RealZero B : (-PS (-is-type 0 -RealZeroNoNan) (-not-type 0 -RealZeroNoNan)))
(-> -RealZero -Real B : (-PS (-is-type 1 -RealZeroNoNan) (-not-type 1 -RealZeroNoNan)))
(map (lambda (t) (commutative-equality/prop -ExactNumber t))
(-> -Real -RealZero B : (-FS (-filter -RealZeroNoNan 0) (-not-filter -RealZeroNoNan 0)))
(-> -RealZero -Real B : (-FS (-filter -RealZeroNoNan 1) (-not-filter -RealZeroNoNan 1)))
(map (lambda (t) (commutative-equality/filter -ExactNumber t))
(list -One -PosByte -Byte -PosIndex -Index
-PosFixnum -NonNegFixnum -NegFixnum -NonPosFixnum -Fixnum
-PosInt -Nat -NegInt -NonPosInt -Int
-PosRat -NonNegRat -NegRat -NonPosRat -Rat
-ExactNumber))
;; For all real types: the props give sign information, and the exactness information is preserved
;; For all real types: the filters give sign information, and the exactness information is preserved
;; from the original types.
(map (lambda (t) (commutative-equality/prop -Real t))
(map (lambda (t) (commutative-equality/filter -Real t))
(list -RealZero -PosReal -NonNegReal -NegReal -NonPosReal -Real))
(->* (list N N) N B))]
[< (from-cases
(-> -Int -One B : (-PS (-is-type 0 -NonPosInt) (-is-type 0 -PosInt)))
(-> -Real -Zero B : (-PS (-is-type 0 -NegReal) (-is-type 0 -NonNegReal)))
(-> -Zero -Real B : (-PS (-is-type 1 -PosReal) (-is-type 1 -NonPosReal)))
(-> -Real -RealZero B : (-PS (-is-type 0 -NegReal) -tt)) ;; False says nothing because of NaN
(-> -RealZero -Real B : (-PS (-is-type 1 -PosReal) -tt)) ;; False says nothing because of NaN
(-> -Byte -PosByte B : (-PS -tt (-is-type 0 -PosByte)))
(-> -Byte -Byte B : (-PS (-is-type 1 -PosByte) -tt))
(-> -PosInt -Byte B : (-PS (-and (-is-type 0 -PosByte) (-is-type 1 -PosByte)) -tt))
(-> -PosReal -Byte B : (-PS (-is-type 1 -PosByte) -tt)) ; -PosReal is ok here, no prop for #f
(-> -Byte -PosInt B : (-PS -tt (-and (-is-type 0 -PosByte) (-is-type 1 -PosByte))))
(-> -Byte -PosRat B : (-PS -tt (-is-type 0 -PosByte))) ; can't be -PosReal, which includes NaN
(-> -Nat -Byte B : (-PS (-and (-is-type 0 -Byte) (-is-type 1 -PosByte)) -tt))
(-> -NonNegReal -Byte B : (-PS (-is-type 1 -PosByte) -tt))
(-> -Byte -Nat B : (-PS -tt (-is-type 1 -Byte)))
(-> -Index -PosIndex B : (-PS -tt (-is-type 0 -PosIndex)))
(-> -Index -Index B : (-PS (-is-type 1 -PosIndex) -tt))
(-> -PosInt -Index B : (-PS (-and (-is-type 0 -PosIndex) (-is-type 1 -PosIndex)) -tt))
(-> -PosReal -Index B : (-PS (-is-type 1 -PosIndex) -tt))
(-> -Index -PosInt B : (-PS -tt (-and (-is-type 0 -PosIndex) (-is-type 1 -PosIndex))))
(-> -Index -PosRat B : (-PS -tt (-is-type 0 -PosIndex))) ; can't be -PosReal, which includes NaN
(-> -Nat -Index B : (-PS (-and (-is-type 0 -Index) (-is-type 1 -PosIndex)) -tt))
(-> -NonNegReal -Index B : (-PS (-is-type 1 -PosIndex) -tt))
(-> -Index -Nat B : (-PS -tt (-is-type 1 -Index)))
(-> -Fixnum -PosInt B : (-PS -tt (-and (-is-type 0 -PosFixnum) (-is-type 1 -PosFixnum))))
(-> -Fixnum -PosRat B : (-PS -tt (-is-type 0 -PosFixnum)))
(-> -Fixnum -Nat B : (-PS -tt (-and (-is-type 0 -NonNegFixnum) (-is-type 1 -NonNegFixnum))))
(-> -Fixnum -NonNegRat B : (-PS -tt (-is-type 0 -NonNegFixnum)))
(-> -Nat -Fixnum B : (-PS (-and (-is-type 1 -PosFixnum) (-is-type 0 -NonNegFixnum)) -tt))
(-> -NonNegReal -Fixnum B : (-PS (-is-type 1 -PosFixnum) -tt))
(-> -Fixnum -NonPosInt B : (-PS (-and (-is-type 0 -NegFixnum) (-is-type 1 -NonPosFixnum)) -tt))
(-> -Fixnum -NonPosReal B : (-PS (-is-type 0 -NegFixnum) -tt))
(-> -NegInt -Fixnum B : (-PS -tt (-and (-is-type 0 -NegFixnum) (-is-type 1 -NegFixnum))))
(-> -NegRat -Fixnum B : (-PS -tt (-is-type 1 -NegFixnum)))
(-> -NonPosInt -Fixnum B : (-PS -tt (-and (-is-type 0 -NonPosFixnum) (-is-type 1 -NonPosFixnum))))
(-> -NonPosRat -Fixnum B : (-PS -tt (-is-type 1 -NonPosFixnum)))
(-> -Real -PosInfinity B : (-PS (-not-type 0 (Un -InexactRealNan -PosInfinity))
(-is-type 0 (Un -InexactRealNan -PosInfinity))))
(-> -NegInfinity -Real B : (-PS (-not-type 1 (Un -InexactRealNan -NegInfinity))
(-is-type 1 (Un -InexactRealNan -NegInfinity))))
(-> -PosInfinity -Real B : -false-propset)
(-> -Real -NegInfinity B : -false-propset)
;; If applying props resulted in the interesection of the prop and the
(-> -Int -One B : (-FS (-filter -NonPosInt 0) (-filter -PosInt 0)))
(-> -Real -Zero B : (-FS (-filter -NegReal 0) (-filter -NonNegReal 0)))
(-> -Zero -Real B : (-FS (-filter -PosReal 1) (-filter -NonPosReal 1)))
(-> -Real -RealZero B : (-FS (-filter -NegReal 0) -top)) ;; False says nothing because of NaN
(-> -RealZero -Real B : (-FS (-filter -PosReal 1) -top)) ;; False says nothing because of NaN
(-> -Byte -PosByte B : (-FS -top (-filter -PosByte 0)))
(-> -Byte -Byte B : (-FS (-filter -PosByte 1) -top))
(-> -PosInt -Byte B : (-FS (-and (-filter -PosByte 0) (-filter -PosByte 1)) -top))
(-> -PosReal -Byte B : (-FS (-filter -PosByte 1) -top)) ; -PosReal is ok here, no filter for #f
(-> -Byte -PosInt B : (-FS -top (-and (-filter -PosByte 0) (-filter -PosByte 1))))
(-> -Byte -PosRat B : (-FS -top (-filter -PosByte 0))) ; can't be -PosReal, which includes NaN
(-> -Nat -Byte B : (-FS (-and (-filter -Byte 0) (-filter -PosByte 1)) -top))
(-> -NonNegReal -Byte B : (-FS (-filter -PosByte 1) -top))
(-> -Byte -Nat B : (-FS -top (-filter -Byte 1)))
(-> -Index -PosIndex B : (-FS -top (-filter -PosIndex 0)))
(-> -Index -Index B : (-FS (-filter -PosIndex 1) -top))
(-> -PosInt -Index B : (-FS (-and (-filter -PosIndex 0) (-filter -PosIndex 1)) -top))
(-> -PosReal -Index B : (-FS (-filter -PosIndex 1) -top))
(-> -Index -PosInt B : (-FS -top (-and (-filter -PosIndex 0) (-filter -PosIndex 1))))
(-> -Index -PosRat B : (-FS -top (-filter -PosIndex 0))) ; can't be -PosReal, which includes NaN
(-> -Nat -Index B : (-FS (-and (-filter -Index 0) (-filter -PosIndex 1)) -top))
(-> -NonNegReal -Index B : (-FS (-filter -PosIndex 1) -top))
(-> -Index -Nat B : (-FS -top (-filter -Index 1)))
(-> -Fixnum -PosInt B : (-FS -top (-and (-filter -PosFixnum 0) (-filter -PosFixnum 1))))
(-> -Fixnum -PosRat B : (-FS -top (-filter -PosFixnum 0)))
(-> -Fixnum -Nat B : (-FS -top (-and (-filter -NonNegFixnum 0) (-filter -NonNegFixnum 1))))
(-> -Fixnum -NonNegRat B : (-FS -top (-filter -NonNegFixnum 0)))
(-> -Nat -Fixnum B : (-FS (-and (-filter -PosFixnum 1) (-filter -NonNegFixnum 0)) -top))
(-> -NonNegReal -Fixnum B : (-FS (-filter -PosFixnum 1) -top))
(-> -Fixnum -NonPosInt B : (-FS (-and (-filter -NegFixnum 0) (-filter -NonPosFixnum 1)) -top))
(-> -Fixnum -NonPosReal B : (-FS (-filter -NegFixnum 0) -top))
(-> -NegInt -Fixnum B : (-FS -top (-and (-filter -NegFixnum 0) (-filter -NegFixnum 1))))
(-> -NegRat -Fixnum B : (-FS -top (-filter -NegFixnum 1)))
(-> -NonPosInt -Fixnum B : (-FS -top (-and (-filter -NonPosFixnum 0) (-filter -NonPosFixnum 1))))
(-> -NonPosRat -Fixnum B : (-FS -top (-filter -NonPosFixnum 1)))
(-> -Real -PosInfinity B : (-FS (-not-filter (Un -InexactRealNan -PosInfinity) 0)
(-filter (Un -InexactRealNan -PosInfinity) 0)))
(-> -NegInfinity -Real B : (-FS (-not-filter (Un -InexactRealNan -NegInfinity) 1)
(-filter (Un -InexactRealNan -NegInfinity) 1)))
(-> -PosInfinity -Real B : -false-filter)
(-> -Real -NegInfinity B : -false-filter)
;; If applying filters resulted in the interesection of the filter and the
;; original type, we'd only need the cases for Fixnums and those for Reals.
;; Cases for Integers and co would fall out naturally from the Real cases,
;; since we'd keep track of the representation knowledge we'd already have,
@ -812,47 +812,47 @@
(<-type-pattern -Real -PosReal -NonNegReal -NegReal -NonPosReal)
(->* (list R R) R B))]
[> (from-cases
(-> -One -Int B : (-PS (-is-type 1 -NonPosInt) (-is-type 1 -PosInt)))
(-> -Real -Zero B : (-PS (-is-type 0 -PosReal) (-is-type 0 -NonPosReal)))
(-> -Zero -Real B : (-PS (-is-type 1 -NegReal) (-is-type 1 -NonNegReal)))
(-> -Real -RealZero B : (-PS (-is-type 0 -PosReal) -tt)) ;; False says nothing because of NaN
(-> -RealZero -Real B : (-PS (-is-type 1 -NegReal) -tt)) ;; False says nothing because of NaN
(-> -PosByte -Byte B : (-PS -tt (-is-type 1 -PosByte)))
(-> -Byte -Byte B : (-PS (-is-type 0 -PosByte) -tt))
(-> -Byte -PosInt B : (-PS (-and (-is-type 0 -PosByte) (-is-type 1 -PosByte)) -tt))
(-> -Byte -PosReal B : (-PS (-is-type 0 -PosByte) -tt))
(-> -PosInt -Byte B : (-PS -tt (-and (-is-type 0 -PosByte) (-is-type 1 -PosByte))))
(-> -PosRat -Byte B : (-PS -tt (-is-type 1 -PosByte)))
(-> -Byte -Nat B : (-PS (-and (-is-type 0 -PosByte) (-is-type 1 -Byte)) -tt))
(-> -Byte -NonNegReal B : (-PS (-is-type 0 -PosByte) -tt))
(-> -Nat -Byte B : (-PS -tt (-is-type 0 -Byte)))
(-> -PosIndex -Index B : (-PS -tt (-is-type 1 -PosIndex)))
(-> -Index -Index B : (-PS (-is-type 0 -PosIndex) -tt))
(-> -Index -PosInt B : (-PS (-and (-is-type 0 -PosIndex) (-is-type 1 -PosIndex)) -tt))
(-> -Index -PosReal B : (-PS (-is-type 0 -PosIndex) -tt))
(-> -PosInt -Index B : (-PS -tt (-and (-is-type 0 -PosIndex) (-is-type 1 -PosIndex))))
(-> -PosRat -Index B : (-PS -tt (-is-type 1 -PosIndex)))
(-> -Index -Nat B : (-PS (-and (-is-type 0 -PosIndex) (-is-type 1 -Index)) -tt))
(-> -Index -NonNegReal B : (-PS (-is-type 0 -PosIndex) -tt))
(-> -Nat -Index B : (-PS -tt (-is-type 0 -Index)))
(-> -PosInt -Fixnum B : (-PS -tt (-and (-is-type 0 -PosFixnum) (-is-type 1 -PosFixnum))))
(-> -PosRat -Fixnum B : (-PS -tt (-is-type 1 -PosFixnum)))
(-> -Nat -Fixnum B : (-PS -tt (-and (-is-type 0 -NonNegFixnum) (-is-type 1 -NonNegFixnum))))
(-> -NonNegRat -Fixnum B : (-PS -tt (-is-type 1 -NonNegFixnum)))
(-> -Fixnum -Nat B : (-PS (-and (-is-type 0 -PosFixnum) (-is-type 1 -NonNegFixnum)) -tt))
(-> -Fixnum -NonNegReal B : (-PS (-is-type 0 -PosFixnum) -tt))
(-> -NonPosInt -Fixnum B : (-PS (-and (-is-type 0 -NonPosFixnum) (-is-type 1 -NegFixnum)) -tt))
(-> -NonPosReal -Fixnum B : (-PS (-is-type 1 -NegFixnum) -tt))
(-> -Fixnum -NegInt B : (-PS -tt (-and (-is-type 0 -NegFixnum) (-is-type 1 -NegFixnum))))
(-> -Fixnum -NegRat B : (-PS -tt (-is-type 0 -NegFixnum)))
(-> -Fixnum -NonPosInt B : (-PS -tt (-and (-is-type 0 -NonPosFixnum) (-is-type 1 -NonPosFixnum))))
(-> -Fixnum -NonPosRat B : (-PS -tt (-is-type 0 -NonPosFixnum)))
(-> -PosInfinity -Real B : (-PS (-not-type 1 (Un -InexactRealNan -PosInfinity))
(-is-type 1 (Un -InexactRealNan -PosInfinity))))
(-> -Real -NegInfinity B : (-PS (-not-type 0 (Un -InexactRealNan -NegInfinity))
(-is-type 0 (Un -InexactRealNan -NegInfinity))))
(-> -Real -PosInfinity B : -false-propset)
(-> -NegInfinity -Real B : -false-propset)
(-> -One -Int B : (-FS (-filter -NonPosInt 1) (-filter -PosInt 1)))
(-> -Real -Zero B : (-FS (-filter -PosReal 0) (-filter -NonPosReal 0)))
(-> -Zero -Real B : (-FS (-filter -NegReal 1) (-filter -NonNegReal 1)))
(-> -Real -RealZero B : (-FS (-filter -PosReal 0) -top)) ;; False says nothing because of NaN
(-> -RealZero -Real B : (-FS (-filter -NegReal 1) -top)) ;; False says nothing because of NaN
(-> -PosByte -Byte B : (-FS -top (-filter -PosByte 1)))
(-> -Byte -Byte B : (-FS (-filter -PosByte 0) -top))
(-> -Byte -PosInt B : (-FS (-and (-filter -PosByte 0) (-filter -PosByte 1)) -top))
(-> -Byte -PosReal B : (-FS (-filter -PosByte 0) -top))
(-> -PosInt -Byte B : (-FS -top (-and (-filter -PosByte 0) (-filter -PosByte 1))))
(-> -PosRat -Byte B : (-FS -top (-filter -PosByte 1)))
(-> -Byte -Nat B : (-FS (-and (-filter -PosByte 0) (-filter -Byte 1)) -top))
(-> -Byte -NonNegReal B : (-FS (-filter -PosByte 0) -top))
(-> -Nat -Byte B : (-FS -top (-filter -Byte 0)))
(-> -PosIndex -Index B : (-FS -top (-filter -PosIndex 1)))
(-> -Index -Index B : (-FS (-filter -PosIndex 0) -top))
(-> -Index -PosInt B : (-FS (-and (-filter -PosIndex 0) (-filter -PosIndex 1)) -top))
(-> -Index -PosReal B : (-FS (-filter -PosIndex 0) -top))
(-> -PosInt -Index B : (-FS -top (-and (-filter -PosIndex 0) (-filter -PosIndex 1))))
(-> -PosRat -Index B : (-FS -top (-filter -PosIndex 1)))
(-> -Index -Nat B : (-FS (-and (-filter -PosIndex 0) (-filter -Index 1)) -top))
(-> -Index -NonNegReal B : (-FS (-filter -PosIndex 0) -top))
(-> -Nat -Index B : (-FS -top (-filter -Index 0)))
(-> -PosInt -Fixnum B : (-FS -top (-and (-filter -PosFixnum 0) (-filter -PosFixnum 1))))
(-> -PosRat -Fixnum B : (-FS -top (-filter -PosFixnum 1)))
(-> -Nat -Fixnum B : (-FS -top (-and (-filter -NonNegFixnum 0) (-filter -NonNegFixnum 1))))
(-> -NonNegRat -Fixnum B : (-FS -top (-filter -NonNegFixnum 1)))
(-> -Fixnum -Nat B : (-FS (-and (-filter -PosFixnum 0) (-filter -NonNegFixnum 1)) -top))
(-> -Fixnum -NonNegReal B : (-FS (-filter -PosFixnum 0) -top))
(-> -NonPosInt -Fixnum B : (-FS (-and (-filter -NonPosFixnum 0) (-filter -NegFixnum 1)) -top))
(-> -NonPosReal -Fixnum B : (-FS (-filter -NegFixnum 1) -top))
(-> -Fixnum -NegInt B : (-FS -top (-and (-filter -NegFixnum 0) (-filter -NegFixnum 1))))
(-> -Fixnum -NegRat B : (-FS -top (-filter -NegFixnum 0)))
(-> -Fixnum -NonPosInt B : (-FS -top (-and (-filter -NonPosFixnum 0) (-filter -NonPosFixnum 1))))
(-> -Fixnum -NonPosRat B : (-FS -top (-filter -NonPosFixnum 0)))
(-> -PosInfinity -Real B : (-FS (-not-filter (Un -InexactRealNan -PosInfinity) 1)
(-filter (Un -InexactRealNan -PosInfinity) 1)))
(-> -Real -NegInfinity B : (-FS (-not-filter (Un -InexactRealNan -NegInfinity) 0)
(-filter (Un -InexactRealNan -NegInfinity) 0)))
(-> -Real -PosInfinity B : -false-filter)
(-> -NegInfinity -Real B : -false-filter)
(>-type-pattern -Int -PosInt -Nat -NegInt -NonPosInt -Zero)
(>-type-pattern -Rat -PosRat -NonNegRat -NegRat -NonPosRat -Zero)
(>-type-pattern -Flonum -PosFlonum -NonNegFlonum -NegFlonum -NonPosFlonum)
@ -861,46 +861,46 @@
(>-type-pattern -Real -PosReal -NonNegReal -NegReal -NonPosReal)
(->* (list R R) R B))]
[<= (from-cases
(-> -Int -One B : (-PS (-is-type 0 (Un -NonPosInt -One)) (-is-type 0 -PosInt)))
(-> -One -Int B : (-PS (-is-type 1 -PosInt) (-is-type 1 -NonPosInt)))
(-> -Real -Zero B : (-PS (-is-type 0 -NonPosReal) (-is-type 0 -PosReal)))
(-> -Zero -Real B : (-PS (-is-type 1 -NonNegReal) (-is-type 1 -NegReal)))
(-> -Real -RealZero B : (-PS (-is-type 0 -NonPosReal) -tt)) ;; False says nothing because of NaN
(-> -RealZero -Real B : (-PS (-is-type 0 -NonNegReal) -tt)) ;; False says nothing because of NaN
(-> -PosByte -Byte B : (-PS (-is-type 1 -PosByte) -tt))
(-> -Byte -Byte B : (-PS -tt (-is-type 0 -PosByte)))
(-> -PosInt -Byte B : (-PS (-and (-is-type 0 -PosByte) (-is-type 1 -PosByte)) -tt))
(-> -PosReal -Byte B : (-PS (-is-type 1 -PosByte) -tt))
(-> -Byte -PosInt B : (-PS -tt (-and (-is-type 0 -PosByte) (-is-type 1 -PosByte))))
(-> -Byte -PosRat B : (-PS -tt (-is-type 0 -PosByte)))
(-> -Nat -Byte B : (-PS (-is-type 0 -Byte) -tt))
(-> -Byte -Nat B : (-PS -tt (-and (-is-type 0 -PosByte) (-is-type 1 -Byte))))
(-> -Byte -NonNegRat B : (-PS -tt (-is-type 0 -PosByte)))
(-> -PosIndex -Index B : (-PS (-is-type 1 -PosIndex) -tt))
(-> -Index -Index B : (-PS -tt (-is-type 0 -PosIndex)))
(-> -Pos -Index B : (-PS (-and (-is-type 0 -PosIndex) (-is-type 1 -PosIndex)) -tt))
(-> -PosReal -Index B : (-PS (-is-type 1 -PosIndex) -tt))
(-> -Index -Pos B : (-PS -tt (-and (-is-type 0 -PosIndex) (-is-type 1 -PosIndex))))
(-> -Index -PosRat B : (-PS -tt (-is-type 0 -PosIndex)))
(-> -Nat -Index B : (-PS (-is-type 0 -Index) -tt))
(-> -Index -Nat B : (-PS -tt (-and (-is-type 0 -PosIndex) (-is-type 1 -Index))))
(-> -Index -NonNegRat B : (-PS -tt (-is-type 0 -PosIndex)))
(-> -PosInt -Fixnum B : (-PS (-and (-is-type 0 -PosFixnum) (-is-type 1 -PosFixnum)) -tt))
(-> -PosReal -Fixnum B : (-PS (-is-type 1 -PosFixnum) -tt))
(-> -Nat -Fixnum B : (-PS (-and (-is-type 0 -NonNegFixnum) (-is-type 1 -NonNegFixnum)) -tt))
(-> -NonNegReal -Fixnum B : (-PS (-is-type 1 -NonNegFixnum) -tt))
(-> -Fixnum -Nat B : (-PS -tt (-and (-is-type 0 -PosFixnum) (-is-type 1 -NonNegFixnum))))
(-> -Fixnum -NonNegRat B : (-PS -tt (-is-type 0 -PosFixnum)))
(-> -NonPosInt -Fixnum B : (-PS -tt (-and (-is-type 0 -NonPosFixnum) (-is-type 1 -NegFixnum))))
(-> -NonPosRat -Fixnum B : (-PS -tt (-is-type 1 -NegFixnum)))
(-> -Fixnum -NegInt B : (-PS (-and (-is-type 0 -NegFixnum) (-is-type 1 -NegFixnum)) -tt))
(-> -Fixnum -NegReal B : (-PS (-is-type 0 -NegFixnum) -tt))
(-> -Fixnum -NonPosInt B : (-PS (-and (-is-type 0 -NonPosFixnum) (-is-type 1 -NonPosFixnum)) -tt))
(-> -Fixnum -NonPosReal B : (-PS (-is-type 0 -NonPosFixnum) -tt))
(-> -Real -PosInfinity B : (-PS (-not-type 0 -InexactRealNan) (-is-type 0 -InexactRealNan)))
(-> -NegInfinity -Real B : (-PS (-not-type 1 -InexactRealNan) (-is-type 1 -InexactRealNan)))
(-> -PosInfinity -Real B : (-PS (-is-type 1 -PosInfinity) (-not-type 1 -PosInfinity)))
(-> -Real -NegInfinity B : (-PS (-is-type 0 -NegInfinity) (-not-type 0 -NegInfinity)))
(-> -Int -One B : (-FS (-filter (Un -NonPosInt -One) 0) (-filter -PosInt 0)))
(-> -One -Int B : (-FS (-filter -PosInt 1) (-filter -NonPosInt 1)))
(-> -Real -Zero B : (-FS (-filter -NonPosReal 0) (-filter -PosReal 0)))
(-> -Zero -Real B : (-FS (-filter -NonNegReal 1) (-filter -NegReal 1)))
(-> -Real -RealZero B : (-FS (-filter -NonPosReal 0) -top)) ;; False says nothing because of NaN
(-> -RealZero -Real B : (-FS (-filter -NonNegReal 0) -top)) ;; False says nothing because of NaN
(-> -PosByte -Byte B : (-FS (-filter -PosByte 1) -top))
(-> -Byte -Byte B : (-FS -top (-filter -PosByte 0)))
(-> -PosInt -Byte B : (-FS (-and (-filter -PosByte 0) (-filter -PosByte 1)) -top))
(-> -PosReal -Byte B : (-FS (-filter -PosByte 1) -top))
(-> -Byte -PosInt B : (-FS -top (-and (-filter -PosByte 0) (-filter -PosByte 1))))
(-> -Byte -PosRat B : (-FS -top (-filter -PosByte 0)))
(-> -Nat -Byte B : (-FS (-filter -Byte 0) -top))
(-> -Byte -Nat B : (-FS -top (-and (-filter -PosByte 0) (-filter -Byte 1))))
(-> -Byte -NonNegRat B : (-FS -top (-filter -PosByte 0)))
(-> -PosIndex -Index B : (-FS (-filter -PosIndex 1) -top))
(-> -Index -Index B : (-FS -top (-filter -PosIndex 0)))
(-> -Pos -Index B : (-FS (-and (-filter -PosIndex 0) (-filter -PosIndex 1)) -top))
(-> -PosReal -Index B : (-FS (-filter -PosIndex 1) -top))
(-> -Index -Pos B : (-FS -top (-and (-filter -PosIndex 0) (-filter -PosIndex 1))))
(-> -Index -PosRat B : (-FS -top (-filter -PosIndex 0)))
(-> -Nat -Index B : (-FS (-filter -Index 0) -top))
(-> -Index -Nat B : (-FS -top (-and (-filter -PosIndex 0) (-filter -Index 1))))
(-> -Index -NonNegRat B : (-FS -top (-filter -PosIndex 0)))
(-> -PosInt -Fixnum B : (-FS (-and (-filter -PosFixnum 0) (-filter -PosFixnum 1)) -top))
(-> -PosReal -Fixnum B : (-FS (-filter -PosFixnum 1) -top))
(-> -Nat -Fixnum B : (-FS (-and (-filter -NonNegFixnum 0) (-filter -NonNegFixnum 1)) -top))
(-> -NonNegReal -Fixnum B : (-FS (-filter -NonNegFixnum 1) -top))
(-> -Fixnum -Nat B : (-FS -top (-and (-filter -PosFixnum 0) (-filter -NonNegFixnum 1))))
(-> -Fixnum -NonNegRat B : (-FS -top (-filter -PosFixnum 0)))
(-> -NonPosInt -Fixnum B : (-FS -top (-and (-filter -NonPosFixnum 0) (-filter -NegFixnum 1))))
(-> -NonPosRat -Fixnum B : (-FS -top (-filter -NegFixnum 1)))
(-> -Fixnum -NegInt B : (-FS (-and (-filter -NegFixnum 0) (-filter -NegFixnum 1)) -top))
(-> -Fixnum -NegReal B : (-FS (-filter -NegFixnum 0) -top))
(-> -Fixnum -NonPosInt B : (-FS (-and (-filter -NonPosFixnum 0) (-filter -NonPosFixnum 1)) -top))
(-> -Fixnum -NonPosReal B : (-FS (-filter -NonPosFixnum 0) -top))
(-> -Real -PosInfinity B : (-FS (-not-filter -InexactRealNan 0) (-filter -InexactRealNan 0)))
(-> -NegInfinity -Real B : (-FS (-not-filter -InexactRealNan 1) (-filter -InexactRealNan 1)))
(-> -PosInfinity -Real B : (-FS (-filter -PosInfinity 1) (-not-filter -PosInfinity 1)))
(-> -Real -NegInfinity B : (-FS (-filter -NegInfinity 0) (-not-filter -NegInfinity 0)))
(<=-type-pattern -Int -PosInt -Nat -NegInt -NonPosInt -Zero)
(<=-type-pattern -Rat -PosRat -NonNegRat -NegRat -NonPosRat -Zero)
(<=-type-pattern -Flonum -PosFlonum -NonNegFlonum -NegFlonum -NonPosFlonum)
@ -909,46 +909,46 @@
(<=-type-pattern -Real -PosReal -NonNegReal -NegReal -NonPosReal)
(->* (list R R) R B))]
[>= (from-cases
(-> -One -Int B : (-PS (-is-type 1 (Un -One -NonPosInt)) (-is-type 1 -PosInt)))
(-> -Int -One B : (-PS (-is-type 0 -PosInt) (-is-type 0 -NonPosInt)))
(-> -Real -Zero B : (-PS (-is-type 0 -NonNegReal) (-is-type 0 -NegReal)))
(-> -Zero -Real B : (-PS (-is-type 1 -NonPosReal) (-is-type 1 -PosReal)))
(-> -Real -RealZero B : (-PS (-is-type 0 -NonNegReal) -tt)) ;; False says nothing because of NaN
(-> -RealZero -Real B : (-PS (-is-type 0 -NonPosReal) -tt)) ;; False says nothing because of NaN
(-> -Byte -PosByte B : (-PS (-is-type 0 -PosByte) -tt))
(-> -Byte -Byte B : (-PS -tt (-is-type 1 -PosByte)))
(-> -Byte -PosInt B : (-PS (-and (-is-type 0 -PosByte) (-is-type 1 -PosByte)) -tt))
(-> -Byte -PosReal B : (-PS (-is-type 0 -PosByte) -tt))
(-> -PosInt -Byte B : (-PS -tt (-and (-is-type 0 -PosByte) (-is-type 1 -PosByte))))
(-> -PosRat -Byte B : (-PS -tt (-is-type 1 -PosByte)))
(-> -Byte -Nat B : (-PS (-is-type 1 -Byte) -tt))
(-> -Nat -Byte B : (-PS -tt (-and (-is-type 0 -Byte) (-is-type 1 -PosByte))))
(-> -NonNegRat -Byte B : (-PS -tt (-is-type 1 -PosByte)))
(-> -Index -PosIndex B : (-PS (-is-type 0 -PosIndex) -tt))
(-> -Index -Index B : (-PS -tt (-is-type 1 -PosIndex)))
(-> -Index -Pos B : (-PS (-and (-is-type 0 -PosIndex) (-is-type 1 -PosIndex)) -tt))
(-> -Index -PosReal B : (-PS (-is-type 0 -PosIndex) -tt))
(-> -Pos -Index B : (-PS -tt (-and (-is-type 0 -PosIndex) (-is-type 1 -PosIndex))))
(-> -PosRat -Index B : (-PS -tt (-is-type 1 -PosIndex)))
(-> -Index -Nat B : (-PS (-is-type 1 -Index) -tt))
(-> -Nat -Index B : (-PS -tt (-and (-is-type 0 -Index) (-is-type 1 -PosIndex))))
(-> -NonNegRat -Index B : (-PS -tt (-is-type 1 -PosIndex)))
(-> -Fixnum -PosInt B : (-PS (-and (-is-type 0 -PosFixnum) (-is-type 1 -PosFixnum)) -tt))
(-> -Fixnum -PosReal B : (-PS (-is-type 0 -PosFixnum) -tt))
(-> -Fixnum -Nat B : (-PS (-and (-is-type 0 -NonNegFixnum) (-is-type 1 -NonNegFixnum)) -tt))
(-> -Fixnum -NonNegReal B : (-PS (-is-type 0 -NonNegFixnum) -tt))
(-> -Nat -Fixnum B : (-PS -tt (-and (-is-type 0 -NonNegFixnum) (-is-type 1 -PosFixnum))))
(-> -NonNegRat -Fixnum B : (-PS -tt (-is-type 1 -PosFixnum)))
(-> -Fixnum -NonPosInt B : (-PS -tt (-and (-is-type 0 -NegFixnum) (-is-type 1 -NonPosFixnum))))
(-> -Fixnum -NonPosRat B : (-PS -tt (-is-type 0 -NegFixnum)))
(-> -NegInt -Fixnum B : (-PS (-and (-is-type 0 -NegFixnum) (-is-type 1 -NegFixnum)) -tt))
(-> -NegReal -Fixnum B : (-PS (-is-type 1 -NegFixnum) -tt))
(-> -NonPosInt -Fixnum B : (-PS (-and (-is-type 0 -NonPosFixnum) (-is-type 1 -NonPosFixnum)) -tt))
(-> -NonPosReal -Fixnum B : (-PS (-is-type 1 -NonPosFixnum) -tt))
(-> -PosInfinity -Real B : (-PS (-not-type 1 -InexactRealNan) (-is-type 1 -InexactRealNan)))
(-> -Real -NegInfinity B : (-PS (-not-type 0 -InexactRealNan) (-is-type 0 -InexactRealNan)))
(-> -Real -PosInfinity B : (-PS (-is-type 0 -PosInfinity) (-not-type 0 -PosInfinity)))
(-> -NegInfinity -Real B : (-PS (-is-type 1 -NegInfinity) (-not-type 1 -NegInfinity)))
(-> -One -Int B : (-FS (-filter (Un -One -NonPosInt) 1) (-filter -PosInt 1)))
(-> -Int -One B : (-FS (-filter -PosInt 0) (-filter -NonPosInt 0)))
(-> -Real -Zero B : (-FS (-filter -NonNegReal 0) (-filter -NegReal 0)))
(-> -Zero -Real B : (-FS (-filter -NonPosReal 1) (-filter -PosReal 1)))
(-> -Real -RealZero B : (-FS (-filter -NonNegReal 0) -top)) ;; False says nothing because of NaN
(-> -RealZero -Real B : (-FS (-filter -NonPosReal 0) -top)) ;; False says nothing because of NaN
(-> -Byte -PosByte B : (-FS (-filter -PosByte 0) -top))
(-> -Byte -Byte B : (-FS -top (-filter -PosByte 1)))
(-> -Byte -PosInt B : (-FS (-and (-filter -PosByte 0) (-filter -PosByte 1)) -top))
(-> -Byte -PosReal B : (-FS (-filter -PosByte 0) -top))
(-> -PosInt -Byte B : (-FS -top (-and (-filter -PosByte 0) (-filter -PosByte 1))))
(-> -PosRat -Byte B : (-FS -top (-filter -PosByte 1)))
(-> -Byte -Nat B : (-FS (-filter -Byte 1) -top))
(-> -Nat -Byte B : (-FS -top (-and (-filter -Byte 0) (-filter -PosByte 1))))
(-> -NonNegRat -Byte B : (-FS -top (-filter -PosByte 1)))
(-> -Index -PosIndex B : (-FS (-filter -PosIndex 0) -top))
(-> -Index -Index B : (-FS -top (-filter -PosIndex 1)))
(-> -Index -Pos B : (-FS (-and (-filter -PosIndex 0) (-filter -PosIndex 1)) -top))
(-> -Index -PosReal B : (-FS (-filter -PosIndex 0) -top))
(-> -Pos -Index B : (-FS -top (-and (-filter -PosIndex 0) (-filter -PosIndex 1))))
(-> -PosRat -Index B : (-FS -top (-filter -PosIndex 1)))
(-> -Index -Nat B : (-FS (-filter -Index 1) -top))
(-> -Nat -Index B : (-FS -top (-and (-filter -Index 0) (-filter -PosIndex 1))))
(-> -NonNegRat -Index B : (-FS -top (-filter -PosIndex 1)))
(-> -Fixnum -PosInt B : (-FS (-and (-filter -PosFixnum 0) (-filter -PosFixnum 1)) -top))
(-> -Fixnum -PosReal B : (-FS (-filter -PosFixnum 0) -top))
(-> -Fixnum -Nat B : (-FS (-and (-filter -NonNegFixnum 0) (-filter -NonNegFixnum 1)) -top))
(-> -Fixnum -NonNegReal B : (-FS (-filter -NonNegFixnum 0) -top))
(-> -Nat -Fixnum B : (-FS -top (-and (-filter -NonNegFixnum 0) (-filter -PosFixnum 1))))
(-> -NonNegRat -Fixnum B : (-FS -top (-filter -PosFixnum 1)))
(-> -Fixnum -NonPosInt B : (-FS -top (-and (-filter -NegFixnum 0) (-filter -NonPosFixnum 1))))
(-> -Fixnum -NonPosRat B : (-FS -top (-filter -NegFixnum 0)))
(-> -NegInt -Fixnum B : (-FS (-and (-filter -NegFixnum 0) (-filter -NegFixnum 1)) -top))
(-> -NegReal -Fixnum B : (-FS (-filter -NegFixnum 1) -top))
(-> -NonPosInt -Fixnum B : (-FS (-and (-filter -NonPosFixnum 0) (-filter -NonPosFixnum 1)) -top))
(-> -NonPosReal -Fixnum B : (-FS (-filter -NonPosFixnum 1) -top))
(-> -PosInfinity -Real B : (-FS (-not-filter -InexactRealNan 1) (-filter -InexactRealNan 1)))
(-> -Real -NegInfinity B : (-FS (-not-filter -InexactRealNan 0) (-filter -InexactRealNan 0)))
(-> -Real -PosInfinity B : (-FS (-filter -PosInfinity 0) (-not-filter -PosInfinity 0)))
(-> -NegInfinity -Real B : (-FS (-filter -NegInfinity 1) (-not-filter -NegInfinity 1)))
(>=-type-pattern -Int -PosInt -Nat -NegInt -NonPosInt -Zero)
(>=-type-pattern -Rat -PosRat -NonNegRat -NegRat -NonPosRat -Zero)
(>=-type-pattern -Flonum -PosFlonum -NonNegFlonum -NegFlonum -NonPosFlonum)
@ -959,10 +959,10 @@
[* (from-cases
(-> -One)
(-> N N : -true-propset : (-arg-path 0))
(-> N N : -true-filter : (-arg-path 0))
(commutative-case -Zero N -Zero)
(-> N -One N : -true-propset : (-arg-path 0))
(-> -One N N : -true-propset : (-arg-path 1))
(-> N -One N : -true-filter : (-arg-path 0))
(-> -One N N : -true-filter : (-arg-path 1))
(-> -PosByte -PosByte -PosIndex)
(-> -Byte -Byte -Index)
(-> -PosByte -PosByte -PosByte -PosFixnum)
@ -1022,10 +1022,10 @@
(varop N))]
[+ (from-cases
(-> -Zero)
(-> N N : -true-propset : (-arg-path 0))
(-> N N : -true-filter : (-arg-path 0))
(binop -Zero)
(-> N -Zero N : -true-propset : (-arg-path 0))
(-> -Zero N N : -true-propset : (-arg-path 1))
(-> N -Zero N : -true-filter : (-arg-path 0))
(-> -Zero N N : -true-filter : (-arg-path 1))
(-> -PosByte -PosByte -PosIndex)
(-> -Byte -Byte -Index)
(-> -PosByte -PosByte -PosByte -PosIndex)
@ -1091,7 +1091,7 @@
(negation-pattern -PosInexactReal -NegInexactReal -NonNegInexactReal -NonPosInexactReal)
(negation-pattern -PosReal -NegReal -NonNegReal -NonPosReal)
(-> N -Zero N : -true-propset : (-arg-path 0))
(-> N -Zero N : -true-filter : (-arg-path 0))
(-> -One -One -Zero)
(-> -PosByte -One -Byte)
(-> -PosIndex -One -Index)
@ -1128,7 +1128,7 @@
[/ (from-cases ; very similar to multiplication, without closure properties for integers
(commutative-case -Zero N -Zero)
(unop -One)
(-> N -One N : -true-propset : (-arg-path 0))
(-> N -One N : -true-filter : (-arg-path 0))
(varop-1+ -PosRat)
(varop-1+ -NonNegRat)
(-> -NegRat -NegRat)
@ -1654,7 +1654,7 @@
(N . -> . N))]
[integer-sqrt
(from-cases
(-> (Un -RealZero -One) (Un -RealZero -One) : -true-propset : (-arg-path 0))
(-> (Un -RealZero -One) (Un -RealZero -One) : -true-filter : (-arg-path 0))
(unop -Byte)
(-NonNegFixnum . -> . -Index)
(-NonNegRat . -> . -Nat)
@ -1664,8 +1664,8 @@
(-Real . -> . N))] ; defined on inexact integers too, but not complex
[integer-sqrt/remainder
(from-cases
(-RealZero . -> . (make-Values (list (-result -RealZero -true-propset (-arg-path 0))
(-result -RealZero -true-propset (-arg-path 0)))))
(-RealZero . -> . (make-Values (list (-result -RealZero -true-filter (-arg-path 0))
(-result -RealZero -true-filter (-arg-path 0)))))
(-One . -> . (-values (list -One -Zero)))
(-Byte . -> . (-values (list -Byte -Byte)))
(-Index . -> . (-values (list -Index -Index)))

98
typed-racket-lib/typed-racket/base-env/base-env.rkt
View File

@ -66,8 +66,8 @@
;; Section 4.2.2.7 (Random Numbers)
[random
(cl->* (->opt -Int -Int [-Pseudo-Random-Generator] -NonNegFixnum)
(->opt -Int [-Pseudo-Random-Generator] -NonNegFixnum)
(cl->* (->opt -PosFixnum [-Pseudo-Random-Generator] -NonNegFixnum)
(->opt -Int [-Pseudo-Random-Generator] -Nat)
(->opt [-Pseudo-Random-Generator] -Flonum))]
[random-seed (-> -PosInt -Void)]
@ -177,11 +177,6 @@
#:repeat? Univ #f
-String)]
[non-empty-string? (make-pred-ty -String)]
[string-contains? (-> -String -String -Boolean)]
[string-prefix? (-> -String -String -Boolean)]
[string-suffix? (-> -String -String -Boolean)]
;; Section 4.3.6 (racket/format)
[~a (->optkey []
#:rest Univ
@ -677,7 +672,7 @@
[((a b c . -> . c) c (-lst a) (-lst b)) c]
[((a b c d . -> . d) d (-lst a) (-lst b) (-lst c)) d]))]
[filter (-poly (a b) (cl->*
((asym-pred a Univ (-PS (-is-type 0 b) -tt))
((asym-pred a Univ (-FS (-filter b 0) -top))
(-lst a)
. -> .
(-lst b))
@ -717,7 +712,7 @@
-Index))]
[partition
(-poly (a b) (cl->*
(-> (asym-pred b Univ (-PS (-is-type 0 a) -tt)) (-lst b) (-values (list (-lst a) (-lst b))))
(-> (asym-pred b Univ (-FS (-filter a 0) -top)) (-lst b) (-values (list (-lst a) (-lst b))))
(-> (-> a Univ) (-lst a) (-values (list (-lst a) (-lst a))))))]
[last (-poly (a) ((-lst a) . -> . a))]
@ -735,7 +730,7 @@
(-poly (a b)
(cl->*
(-> (-lst a)
(asym-pred a Univ (-PS (-is-type 0 b) -tt))
(asym-pred a Univ (-FS (-filter b 0) -top))
(-lst b))
(-> (-lst a) (-> a Univ) (-lst a))))]
[dropf (-poly (a) (-> (-lst a) (-> a Univ) (-lst a)))]
@ -743,14 +738,14 @@
(-poly (a b)
(cl->*
(-> (-lst a)
(asym-pred a Univ (-PS (-is-type 0 b) -tt))
(asym-pred a Univ (-FS (-filter b 0) -top))
(-values (list (-lst b) (-lst a))))
(-> (-lst a) (-> a Univ) (-values (list (-lst a) (-lst a))))))]
[takef-right
(-poly (a b)
(cl->*
(-> (-lst a)
(asym-pred a Univ (-PS (-is-type 0 b) -tt))
(asym-pred a Univ (-FS (-filter b 0) -top))
(-lst b))
(-> (-lst a) (-> a Univ) (-lst a))))]
[dropf-right (-poly (a) (-> (-lst a) (-> a Univ) (-lst a)))]
@ -758,7 +753,7 @@
(-poly (a b)
(cl->*
(-> (-lst a)
(asym-pred a Univ (-PS (-is-type 0 b) -tt))
(asym-pred a Univ (-FS (-filter b 0) -top))
(-values (list (-lst a) (-lst b))))
(-> (-lst a) (-> a Univ) (-values (list (-lst a) (-lst a))))))]
@ -778,12 +773,6 @@
(-poly (a) ((-lst (-lst a)) . -> . (-lst a)))]
[flatten
(Univ . -> . (-lst Univ))]
[combinations (-poly (a) (cl->*
(-> (-lst a) (-lst (-lst a)))
(-> (-lst a) -Nat (-lst (-lst a)))))]
[in-combinations (-poly (a) (cl->*
(-> (-lst a) (-seq (-lst a)))
(-> (-lst a) -Nat (-seq (-lst a)))))]
[permutations (-poly (a) (-> (-lst a) (-lst (-lst a))))]
[in-permutations (-poly (a) (-> (-lst a) (-seq (-lst a))))]
[argmin (-poly (a) ((a . -> . -Real) (-lst a) . -> . a))]
@ -853,7 +842,7 @@
. ->... .
-Index))]
[vector-filter (-poly (a b) (cl->*
((asym-pred a Univ (-PS (-is-type 0 b) -tt))
((asym-pred a Univ (-FS (-filter b 0) -top))
(-vec a)
. -> .
(-vec b))
@ -1041,7 +1030,7 @@
[sequence-fold (-poly (a b) ((b a . -> . b) b (-seq a) . -> . b))]
[sequence-count (-poly (a) ((a . -> . Univ) (-seq a) . -> . -Nat))]
[sequence-filter (-poly (a b) (cl->*
((asym-pred a Univ (-PS (-is-type 0 b) -tt))
((asym-pred a Univ (-FS (-filter b 0) -top))
(-seq a)
. -> .
(-seq b))
@ -1071,7 +1060,7 @@
[proper-subset? (-poly (e) (-> (-set e) (-set e) B))]
[set-map (-poly (e b) (-> (-set e) (-> e b) (-lst b)))]
[set-for-each (-poly (e b) (-> (-set e) (-> e b) -Void))]
[generic-set? (asym-pred Univ B (-PS -tt (-not-type 0 (-set Univ))))]
[generic-set? (asym-pred Univ B (-FS -top (-not-filter (-set Univ) 0)))]
[set? (make-pred-ty (-set Univ))]
[set-equal? (-poly (e) (-> (-set e) B))]
[set-eqv? (-poly (e) (-> (-set e) B))]
@ -1110,14 +1099,14 @@
[identity (-poly (a) (->acc (list a) a null))]
[const (-poly (a) (-> a (->* '() Univ a)))]
[negate (-polydots (a b c d)
(cl->* (-> (-> c Univ : (-PS (-is-type 0 a) (-not-type 0 b)))
(-> c -Boolean : (-PS (-not-type 0 b) (-is-type 0 a))))
(-> (-> c Univ : (-PS (-is-type 0 a) (-is-type 0 b)))
(-> c -Boolean : (-PS (-is-type 0 b) (-is-type 0 a))))
(-> (-> c Univ : (-PS (-not-type 0 a) (-is-type 0 b)))
(-> c -Boolean : (-PS (-is-type 0 b) (-not-type 0 a))))
(-> (-> c Univ : (-PS (-not-type 0 a) (-not-type 0 b)))
(-> c -Boolean : (-PS (-not-type 0 b) (-not-type 0 a))))
(cl->* (-> (-> c Univ : (-FS (-filter a 0) (-not-filter b 0)))
(-> c -Boolean : (-FS (-not-filter b 0) (-filter a 0))))
(-> (-> c Univ : (-FS (-filter a 0) (-filter b 0)))
(-> c -Boolean : (-FS (-filter b 0) (-filter a 0))))
(-> (-> c Univ : (-FS (-not-filter a 0) (-filter b 0)))
(-> c -Boolean : (-FS (-filter b 0) (-not-filter a 0))))
(-> (-> c Univ : (-FS (-not-filter a 0) (-not-filter b 0)))
(-> c -Boolean : (-FS (-not-filter b 0) (-not-filter a 0))))
(-> ((list) [d d] . ->... . Univ)
((list) [d d] . ->... . -Boolean))))]
[conjoin (-polydots (a) (->* '() (->... '() (a a) Univ) (->... '() (a a) Univ)))]
@ -1303,7 +1292,7 @@
[call-with-continuation-barrier (-poly (a) (-> (-> a) a))]
[continuation-prompt-available? (-> (make-Prompt-TagTop) B)]
[continuation?
(asym-pred Univ B (-PS (-is-type 0 top-func) -tt))]
(asym-pred Univ B (-FS (-filter top-func 0) -top))]
[continuation-prompt-tag? (make-pred-ty (make-Prompt-TagTop))]
[dynamic-wind (-poly (a) (-> (-> ManyUniv) (-> a) (-> ManyUniv) a))]
@ -1424,7 +1413,7 @@
[never-evt (-evt (Un))]
[system-idle-evt (-> (-evt -Void))]
[alarm-evt (-> -Real (-mu x (-evt x)))]
[handle-evt? (asym-pred Univ B (-PS (-is-type 0 (-evt Univ)) -tt))]
[handle-evt? (asym-pred Univ B (-FS (-filter (-evt Univ) 0) -top))]
[current-evt-pseudo-random-generator
(-Param -Pseudo-Random-Generator -Pseudo-Random-Generator)]
@ -1435,7 +1424,7 @@
[channel-try-get (-poly (a) ((-channel a) . -> . (Un a (-val #f))))]
[channel-put (-poly (a) ((-channel a) a . -> . -Void))]
[channel-put-evt (-poly (a) (-> (-channel a) a (-mu x (-evt x))))]
[channel-put-evt? (asym-pred Univ B (-PS (-is-type 0 (-mu x (-evt x))) -tt))]
[channel-put-evt? (asym-pred Univ B (-FS (-filter (-mu x (-evt x)) 0) -top))]
;; Section 11.2.3 (Semaphores)
[semaphore? (make-pred-ty -Semaphore)]
@ -1445,7 +1434,7 @@
[semaphore-try-wait? (-> -Semaphore B)]
[semaphore-wait/enable-break (-> -Semaphore -Void)]
[semaphore-peek-evt (-> -Semaphore (-mu x (-evt x)))]
[semaphore-peek-evt? (asym-pred Univ B (-PS (-is-type 0 (-mu x (-evt x))) -tt))]
[semaphore-peek-evt? (asym-pred Univ B (-FS (-filter (-mu x (-evt x)) 0) -top))]
[call-with-semaphore
(-polydots (b a)
(cl->* (->... (list -Semaphore (->... '() [a a] b))
@ -1541,10 +1530,7 @@
[syntax-original? (-poly (a) (-> (-Syntax a) B))]
[syntax-source-module (->opt (-Syntax Univ) [Univ] (Un (-val #f) -Path Sym -Module-Path-Index))]
[syntax-e (-poly (a) (->acc (list (-Syntax a)) a (list -syntax-e)))]
[syntax->list (-poly (a)
(cl->* (-> (-Syntax (-lst a)) (-lst a))
(-> (-Syntax Univ)
(Un (-val #f) (-lst (-Syntax Univ))))))]
[syntax->list (-poly (a) (-> (-Syntax (-lst a)) (-lst a)))]
[syntax->datum (cl->* (-> Any-Syntax -Sexp)
(-> (-Syntax Univ) Univ))]
@ -1849,8 +1835,8 @@
[port-file-identity (-> (Un -Input-Port -Output-Port) -PosInt)]
;; Section 13.1.6
[open-input-string (->opt -String [Univ] -Input-Port)]
[open-input-bytes (->opt -Bytes [Univ] -Input-Port)]
[open-input-string (-> -String -Input-Port)]
[open-input-bytes (-> -Bytes -Input-Port)]
[open-output-string
([Univ] . ->opt . -Output-Port)]
[open-output-bytes
@ -1863,7 +1849,7 @@
;; Section 13.1.7
[make-pipe
(cl->* [->opt [N Univ Univ] (-values (list -Input-Port -Output-Port))])]
(cl->* [->opt [N] (-values (list -Input-Port -Output-Port))])]
[pipe-content-length (-> (Un -Input-Port -Output-Port) -Nat)]
;; Section 13.1.8
@ -1965,10 +1951,8 @@
[make-pipe-with-specials (->opt [-Nat Univ Univ] (-values (list -Input-Port -Output-Port)))]
[merge-input (->opt -Input-Port -Input-Port [(-opt -Nat)] -Input-Port)]
[open-output-nowhere (->opt [Univ Univ] -Output-Port)]
[peeking-input-port (->optkey -Input-Port [Univ -Nat]
#:init-position -Nat #f
-Input-Port)]
[open-output-nowhere (-> -Output-Port)]
[peeking-input-port (->opt -Input-Port [Univ -Nat] -Input-Port)]
[reencode-input-port
(->opt -Input-Port -String (-opt -Bytes) [Univ Univ Univ (-> -String -Input-Port ManyUniv)] -Input-Port)]
@ -2316,7 +2300,7 @@
[resolved-module-path? (make-pred-ty -Resolved-Module-Path)]
[make-resolved-module-path (-> (Un -Symbol -Path) -Resolved-Module-Path)]
[resolved-module-path-name (-> -Resolved-Module-Path (Un -Path -Symbol))]
[module-path? (asym-pred Univ B (-PS (-is-type 0 -Module-Path) -tt))]
[module-path? (asym-pred Univ B (-FS (-filter -Module-Path 0) -top))]
[current-module-name-resolver (-Param (cl->* (-Resolved-Module-Path Univ . -> . Univ)
((Un -Module-Path -Path)
@ -2500,8 +2484,8 @@
;; Section 15.1 (Path Manipulation)
[path? (make-pred-ty -Path)]
[path-string? (asym-pred Univ B
(-PS (-is-type 0 (Un -Path -String))
(-not-type 0 -Path)))]
(-FS (-filter (Un -Path -String) 0)
(-not-filter -Path 0)))]
[path-for-some-system? (make-pred-ty -SomeSystemPath)]
[string->path (-> -String -Path)]
@ -2566,16 +2550,6 @@
(Un -SomeSystemPath (one-of/c 'up 'same))
B))))]
[path-replace-extension
(cl->*
(-> -Pathlike (Un -String -Bytes) -Path)
(-> -SomeSystemPathlike (Un -String -Bytes) -SomeSystemPath))]
[path-add-extension
(cl->*
(-> -Pathlike (Un -String -Bytes) -Path)
(-> -SomeSystemPathlike (Un -String -Bytes) -SomeSystemPath))]
[path-replace-suffix
(cl->*
(-> -Pathlike (Un -String -Bytes) -Path)
@ -2701,10 +2675,10 @@
[tcp-abandon-port (-Port . -> . -Void)]
[tcp-addresses (cl->*
((Un -TCP-Listener -Port) [(-val #f)] . ->opt . (-values (list -String -String)))
((Un -TCP-Listener -Port) (-val #t) . -> . (-values (list -String -Index -String -Index))))]
(-Port [(-val #f)] . ->opt . (-values (list -String -String)))
(-Port (-val #t) . -> . (-values (list -String -Index -String -Index))))]
[tcp-port? (asym-pred Univ B (-PS (-is-type 0 (Un -Input-Port -Output-Port)) -tt))]
[tcp-port? (asym-pred Univ B (-FS (-filter (Un -Input-Port -Output-Port) 0) -top))]
;; Section 15.3.2 (racket/udp)
[udp-open-socket (->opt [(-opt -String) (-opt -String)] -UDP-Socket)]
@ -3063,7 +3037,7 @@
[assert (-poly (a b) (cl->*
(Univ (make-pred-ty (list a) Univ b) . -> . b)
(-> (Un a (-val #f)) a)))]
[defined? (->* (list Univ) -Boolean : (-PS (-not-type 0 -Undefined) (-is-type 0 -Undefined)))]
[defined? (->* (list Univ) -Boolean : (-FS (-not-filter -Undefined 0) (-filter -Undefined 0)))]
;; Syntax Manual
;; Section 2.1 (syntax/stx)

4
typed-racket-lib/typed-racket/base-env/base-special-env.rkt
View File

@ -182,9 +182,7 @@
[(-HashTop) (-seq (-pair Univ Univ))]))]
;; in-port
[(make-template-identifier 'in-port 'racket/private/for)
(-poly (a)
(cl->* (-> (-seq Univ))
(->opt (-> -Input-Port (Un a (-val eof))) [-Input-Port] (-seq a))))]
(->opt [(-> -Input-Port Univ) -Input-Port] (-seq Univ))]
;; in-input-port-bytes
[(make-template-identifier 'in-input-port-bytes 'racket/private/for)
(-> -Input-Port (-seq -Byte))]

3
typed-racket-lib/typed-racket/base-env/base-types-extra.rkt
View File

@ -22,8 +22,7 @@
(define-other-types
-> ->* case-> U Rec All Opaque Vector
Parameterof List List* Class Object Unit Values AnyValues Instance Refinement
pred Struct Struct-Type Prefab Top Bot Distinction Sequenceof
∩)
pred Struct Struct-Type Prefab Top Bot Distinction Sequenceof)
(provide (rename-out [All ∀]
[U Un]

2
typed-racket-lib/typed-racket/base-env/class-prims.rkt
View File

@ -282,7 +282,7 @@
[_ #f]))
;; clauses->names : (-> Clause Boolean) Listof<Clause> -> Listof<Id>
;; prop clauses by some property and spit out the names in those clauses
;; filter clauses by some property and spit out the names in those clauses
(define (clauses->names prop clauses [keep-pair? #f])
(apply append
(for/list ([clause (in-list clauses)]

4
typed-racket-lib/typed-racket/base-env/env-lang.rkt
View File

@ -5,7 +5,7 @@
(require (for-syntax racket/base syntax/parse)
(utils tc-utils)
(env init-envs)
(types abbrev numeric-tower union prop-ops))
(types abbrev numeric-tower union filter-ops))
(define-syntax (-#%module-begin stx)
(define-syntax-class clause
@ -29,4 +29,4 @@
require
(except-out (all-from-out racket/base) #%module-begin)
types rep private utils
(types-out abbrev numeric-tower union prop-ops))
(types-out abbrev numeric-tower union filter-ops))

4
typed-racket-lib/typed-racket/base-env/extra-env-lang.rkt
View File

@ -11,7 +11,7 @@
(for-syntax racket/base
syntax/parse
syntax/stx)
(for-syntax (types abbrev numeric-tower union prop-ops)))
(for-syntax (types abbrev numeric-tower union filter-ops)))
(provide type-environment
(rename-out [-#%module-begin #%module-begin])
@ -20,7 +20,7 @@
(except-out (all-from-out racket/base) #%module-begin)
(for-syntax (except-out (all-from-out racket/base) #%module-begin))
types rep private utils
(for-syntax (types-out abbrev numeric-tower union prop-ops)))
(for-syntax (types-out abbrev numeric-tower union filter-ops)))
;; syntax classes for type clauses in the type-environment macro
(begin-for-syntax

66
typed-racket-lib/typed-racket/base-env/prims-contract.rkt
View File

@ -19,7 +19,7 @@
(provide require/opaque-type require-typed-struct-legacy require-typed-struct
require/typed-legacy require/typed require/typed/provide
require-typed-struct/provide core-cast make-predicate define-predicate
require-typed-struct/provide cast make-predicate define-predicate
require-typed-signature)
(module forms racket/base
@ -31,7 +31,7 @@
require-typed-struct-legacy
require-typed-struct
require/typed-legacy require/typed require/typed/provide
require-typed-struct/provide core-cast make-predicate define-predicate)]))
require-typed-struct/provide cast make-predicate define-predicate)]))
(define-syntax (def stx)
(syntax-case stx ()
[(_ id ...)
@ -43,16 +43,7 @@
require-typed-struct-legacy
require-typed-struct
require/typed-legacy require/typed require/typed/provide
require-typed-struct/provide make-predicate define-predicate)
;; Expand `cast` to a `core-cast` with an extra `#%expression` in order
;; to prevent the contract generation pass from executing too early
;; (i.e., before the `cast` typechecks)
(define-syntax (-core-cast stx) (core-cast stx))
(define-syntax (cast stx)
(syntax-case stx ()
[(_ e ty) (quasisyntax/loc stx (#%expression #,(syntax/loc stx (-core-cast e ty))))]))
(provide cast))
require-typed-struct/provide cast make-predicate define-predicate))
;; unsafe operations go in this submodule
(module* unsafe #f
@ -84,7 +75,6 @@
(for-template "../utils/any-wrap.rkt")
"../utils/tc-utils.rkt"
"../private/syntax-properties.rkt"
"../private/cast-table.rkt"
"../typecheck/internal-forms.rkt"
;; struct-extraction is actually used at both of these phases
"../utils/struct-extraction.rkt"
@ -260,27 +250,9 @@
;; make-predicate
;; cast
;; Helpers to construct syntax for contract definitions
;; make-contract-def-rhs : Type-Stx Boolean Boolean -> Syntax
;; Helper to construct syntax for contract definitions
(define (make-contract-def-rhs type flat? maker?)
(define contract-def `#s(contract-def ,type ,flat? ,maker? untyped))
(contract-def-property #'#f (λ () contract-def)))
;; make-contract-def-rhs/from-typed : Id Boolean Boolean -> Syntax
(define (make-contract-def-rhs/from-typed id flat? maker?)
(contract-def-property
#'#f
;; This function should only be called after the type-checking pass has finished.
;; By then `tc/#%expression` will have recognized the `casted-expr` property and
;; will have added the casted expression's original type to the cast-table, so
;; that `(cast-table-ref id)` can get that type here.
(λ ()
(define type-stx
(or (cast-table-ref id)
(int-err (string-append
"contract-def-property: thunk called too early\n"
" This should only be called after the type-checking pass has finished."))))
`#s(contract-def ,type-stx ,flat? ,maker? typed))))
(contract-def-property #'#f `#s(contract-def ,type ,flat? ,maker? untyped)))
(define (define-predicate stx)
@ -313,21 +285,21 @@
#`(#,(external-check-property #'#%expression check-valid-type)
#,(ignore-some/expr #`(flat-contract-predicate #,name) #'(Any -> Boolean : ty)))]))
;; wrapped above in the `forms` submodule
(define (core-cast stx)
(define (cast stx)
(syntax-parse stx
[(_ v:expr ty:expr)
(define (apply-contract v ctc-expr pos neg)
(define (apply-contract ctc-expr)
#`(#%expression
#,(ignore-some/expr
#`(let-values (((val) #,(with-type* v #'Any)))
#`(let-values (((val) #,(with-type* #'v #'Any)))
#,(syntax-property
(quasisyntax/loc stx
(contract
#,ctc-expr
val
'#,pos
'#,neg
'cast
'typed-world
val
(quote-srcloc #,stx)))
'feature-profile:TR-dynamic-check #t))
@ -336,13 +308,8 @@
(cond [(not (unbox typed-context?)) ; no-check, don't check
#'v]
[else
(define new-ty-ctc (syntax-local-lift-expression
(make-contract-def-rhs #'ty #f #f)))
(define existing-ty-id new-ty-ctc)
(define existing-ty-ctc (syntax-local-lift-expression
(make-contract-def-rhs/from-typed existing-ty-id #f #f)))
(define (store-existing-type existing-type)
(cast-table-set! existing-ty-id existing-type))
(define ctc (syntax-local-lift-expression
(make-contract-def-rhs #'ty #f #f)))
(define (check-valid-type _)
(define type (parse-type #'ty))
(define vars (fv type))
@ -352,12 +319,7 @@
"Type ~a could not be converted to a contract because it contains free variables."
type)))
#`(#,(external-check-property #'#%expression check-valid-type)
#,(apply-contract
(apply-contract
#`(#,(casted-expr-property #'#%expression store-existing-type)
v)
existing-ty-ctc 'typed-world 'cast)
new-ty-ctc 'cast 'typed-world))])]))
#,(apply-contract ctc))])]))

7
typed-racket-lib/typed-racket/base-env/prims.rkt
View File

@ -145,12 +145,9 @@ the typed racket language.
(provide (all-from-out "base-contracted.rkt")))
(begin-for-syntax
(require racket/runtime-path
(for-syntax racket/base))
(define-runtime-module-path-index contract-defs-submod
'(submod "." #%contract-defs))
(require racket/base "../utils/redirect-contract.rkt")
(define mk (make-make-redirect-to-contract contract-defs-submod)))
(define varref (#%variable-reference))
(define mk (make-make-redirect-to-contract varref)))
(define-syntax-rule (def-redirect id ...)
(begin (define-syntax id (mk (quote-syntax id))) ... (provide id ...)))

34
typed-racket-lib/typed-racket/env/init-envs.rkt vendored
View File

@ -10,10 +10,10 @@
"mvar-env.rkt"
"signature-env.rkt"
(rename-in racket/private/sort [sort raw-sort])
(rep type-rep object-rep prop-rep rep-utils free-variance)
(rep type-rep object-rep filter-rep rep-utils free-variance)
(for-syntax syntax/parse racket/base)
(types abbrev union)
racket/dict racket/list racket/set racket/promise
racket/dict racket/list racket/promise
mzlib/pconvert racket/match)
(provide ;; convenience form for defining an initial environment
@ -64,28 +64,22 @@
[(? Rep? (app (lambda (v) (hash-ref predefined-type-table (Rep-seq v) #f)) (? values id))) id]
[(Listof: elem-ty)
`(-lst ,(sub elem-ty))]
[(Function: (list (arr: dom (Values: (list (Result: t
(PropSet: (TrueProp:)
(TrueProp:))
(Empty:))))
#f #f '())))
[(Function: (list (arr: dom (Values: (list (Result: t (FilterSet: (Top:) (Top:)) (Empty:)))) #f #f '())))
`(simple-> (list ,@(map sub dom)) ,(sub t))]
[(Function: (list (arr: dom (Values: (list (Result: t (PropSet: (TypeProp: pth ft)
(NotTypeProp: pth ft))
[(Function: (list (arr: dom (Values: (list (Result: t (FilterSet: (TypeFilter: ft pth)
(NotTypeFilter: ft pth))
(Empty:))))
#f #f '())))
`(make-pred-ty (list ,@(map sub dom)) ,(sub t) ,(sub ft) ,(sub pth))]
[(Function: (list (arr: dom (Values: (list (Result: t (PropSet: (NotTypeProp: (Path: pth (list 0 0))
(== -False))
(TypeProp: (Path: pth (list 0 0))
(== -False)))
[(Function: (list (arr: dom (Values: (list (Result: t (FilterSet: (NotTypeFilter: (== -False)
(Path: pth (list 0 0)))
(TypeFilter: (== -False)
(Path: pth (list 0 0))))
(Path: pth (list 0 0)))))
#f #f '())))
`(->acc (list ,@(map sub dom)) ,(sub t) ,(sub pth))]
[(Result: t (PropSet: (TrueProp:) (TrueProp:)) (Empty:)) `(-result ,(sub t))]
[(Result: t (FilterSet: (Top:) (Top:)) (Empty:)) `(-result ,(sub t))]
[(Union: elems) (split-union elems)]
[(Intersection: elems) `(make-Intersection (set ,@(for/list ([elem (in-immutable-set elems)])
(sub elem))))]
[(Base: n cnt pred _) (int-err "Base type ~a not in predefined-type-table" n)]
[(Name: stx args struct?)
`(make-Name (quote-syntax ,stx) ,args ,struct?)]
@ -139,10 +133,10 @@
(list ,@(serialize-mapping mapping)))]
[(arr: dom rng rest drest kws)
`(make-arr ,(sub dom) ,(sub rng) ,(sub rest) ,(sub drest) ,(sub kws))]
[(TypeProp: o t)
`(make-TypeProp ,(sub o) ,(sub t))]
[(NotTypeProp: o t)
`(make-NotTypeProp ,(sub o) ,(sub t))]
[(TypeFilter: t p)
`(make-TypeFilter ,(sub t) ,(sub p))]
[(NotTypeFilter: t p)
`(make-NotTypeFilter ,(sub t) ,(sub p))]
[(Path: p i)
`(make-Path ,(sub p) ,(if (identifier? i)
`(quote-syntax ,i)

8
typed-racket-lib/typed-racket/env/type-env-structs.rkt vendored
View File

@ -6,12 +6,12 @@
(contract-req)
(rep object-rep))
(require-for-cond-contract (rep type-rep prop-rep))
(require-for-cond-contract (rep type-rep filter-rep))
;; types is a free-id-table of identifiers to types
;; props is a list of known propositions
(define-struct/cond-contract env ([types immutable-free-id-table?]
[props (listof Prop?)]
[props (listof Filter/c)]
[aliases immutable-free-id-table?])
#:transparent
#:property prop:custom-write
@ -23,8 +23,8 @@
[extend (env? identifier? Type/c . -> . env?)]
[extend/values (env? (listof identifier?) (listof Type/c) . -> . env?)]
[lookup (env? identifier? (identifier? . -> . any) . -> . any)]
[env-props (env? . -> . (listof Prop?))]
[replace-props (env? (listof Prop?) . -> . env?)]
[env-props (env? . -> . (listof Filter/c))]
[replace-props (env? (listof Filter/c) . -> . env?)]
[empty-prop-env env?]
[extend+alias/values (env? (listof identifier?) (listof Type/c) (listof Object?) . -> . env?)]
[lookup-alias (env? identifier? (identifier? . -> . (or/c #f Object?)) . -> . (or/c #f Object?))])

4
typed-racket-lib/typed-racket/infer/constraints.rkt
View File

@ -7,7 +7,7 @@
racket/match
racket/list)
(import intersect^ dmap^)
(import restrict^ dmap^)
(export constraints^)
;; Widest constraint possible
@ -34,7 +34,7 @@
;; intersect the given types. produces a lower bound on both, but
;; perhaps not the GLB
(define (meet S T)
(let ([s* (intersect S T)])
(let ([s* (restrict S T)])
(if (and (subtype s* S)
(subtype s* T))
s*

2
typed-racket-lib/typed-racket/infer/fail.rkt
View File

@ -14,7 +14,7 @@
#'((early-return rhs ...))))
(syntax-parse stx
[(_ e [c . r:rhs] ...)
(syntax/loc stx (match* e [c . r.r] ...))]))
#'(match* e [c . r.r] ...)]))
(begin-for-syntax
(define-splicing-syntax-class arg

63
typed-racket-lib/typed-racket/infer/infer-unit.rkt
View File

@ -11,7 +11,7 @@
(except-in
(combine-in
(utils tc-utils)
(rep free-variance type-rep prop-rep object-rep rep-utils)
(rep free-variance type-rep filter-rep object-rep rep-utils)
(types utils abbrev numeric-tower union subtype resolve
substitute generalize prefab)
(env index-env tvar-env))
@ -19,7 +19,7 @@
"constraint-structs.rkt"
"signatures.rkt" "fail.rkt"
"promote-demote.rkt"
racket/match racket/set
racket/match
mzlib/etc
(contract-req)
(for-syntax
@ -224,23 +224,23 @@
(substitute (make-F var) v ty*))))
(define/cond-contract (cgen/prop context s t)
(context? Prop? Prop? . -> . (or/c #f cset?))
(define/cond-contract (cgen/filter context s t)
(context? Filter? Filter? . -> . (or/c #f cset?))
(match* (s t)
[(e e) (empty-cset/context context)]
[(e (TrueProp:)) (empty-cset/context context)]
[(e (Top:)) (empty-cset/context context)]
;; FIXME - is there something to be said about the logical ones?
[((TypeProp: o s) (TypeProp: o t)) (cgen/inv context s t)]
[((NotTypeProp: o s) (NotTypeProp: o t)) (cgen/inv context s t)]
[((TypeFilter: s p) (TypeFilter: t p)) (cgen/inv context s t)]
[((NotTypeFilter: s p) (NotTypeFilter: t p)) (cgen/inv context s t)]
[(_ _) #f]))
;; s and t must be *latent* prop sets
(define/cond-contract (cgen/prop-set context s t)
(context? PropSet? PropSet? . -> . (or/c #f cset?))
;; s and t must be *latent* filter sets
(define/cond-contract (cgen/filter-set context s t)
(context? FilterSet? FilterSet? . -> . (or/c #f cset?))
(match* (s t)
[(e e) (empty-cset/context context)]
[((PropSet: p+ p-) (PropSet: q+ q-))
(% cset-meet (cgen/prop context p+ q+) (cgen/prop context p- q-))]
[((FilterSet: s+ s-) (FilterSet: t+ t-))
(% cset-meet (cgen/filter context s+ t+) (cgen/filter context s- t-))]
[(_ _) #f]))
(define/cond-contract (cgen/object context s t)
@ -320,7 +320,7 @@
(% move-dotted-rest-to-dmap (cgen (context-add-var context dbound) s-dty t-dty) dbound dbound*)))]
[((seq ss (dotted-end s-dty dbound))
(seq ts (dotted-end t-dty dbound*)))
#:return-unless (inferable-index? context dbound*) #f
#:when (inferable-index? context dbound*)
#:return-unless (= (length ss) (length ts)) #f
(% cset-meet
(cgen/list context ss ts)
@ -439,26 +439,26 @@
;; CG-Top
[(_ (Univ:)) empty]
;; AnyValues
[((AnyValues: p) (AnyValues: q))
(cgen/prop context p q)]
[((AnyValues: s-f) (AnyValues: t-f))
(cgen/filter context s-f t-f)]
[((or (Values: (list (Result: _ psets _) ...))
(ValuesDots: (list (Result: _ psets _) ...) _ _))
(AnyValues: q))
[((or (Values: (list (Result: _ fs _) ...))
(ValuesDots: (list (Result: _ fs _) ...) _ _))
(AnyValues: t-f))
(cset-join
(filter identity
(for/list ([pset (in-list psets)])
(match pset
[(PropSet: p+ p-)
(% cset-meet (cgen/prop context p+ q) (cgen/prop context p- q))]))))]
(for/list ([f (in-list fs)])
(match f
[(FilterSet: f+ f-)
(% cset-meet (cgen/filter context f+ t-f) (cgen/filter context f- t-f))]))))]
;; check all non Type/c first so that calling subtype is safe
;; check each element
[((Result: s pset-s o-s)
(Result: t pset-t o-t))
[((Result: s f-s o-s)
(Result: t f-t o-t))
(% cset-meet (cg s t)
(cgen/prop-set context pset-s pset-t)
(cgen/filter-set context f-s f-t)
(cgen/object context o-s o-t))]
;; Values just delegate to cgen/seq, except special handling for -Bottom.
@ -525,19 +525,6 @@
[((? Mu? s) t) (cg (unfold s) t)]
[(s (? Mu? t)) (cg s (unfold t))]
;; find *an* element of elems which can be made a subtype of T
[((Intersection: ts) T)
(cset-join
(for*/list ([t (in-immutable-set ts)]
[v (in-value (cg t T))]
#:when v)
v))]
;; constrain S to be below *each* element of elems, and then combine the constraints
[(S (Intersection: ts))
(define cs (for/list/fail ([ts (in-immutable-set ts)]) (cg S ts)))
(and cs (cset-meet* (cons empty cs)))]
;; constrain *each* element of es to be below T, and then combine the constraints
[((Union: es) T)
(define cs (for/list/fail ([e (in-list es)]) (cg e T)))

6
typed-racket-lib/typed-racket/infer/infer.rkt
View File

@ -1,11 +1,11 @@
#lang racket/base
(require "infer-unit.rkt" "constraints.rkt" "dmap.rkt" "signatures.rkt"
"intersect.rkt"
"restrict.rkt"
(only-in racket/unit provide-signature-elements
define-values/invoke-unit/infer link))
(provide-signature-elements intersect^ infer^)
(provide-signature-elements restrict^ infer^)
(define-values/invoke-unit/infer
(link infer@ constraints@ dmap@ intersect@))
(link infer@ constraints@ dmap@ restrict@))

71
typed-racket-lib/typed-racket/infer/intersect.rkt
View File

@ -1,71 +0,0 @@
#lang racket/unit
(require "../utils/utils.rkt")
(require (rep type-rep)
(types abbrev base-abbrev union subtype resolve)
"signatures.rkt"
racket/match
racket/set)
(import infer^)
(export intersect^)
;; compute the intersection of two types
;; (note: previously called restrict)
(define (intersect t1 t2)
;; build-type: build a type while propogating bottom
(define (build-type constructor . args)
(if (memf Bottom? args) -Bottom (apply constructor args)))
;; resolved is a set tracking previously seen intersect cases
;; (i.e. pairs of t1 t2) to prevent infinite unfolding.
;; subtyping performs a similar check for the same
;; reason
(let intersect
([t1 t1] [t2 t2] [resolved (set)])
(match*/no-order
(t1 t2)
;; already a subtype
[(t1 t2) #:no-order #:when (subtype t1 t2) t1]
;; polymorphic intersect
[(t1 (Poly: vars t))
#:no-order
#:when (infer vars null (list t1) (list t) #f)
t1]
;; structural recursion on types
[((Pair: a1 d1) (Pair: a2 d2))
(build-type -pair
(intersect a1 a2 resolved)
(intersect d1 d2 resolved))]
;; FIXME: support structural updating for structs when structs are updated to
;; contain not only *if* they are polymorphic, but *which* fields are too
;;[((Struct: _ _ _ _ _ _)
;; (Struct: _ _ _ _ _ _))]
[((Syntax: t1*) (Syntax: t2*))
(build-type -Syntax (intersect t1* t2* resolved))]
[((Promise: t1*) (Promise: t2*))
(build-type -Promise (intersect t1* t2* resolved))]
;; unions
[((Union: t1s) t2)
#:no-order
(apply Un (map (λ (t1) (intersect t1 t2 resolved)) t1s))]
;; intersections
[((Intersection: t1s) t2)
#:no-order
(apply -unsafe-intersect (for/list ([t1 (in-immutable-set t1s)])
(intersect t1 t2 resolved)))]
;; resolve resolvable types if we haven't already done so
[((? needs-resolving? t1) t2)
#:no-order
#:when (not (or (set-member? resolved (cons t1 t2))
(set-member? resolved (cons t2 t1))))
(intersect (resolve t1) t2 (set-add resolved (cons t1 t2)))]
;; t2 and t1 have a complex relationship, so we build an intersection
;; (note: intersection checks for overlap)
[(t1 t2) (-unsafe-intersect t1 t2)])))

16
typed-racket-lib/typed-racket/infer/promote-demote.rkt
View File

@ -15,13 +15,13 @@
(for/or ([e (in-list (append* (map fv ts)))])
(memq e V)))
;; get-propset : SomeValues -> PropSet
;; extract prop sets out of the range of a function type
(define (get-propsets rng)
;; get-filters : SomeValues -> FilterSet
;; extract filters out of the range of a function type
(define (get-filters rng)
(match rng
[(AnyValues: p) (list (-PS p p))]
[(Values: (list (Result: _ propsets _) ...)) propsets]
[(ValuesDots: (list (Result: _ propsets _) ...) _ _) propsets]))
[(AnyValues: f) (list (-FS f f))]
[(Values: (list (Result: _ lf _) ...)) lf]
[(ValuesDots: (list (Result: _ lf _) ...) _ _) lf]))
(begin-encourage-inline
@ -43,7 +43,7 @@
(match arr
[(arr: dom rng rest drest kws)
(cond
[(apply V-in? V (get-propsets rng))
[(apply V-in? V (get-filters rng))
#f]
[(and drest (memq (cdr drest) V))
(make-arr (map contra dom)
@ -63,7 +63,7 @@
[(Function: arrs)
(make-Function (filter-map arr-change arrs))]
[(? structural?) (structural-map T structural-recur)]
[(? Prop?) ((sub-f co) T)]
[(? Filter?) ((sub-f co) T)]
[(? Object?) ((sub-o co) T)]
[(? Type?) ((sub-t co) T)]))
(define (var-promote T V)

68
typed-racket-lib/typed-racket/infer/restrict.rkt Normal file
View File

@ -0,0 +1,68 @@
#lang racket/unit
(require "../utils/utils.rkt")
(require (rep type-rep)
(types abbrev base-abbrev union subtype remove-intersect resolve)
"signatures.rkt"
racket/match
racket/set)
(import infer^)
(export restrict^)
;; restrict t1 to be a subtype of t2
;; if `pref' is 'new, use t2 when giving up, otherwise use t1
(define (restrict t1 t2 [pref 'new])
;; build-type: build a type while propogating bottom
(define (build-type constructor . args)
(if (memf Bottom? args) -Bottom (apply constructor args)))
;; resolved is a set tracking previously seen restrict cases
;; (i.e. pairs of t1 t2) to prevent infinite unfolding.
;; subtyping performs a similar check for the same
;; reason
(define (restrict* t1 t2 pref resolved)
(match* (t1 t2)
;; already a subtype
[(_ _) #:when (subtype t1 t2)
t1]
;; polymorphic restrict
[(_ (Poly: vars t)) #:when (infer vars null (list t1) (list t) #f)
t1]
;; structural recursion on types
[((Pair: a1 d1) (Pair: a2 d2))
(build-type -pair
(restrict* a1 a2 pref resolved)
(restrict* d1 d2 pref resolved))]
;; FIXME: support structural updating for structs when structs are updated to
;; contain not only *if* they are polymorphic, but *which* fields are too
;;[((Struct: _ _ _ _ _ _)
;; (Struct: _ _ _ _ _ _))]
[((Syntax: t1*) (Syntax: t2*))
(build-type -Syntax (restrict* t1* t2* pref resolved))]
[((Promise: t1*) (Promise: t2*))
(build-type -Promise (restrict* t1* t2* pref resolved))]
;; unions
[((Union: t1s) _) (apply Un (map (λ (t1*) (restrict* t1* t2 pref resolved)) t1s))]
[(_ (Union: t2s)) (apply Un (map (λ (t2*) (restrict* t1 t2* pref resolved)) t2s))]
;; resolve resolvable types if we haven't already done so
[((? needs-resolving?) _) #:when (not (set-member? resolved (cons t1 t2)))
(restrict* (resolve t1) t2 pref (set-add resolved (cons t1 t2)))]
[(_ (? needs-resolving?)) #:when (not (set-member? resolved (cons t1 t2)))
(restrict* t1 (resolve t2) pref (set-add resolved (cons t1 t2)))]
;; we don't actually want this - want something that's a part of t1
[(_ _) #:when (subtype t2 t1)
t2]
;; there's no overlap, so the restriction is empty
[(_ _) #:when (not (overlap t1 t2))
(Un)]
;; t2 and t1 have a complex relationship, so we punt
[(_ _) (if (eq? pref 'new) t2 t1)]))
(restrict* t1 t2 pref (set)))

4
typed-racket-lib/typed-racket/infer/signatures.rkt
View File

@ -20,8 +20,8 @@
[cond-contracted cset-join ((listof cset?) . -> . cset?)]
[cond-contracted c-meet ((c? c?) (symbol?) . ->* . (or/c #f c?))]))
(define-signature intersect^
([cond-contracted intersect (Type/c Type/c . -> . Type/c)]))
(define-signature restrict^
([cond-contracted restrict ((Type/c Type/c) ((or/c 'new 'orig)) . ->* . Type/c)]))
(define-signature infer^
([cond-contracted infer ((;; variables from the forall

25
typed-racket-lib/typed-racket/private/cast-table.rkt
View File

@ -1,25 +0,0 @@
#lang racket/base
(provide cast-table-ref
cast-table-set!)
(require syntax/id-table)
;; A module that helps store information about the original types of casted
;; expressions.
;;
;; Casts in Typed Racket must generate two contracts. One from typed to untyped,
;; and another from untyped to typed. The contract from typed to untyped is
;; generated based on the existing type of the expression, which must be stored
;; in this table so that it can be looked up later in the contract-generation
;; pass.
(define cast-table (make-free-id-table))
;; cast-table-set! : Id Type-Stx -> Void
(define (cast-table-set! id type-stx)
(free-id-table-set! cast-table id type-stx))
;; cast-table-ref : Id -> (U False Type-Stx)
(define (cast-table-ref id)
(free-id-table-ref cast-table id #f))

69
typed-racket-lib/typed-racket/private/parse-type.rkt
View File

@ -2,12 +2,11 @@
;; This module provides functions for parsing types written by the user
(require (rename-in "../utils/utils.rkt" [infer infer-in])
(require "../utils/utils.rkt"
(except-in (rep type-rep object-rep) make-arr)
(rename-in (types abbrev union utils prop-ops resolve
(rename-in (types abbrev union utils filter-ops resolve
classes prefab signatures)
[make-arr* make-arr])
(only-in (infer-in infer) intersect)
(utils tc-utils stxclass-util literal-syntax-class)
syntax/stx (prefix-in c: (contract-req))
syntax/parse racket/sequence
@ -110,7 +109,6 @@
(define-literal-syntax-class #:for-label Bot)
(define-literal-syntax-class #:for-label Distinction)
(define-literal-syntax-class #:for-label Sequenceof)
(define-literal-syntax-class #:for-label ∩)
;; (Syntax -> Type) -> Syntax Any -> Syntax
;; See `parse-type/id`. This is a curried generalization.
@ -229,7 +227,7 @@
#:attributes (type)
(pattern (~optional (~seq #:rest type:non-keyword-ty))))
;; syntax classes for props, objects, and related things
;; syntax classes for filters, objects, and related things
(define-syntax-class path-elem
#:description "path element"
(pattern :car^
@ -246,8 +244,8 @@
#:description "!"
(pattern (~datum !)))
(define-splicing-syntax-class simple-latent-prop
#:description "latent prop"
(define-splicing-syntax-class simple-latent-filter
#:description "latent filter"
(pattern (~seq t:expr :@ pe:path-elem ...)
#:attr type (parse-type #'t)
#:attr path (attribute pe.pe))
@ -256,54 +254,54 @@
#:attr path '()))
(define-syntax-class (prop doms)
#:description "proposition"
#:description "filter proposition"
#:attributes (prop)
(pattern :Top^ #:attr prop -tt)
(pattern :Bot^ #:attr prop -ff)
(pattern :Top^ #:attr prop -top)
(pattern :Bot^ #:attr prop -bot)
;; Here is wrong check
(pattern (t:expr :@ ~! pe:path-elem ... (~var o (prop-object doms)))
#:attr prop (-is-type (-acc-path (attribute pe.pe) (attribute o.obj)) (parse-type #'t)))
(pattern (t:expr :@ ~! pe:path-elem ... (~var o (filter-object doms)))
#:attr prop (-filter (parse-type #'t) (-acc-path (attribute pe.pe) (attribute o.obj))))
;; Here is wrong check
(pattern (:! t:expr :@ ~! pe:path-elem ... (~var o (prop-object doms)))
#:attr prop (-not-type (-acc-path (attribute pe.pe) (attribute o.obj)) (parse-type #'t)))
(pattern (:! t:expr :@ ~! pe:path-elem ... (~var o (filter-object doms)))
#:attr prop (-not-filter (parse-type #'t) (-acc-path (attribute pe.pe) (attribute o.obj))))
(pattern (:! t:expr)
#:attr prop (-not-type 0 (parse-type #'t)))
#:attr prop (-not-filter (parse-type #'t) 0))
(pattern ((~datum and) (~var p (prop doms)) ...)
#:attr prop (apply -and (attribute p.prop)))
(pattern ((~datum or) (~var p (prop doms)) ...)
#:attr prop (apply -or (attribute p.prop)))
(pattern ((~literal implies) (~var p1 (prop doms)) (~var p2 (prop doms)))
#:attr prop (-or (negate-prop (attribute p1.prop)) (attribute p2.prop)))
#:attr prop (-imp (attribute p1.prop) (attribute p2.prop)))
(pattern t:expr
#:attr prop (-is-type 0 (parse-type #'t))))
#:attr prop (-filter (parse-type #'t) 0)))
(define-splicing-syntax-class (prop-object doms)
#:description "prop object"
(define-splicing-syntax-class (filter-object doms)
#:description "filter object"
#:attributes (obj)
(pattern i:id
#:fail-unless (identifier-binding #'i)
"Propositions for predicates may not reference identifiers that are unbound"
"Filters for predicates may not reference identifiers that are unbound"
#:fail-when (is-var-mutated? #'i)
"Propositions for predicates may not reference identifiers that are mutated"
"Filters for predicates may not reference identifiers that are mutated"
#:attr obj (-id-path #'i))
(pattern idx:nat
#:do [(define arg (syntax-e #'idx))]
#:fail-unless (< arg (length doms))
(format "Proposition's object index ~a is larger than argument length ~a"
(format "Filter proposition's object index ~a is larger than argument length ~a"
arg (length doms))
#:attr obj (-arg-path arg 0))
(pattern (~seq depth-idx:nat idx:nat)
#:do [(define arg (syntax-e #'idx))
(define depth (syntax-e #'depth-idx))]
#:fail-unless (<= depth (length (current-arities)))
(format "Index ~a used in a proposition, but the use is only within ~a enclosing functions"
(format "Index ~a used in a filter, but the use is only within ~a enclosing functions"
depth (length (current-arities)))
#:do [(define actual-arg
(if (zero? depth)
(length doms)
(list-ref (current-arities) (sub1 depth))))]
#:fail-unless (< arg actual-arg)
(format "Proposition's object index ~a is larger than argument length ~a"
(format "Filter proposition's object index ~a is larger than argument length ~a"
depth actual-arg)
#:attr obj (-arg-path arg (syntax-e #'depth-idx))))
@ -468,10 +466,6 @@
t*))))]
[(:U^ ts ...)
(apply Un (parse-types #'(ts ...)))]
[(:∩^ ts ...)
(for/fold ([ty Univ])
([t (in-list (parse-types #'(ts ...)))])
(intersect ty t))]
[(:quote^ t)
(parse-quoted-type #'t)]
[(:All^ . rest)
@ -504,9 +498,9 @@
(list (make-arr
doms
(parse-type (syntax/loc stx (rest-dom ...))))))))]
[(~or (:->^ dom rng :colon^ latent:simple-latent-prop)
(dom :->^ rng :colon^ latent:simple-latent-prop))
;; use parse-type instead of parse-values-type because we need to add the props from the pred-ty
[(~or (:->^ dom rng :colon^ latent:simple-latent-filter)
(dom :->^ rng :colon^ latent:simple-latent-filter))
;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty
(with-arity 1
(make-pred-ty (list (parse-type #'dom)) (parse-type #'rng) (attribute latent.type)
(-acc-path (attribute latent.path) (-arg-path 0))))]
@ -566,11 +560,11 @@
:colon^ (~var latent (full-latent (syntax->list #'(dom ...)))))
(dom:non-keyword-ty ... :->^ rng:expr
~! :colon^ (~var latent (full-latent (syntax->list #'(dom ...))))))
;; use parse-type instead of parse-values-type because we need to add the props from the pred-ty
;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty
(with-arity (length (syntax->list #'(dom ...)))
(->* (parse-types #'(dom ...))
(parse-type #'rng)
: (-PS (attribute latent.positive) (attribute latent.negative))
: (-FS (attribute latent.positive) (attribute latent.negative))
: (attribute latent.object)))]
[(:->*^ (~var mand (->*-args #t))
(~optional (~var opt (->*-args #f))
@ -930,12 +924,11 @@
(define (parse-tc-results stx)
(syntax-parse stx
[((~or :Values^ :values^) t ...)
(define empties (stx-map (λ (x) #f) #'(t ...)))
(ret (parse-types #'(t ...))
empties
empties)]
[:AnyValues^ (tc-any-results #f)]
[t (ret (parse-type #'t) #f #f)]))
(stx-map (lambda (x) -no-filter) #'(t ...))
(stx-map (lambda (x) -no-obj) #'(t ...)))]
[:AnyValues^ (tc-any-results -no-filter)]
[t (ret (parse-type #'t) -no-filter -no-obj)]))
(define parse-type/id (parse/id parse-type))

3
typed-racket-lib/typed-racket/private/syntax-properties.rkt
View File

@ -50,10 +50,9 @@
(ignore typechecker:ignore #:mark)
(ignore-some typechecker:ignore-some #:mark)
(ignore-some-expr typechecker:ignore-some)
(contract-def typechecker:contract-def) ; -> Contract-Def (struct in type-contract.rkt)
(contract-def typechecker:contract-def)
(contract-def/provide typechecker:contract-def/provide)
(external-check typechecker:external-check)
(casted-expr typechecker:casted-expr) ; Type -> Void, takes the original type of the casted expr
(with-type typechecker:with-type #:mark)
(type-ascription type-ascription)
(type-inst type-inst)

82
typed-racket-lib/typed-racket/private/type-contract.rkt
View File

@ -5,7 +5,7 @@
(require
"../utils/utils.rkt"
syntax/parse
(rep type-rep prop-rep object-rep)
(rep type-rep filter-rep object-rep)
(utils tc-utils)
(env type-name-env row-constraint-env)
(rep rep-utils)
@ -14,10 +14,10 @@
(private parse-type syntax-properties)
racket/match racket/syntax racket/list
racket/format
racket/dict racket/set
racket/dict
syntax/flatten-begin
(only-in (types abbrev) -Bottom -Boolean)
(static-contracts instantiate optimize structures combinators constraints)
(static-contracts instantiate optimize structures combinators)
;; TODO make this from contract-req
(prefix-in c: racket/contract)
(contract-req)
@ -39,26 +39,14 @@
;; submod for testing
(module* test-exports #f (provide type->contract))
;; has-contrat-def-property? : Syntax -> Boolean
(define (has-contract-def-property? stx)
(syntax-parse stx
#:literal-sets (kernel-literals)
[(define-values (_) e)
(and (contract-def-property #'e)
#t)]
[_ #f]))
(struct contract-def (type flat? maker? typed-side) #:prefab)
;; get-contract-def-property : Syntax -> (U False Contract-Def)
;; Checks if the given syntax needs to be fixed up for contract generation
;; and if yes it returns the information stored in the property
(define (get-contract-def-property stx)
(syntax-parse stx
#:literal-sets (kernel-literals)
[(define-values (_) e)
(and (contract-def-property #'e)
((contract-def-property #'e)))]
[(define-values (_) e) (contract-def-property #'e)]
[_ #f]))
;; type->contract-fail : Syntax Type #:ctc-str String
@ -135,7 +123,7 @@
[else
(match-define (list defs ctc) result)
(define maybe-inline-val
(should-inline-contract?/cache ctc cache))
(should-inline-contract? ctc cache))
#`(begin #,@defs
#,@(if maybe-inline-val
null
@ -153,11 +141,18 @@
;; Syntax (Dict Static-Contract (Cons Id Syntax)) -> (Option Syntax)
;; A helper for generate-contract-def/provide that helps inline contract
;; expressions when needed to cooperate with the contract system's optimizations
(define (should-inline-contract?/cache ctc-stx cache)
(define (should-inline-contract? ctc-stx cache)
(and (identifier? ctc-stx)
(let ([match? (assoc ctc-stx (hash-values cache) free-identifier=?)])
(and match?
(should-inline-contract? (cdr match?))
(or
;; no need to generate an extra def for things that are already identifiers
(identifier? match?)
;; ->* are handled specially by the contract system
(let ([sexp (syntax-e (cdr match?))])
(and (pair? sexp)
(or (free-identifier=? (car sexp) #'->)
(free-identifier=? (car sexp) #'->*)))))
(cdr match?)))))
;; The below requires are needed since they provide identifiers that
@ -190,7 +185,7 @@
(define sc-cache (make-hash))
(with-new-name-tables
(for/list ((e (in-list forms)))
(if (not (has-contract-def-property? e))
(if (not (get-contract-def-property e))
e
(begin (set-box! include-extra-requires? #t)
(generate-contract-def e ctc-cache sc-cache))))))
@ -216,15 +211,6 @@
ctc-cache sc-cache)))]
[_ form]))))
;; get-max-contract-kind
;; static-contract -> (or/c 'flat 'chaperone 'impersonator)
;; recurse into a contract finding the max
;; kind (e.g. flat < chaperone < impersonator)
(define (get-max-contract-kind sc)
(define (get-restriction sc)
(sc->constraints sc get-restriction))
(kind-max-max (contract-restrict-value (get-restriction sc))))
;; To avoid misspellings
(define impersonator-sym 'impersonator)
(define chaperone-sym 'chaperone)
@ -399,21 +385,6 @@
(if numeric-sc
(apply or/sc numeric-sc (map t->sc non-numeric))
(apply or/sc (map t->sc elems)))]
[(Intersection: ts)
(define-values (chaperones/impersonators others)
(for/fold ([cs/is null] [others null])
([elem (in-immutable-set ts)])
(define c (t->sc elem))
(if (equal? flat-sym (get-max-contract-kind c))
(values cs/is (cons c others))
(values (cons c cs/is) others))))
(cond
[(> (length chaperones/impersonators) 1)
(fail #:reason (~a "Intersection type contract contains"
" more than 1 non-flat contract: "
type))]
[else
(apply and/sc (append others chaperones/impersonators))])]
[(and t (Function: arrs))
#:when (any->bool? arrs)
;; Avoid putting (-> any T) contracts on struct predicates (where Boolean <: T)
@ -619,14 +590,7 @@
[(Syntax: t)
(syntax/sc (t->sc t))]
[(Value: v)
(if (and (c:flat-contract? v)
;; numbers used as contracts compare with =, but TR
;; requires an equal? check
(not (number? v))
;; regexps don't match themselves when used as contracts
(not (regexp? v)))
(flat/sc #`(quote #,v))
(flat/sc #`(flat-named-contract '#,v (lambda (x) (equal? x '#,v))) v))]
(flat/sc #`(flat-named-contract '#,v (lambda (x) (equal? x '#,v))) v)]
[(Param: in out)
(parameter/sc (t->sc in) (t->sc out))]
[(Hashtable: k v)
@ -649,21 +613,17 @@
;; and call the given thunk or raise an error
(define (handle-range arr convert-arr)
(match arr
;; functions with no props or objects
[(arr: dom (Values: (list (Result: rngs
(PropSet: (TrueProp:)
(TrueProp:))
(Empty:)) ...))
rst drst kws)
;; functions with no filters or objects
[(arr: dom (Values: (list (Result: rngs (FilterSet: (Top:) (Top:)) (Empty:)) ...)) rst drst kws)
(convert-arr)]
;; Functions that don't return
[(arr: dom (Values: (list (Result: (== -Bottom) _ _) ...)) rst drst kws)
(convert-arr)]
;; functions with props or objects
;; functions with filters or objects
[(arr: dom (Values: (list (Result: rngs _ _) ...)) rst drst kws)
(if (from-untyped? typed-side)
(fail #:reason (~a "cannot generate contract for function type"
" with props or objects."))
" with filters or objects."))
(convert-arr))]
[(arr: dom (? ValuesDots?) rst drst kws)
(fail #:reason (~a "cannot generate contract for function type"
@ -837,7 +797,7 @@
(let/ec escape
(let loop ([type type])
(type-case
(#:Type loop #:Prop (sub-f loop) #:Object (sub-o loop))
(#:Type loop #:Filter (sub-f loop) #:Object (sub-o loop))
type
[#:App arg _ _
(match arg

3
typed-racket-lib/typed-racket/private/with-types.rkt
View File

@ -154,11 +154,10 @@
(define (type-stxs->ids+defs type-stxs typed-side)
(for/lists (_1 _2) ([t (in-list type-stxs)])
(define ctc-id (generate-temporary))
(define contract-def `#s(contract-def ,t #f #f ,typed-side))
(values ctc-id
#`(define-values (#,ctc-id)
#,(contract-def-property
#'#f (λ () contract-def))))))
#'#f `#s(contract-def ,t #f #f ,typed-side))))))
(define (wt-core stx)
(define-syntax-class typed-id

70
typed-racket-lib/typed-racket/rep/filter-rep.rkt
View File

@ -1,4 +1,70 @@
#lang racket/base
(require "prop-rep.rkt")
(provide (all-from-out "prop-rep.rkt"))
(require "../utils/utils.rkt" "rep-utils.rkt" "free-variance.rkt")
(provide hash-name filter-equal?)
(begin-for-cond-contract
(require racket/contract/base racket/lazy-require)
(lazy-require ["type-rep.rkt" (Type/c Univ? Bottom?)]
["object-rep.rkt" (Path?)]))
(provide-for-cond-contract Filter/c FilterSet/c name-ref/c)
(define-for-cond-contract (Filter/c-predicate? e)
(and (Filter? e) (not (NoFilter? e)) (not (FilterSet? e))))
(define-for-cond-contract Filter/c
(flat-named-contract 'Filter Filter/c-predicate?))
(define-for-cond-contract FilterSet/c
(flat-named-contract
'FilterSet
(λ (e) (or (FilterSet? e) (NoFilter? e)))))
;; A Name-Ref is any value that represents an object.
;; As an identifier, it represents a free variable in the environment
;; As a list, it represents a De Bruijn indexed bound variable
(define-for-cond-contract name-ref/c
(or/c identifier? (list/c integer? integer?)))
(define (hash-name v) (if (identifier? v) (hash-id v) (list v)))
(define-for-cond-contract ((length>=/c len) l)
(and (list? l)
(>= (length l) len)))
(def-filter Bot () [#:fold-rhs #:base])
(def-filter Top () [#:fold-rhs #:base])
(def-filter TypeFilter ([t (and/c Type/c (not/c Univ?) (not/c Bottom?))] [p Path?])
[#:intern (list (Rep-seq t) (Rep-seq p))]
[#:frees (λ (f) (combine-frees (map f (list t p))))]
[#:fold-rhs (*TypeFilter (type-rec-id t) (object-rec-id p))])
(def-filter NotTypeFilter ([t (and/c Type/c (not/c Univ?) (not/c Bottom?))] [p Path?])
[#:intern (list (Rep-seq t) (Rep-seq p))]
[#:frees (λ (f) (combine-frees (map f (list t p))))]
[#:fold-rhs (*NotTypeFilter (type-rec-id t) (object-rec-id p))])
;; implication
(def-filter ImpFilter ([a Filter/c] [c Filter/c]))
(def-filter OrFilter ([fs (and/c (length>=/c 2)
(listof (or/c TypeFilter? NotTypeFilter? ImpFilter?)))])
[#:intern (map Rep-seq fs)]
[#:fold-rhs (*OrFilter (map filter-rec-id fs))]
[#:frees (λ (f) (combine-frees (map f fs)))])
(def-filter AndFilter ([fs (and/c (length>=/c 2)
(listof (or/c OrFilter? TypeFilter? NotTypeFilter? ImpFilter?)))])
[#:intern (map Rep-seq fs)]
[#:fold-rhs (*AndFilter (map filter-rec-id fs))]
[#:frees (λ (f) (combine-frees (map f fs)))])
(def-filter FilterSet ([thn Filter/c] [els Filter/c])
[#:fold-rhs (*FilterSet (filter-rec-id thn) (filter-rec-id els))])
;; represents no info about the filters of this expression
;; should only be used for parsing type annotations and expected types
(def-filter NoFilter () [#:fold-rhs #:base])
(define (filter-equal? a b) (= (Rep-seq a) (Rep-seq b)))

14
typed-racket-lib/typed-racket/rep/object-rep.rkt
View File

@ -5,7 +5,7 @@
;;
;; See "Logical Types for Untyped Languages" pg.3
(require "rep-utils.rkt" "free-variance.rkt" "prop-rep.rkt" "../utils/utils.rkt" (contract-req))
(require "rep-utils.rkt" "free-variance.rkt" "filter-rep.rkt" "../utils/utils.rkt" (contract-req))
(provide object-equal?)
(def-pathelem CarPE () [#:fold-rhs #:base])
@ -25,4 +25,16 @@
[#:frees (λ (f) (combine-frees (map f p)))]
[#:fold-rhs (*Path (map pathelem-rec-id p) v)])
;; represents no info about the object of this expression
;; should only be used for parsing type annotations and expected types
(def-object NoObject () [#:fold-rhs #:base])
(define (object-equal? o1 o2) (= (Rep-seq o1) (Rep-seq o2)))
#|
(dlo LEmpty () [#:fold-rhs #:base])
(dlo LPath ([p (listof PathElem?)] [idx index/c])
[#:frees (λ (f) (combine-frees (map f p)))]
[#:fold-rhs (*LPath (map pathelem-rec-id p) idx)])
|#

56
typed-racket-lib/typed-racket/rep/prop-rep.rkt
View File

@ -1,56 +0,0 @@
#lang racket/base
(require "../utils/utils.rkt" "rep-utils.rkt" "free-variance.rkt")
(provide hash-name prop-equal?)
(begin-for-cond-contract
(require racket/contract/base racket/lazy-require)
(lazy-require ["type-rep.rkt" (Type/c Univ? Bottom?)]
["object-rep.rkt" (Path?)]))
(provide-for-cond-contract name-ref/c)
;; A Name-Ref is any value that represents an object.
;; As an identifier, it represents a free variable in the environment
;; As a list, it represents a De Bruijn indexed bound variable
(define-for-cond-contract name-ref/c
(or/c identifier? (list/c integer? integer?)))
(define (hash-name v) (if (identifier? v) (hash-id v) (list v)))
(define-for-cond-contract ((length>=/c len) l)
(and (list? l)
(>= (length l) len)))
;; the trivially "true" proposition
(def-prop TrueProp () [#:fold-rhs #:base])
;; the absurd, "false" proposition
(def-prop FalseProp () [#:fold-rhs #:base])
(def-prop TypeProp ([p Path?] [t (and/c Type/c (not/c Univ?) (not/c Bottom?))])
[#:intern (list (Rep-seq t) (Rep-seq p))]
[#:frees (λ (f) (combine-frees (map f (list t p))))]
[#:fold-rhs (*TypeProp (object-rec-id p) (type-rec-id t))])
(def-prop NotTypeProp ([p Path?] [t (and/c Type/c (not/c Univ?) (not/c Bottom?))])
[#:intern (list (Rep-seq t) (Rep-seq p))]
[#:frees (λ (f) (combine-frees (map f (list t p))))]
[#:fold-rhs (*NotTypeProp (object-rec-id p) (type-rec-id t))])
(def-prop OrProp ([fs (and/c (length>=/c 2)
(listof (or/c TypeProp? NotTypeProp?)))])
[#:intern (map Rep-seq fs)]
[#:fold-rhs (*OrProp (map prop-rec-id fs))]
[#:frees (λ (f) (combine-frees (map f fs)))])
(def-prop AndProp ([fs (and/c (length>=/c 2)
(listof (or/c OrProp? TypeProp? NotTypeProp?)))])
[#:intern (map Rep-seq fs)]
[#:fold-rhs (*AndProp (map prop-rec-id fs))]
[#:frees (λ (f) (combine-frees (map f fs)))])
(def-prop PropSet ([thn Prop?] [els Prop?])
[#:fold-rhs (*PropSet (prop-rec-id thn) (prop-rec-id els))])
(define (prop-equal? a b) (= (Rep-seq a) (Rep-seq b)))

16
typed-racket-lib/typed-racket/rep/rep-utils.rkt
View File

@ -20,7 +20,7 @@
(lazy-require
["../types/printer.rkt" (print-type print-prop print-object print-pathelem)])
["../types/printer.rkt" (print-type print-filter print-object print-pathelem)])
(provide == defintern hash-id (for-syntax fold-target))
@ -135,7 +135,7 @@
#:defaults
([frees.f1 (combiner #'Rep-free-vars #'flds.fields)]
[frees.f2 (combiner #'Rep-free-idxs #'flds.fields)]))
;; This tricky beast is for defining the type/prop/etc.'s
;; This tricky beast is for defining the type/filter/etc.'s
;; part of the fold. The make-prim-type's given
;; rec-ids are bound in this expression's context.
(~optional [#:fold-rhs (~var fold-rhs (fold-pat #'name.fold))]
@ -204,7 +204,7 @@
provides))])))
;; rec-ids are identifiers that are of the folded type, so we recur on them.
;; kws is e.g. '(#:Type #:Prop #:Object #:PathElem)
;; kws is e.g. '(#:Type #:Filter #:Object #:PathElem)
(define-for-syntax (mk-fold hashtable rec-ids kws)
(lambda (stx)
(define new-hashtable (make-hasheq))
@ -217,7 +217,7 @@
(syntax/loc this-syntax (pats ...))
(lambda () #'e)
this-syntax))
;; Match on a type (or prop etc) case with keyword k
;; Match on a type (or filter etc) case with keyword k
;; pats are the unignored patterns (say for rator rand)
;; and e is the expression that will run as fold-rhs.
(pattern
@ -351,18 +351,18 @@
;; [unsyntax (*1)]
(mk-fold ht
rec-ids
;; '(#:Type #:Prop #:Object #:PathElem)
;; '(#:Type #:Filter #:Object #:PathElem)
'(i.kw ...)))
(list i.hashtable ...))))))]))
(make-prim-type [Type def-type #:Type type-case print-type type-name-ht type-rec-id #:key]
[Prop def-prop #:Prop prop-case print-prop prop-name-ht prop-rec-id]
[Filter def-filter #:Filter filter-case print-filter filter-name-ht filter-rec-id]
[Object def-object #:Object object-case print-object object-name-ht object-rec-id]
[PathElem def-pathelem #:PathElem pathelem-case print-pathelem pathelem-name-ht pathelem-rec-id])
(define (Rep-values rep)
(match rep
[(? (lambda (e) (or (Prop? e)
[(? (lambda (e) (or (Filter? e)
(Object? e)
(PathElem? e)))
(app (lambda (v) (vector->list (struct->vector v))) (list-rest tag seq fv fi stx vals)))
@ -386,7 +386,7 @@
(provide/cond-contract
[rename rep-equal? type-equal? (Type? Type? . -> . boolean?)]
[rename rep<? type<? (Type? Type? . -> . boolean?)]
[rename rep<? prop<? (Prop? Prop? . -> . boolean?)]
[rename rep<? filter<? (Filter? Filter? . -> . boolean?)]
[struct Rep ([seq exact-nonnegative-integer?]
[free-vars (hash/c symbol? variance?)]
[free-idxs (hash/c symbol? variance?)]

81
typed-racket-lib/typed-racket/rep/type-rep.rkt
View File

@ -7,8 +7,8 @@
;; TODO use contract-req
(require (utils tc-utils)
"rep-utils.rkt" "object-rep.rkt" "prop-rep.rkt" "free-variance.rkt"
racket/match racket/list racket/set
"rep-utils.rkt" "object-rep.rkt" "filter-rep.rkt" "free-variance.rkt"
racket/match racket/list
racket/contract
racket/lazy-require
racket/promise
@ -19,11 +19,10 @@
PolyDots-names:
PolyRow-names: PolyRow-fresh:
Type-seq
-unsafe-intersect
Mu-unsafe: Poly-unsafe:
PolyDots-unsafe:
Mu? Poly? PolyDots? PolyRow?
Prop? Object?
Filter? Object?
Type/c Type/c?
Values/c SomeValues/c
Bottom?
@ -54,9 +53,8 @@
;; Ugly hack - should use units
(lazy-require
("../types/union.rkt" (Un))
("../types/overlap.rkt" (overlap?))
("../types/resolve.rkt" (resolve-app)))
("../types/union.rkt" (Un))
("../types/resolve.rkt" (resolve-app)))
(define name-table (make-weak-hasheq))
@ -276,9 +274,9 @@
[#:frees (λ (f) (f ty))]
[#:fold-rhs (*Keyword kw (type-rec-id ty) required?)])
(def-type Result ([t Type/c] [f PropSet?] [o Object?])
(def-type Result ([t Type/c] [f FilterSet?] [o Object?])
[#:frees (λ (frees) (combine-frees (map frees (list t f o))))]
[#:fold-rhs (*Result (type-rec-id t) (prop-rec-id f) (object-rec-id o))])
[#:fold-rhs (*Result (type-rec-id t) (filter-rec-id f) (object-rec-id o))])
(def-type Values ([rs (listof Result?)])
[#:intern (map Rep-seq rs)]
@ -286,7 +284,7 @@
[#:fold-rhs (*Values (map type-rec-id rs))])
(def-type AnyValues ([f Prop?])
(def-type AnyValues ([f Filter/c])
[#:fold-rhs #:base])
(def-type ValuesDots ([rs (listof Result?)] [dty Type/c] [dbound (or/c symbol? natural-number/c)])
@ -451,55 +449,6 @@
(define d* (remove-duplicates d))
(if (and (pair? d*) (null? (cdr d*))) (car d*) d*))])
;; Intersection
(def-type Intersection ([elems (and/c (set/c Type/c)
(λ (s) (>= (set-count s) 2)))])
[#:intern (for/set ([e (in-immutable-set elems)])
(Rep-seq e))]
[#:frees (λ (f) (combine-frees (for/list ([elem (in-immutable-set elems)])
(f elem))))]
[#:fold-rhs (let ([elems (for/list ([elem (in-immutable-set elems)])
(type-rec-id elem))])
(apply -unsafe-intersect elems))]
[#:key (let ()
(define d
(let loop ([ts (set->list elems)] [res null])
(cond [(null? ts) res]
[else
(define k (Type-key (car ts)))
(cond [(not k) (list #f)]
[(pair? k) (loop (cdr ts) (append k res))]
[else (loop (cdr ts) (cons k res))])])))
(define d* (remove-duplicates d))
(if (and (pair? d*) (null? (cdr d*))) (car d*) d*))])
;; constructor for intersections
;; in general, intersections should be built
;; using the 'intersect' operator, which worries
;; about actual subtyping, etc...
(define (-unsafe-intersect . ts)
(let loop ([elems (set)]
[ts ts])
(match ts
[(list)
(cond
[(set-empty? elems) (Univ)]
;; size = 1 ?
[(= 1 (set-count elems)) (set-first elems)]
;; size > 1, build an intersection
[else (*Intersection elems)])]
[(cons t ts)
(match t
[(? Bottom?) t]
[(Univ:) (loop elems ts)]
[(Intersection: ts*) (loop (set-union elems ts*) ts)]
[t (cond
[(for/or ([elem (in-immutable-set elems)]) (not (overlap? elem t)))
(*Union (list))]
[else (loop (set-add elems t) ts)])])])))
(def-type Univ () [#:frees #f] [#:fold-rhs #:base])
;; in : Type
@ -668,10 +617,10 @@
(define ((sub-f st) e)
(prop-case (#:Type st
#:Prop (sub-f st)
#:PathElem (sub-pe st))
e))
(filter-case (#:Type st
#:Filter (sub-f st)
#:PathElem (sub-pe st))
e))
(define ((sub-o st) e)
@ -687,7 +636,7 @@
(define ((sub-t st) e)
(type-case (#:Type st
#:Prop (sub-f st))
#:Filter (sub-f st))
e))
@ -708,7 +657,7 @@
(f (+ (cdr pr) outer)))]
[else default]))
(type-case
(#:Type sb #:Prop (sub-f sb) #:Object (sub-o sb))
(#:Type sb #:Filter (sub-f sb) #:Object (sub-o sb))
ty
[#:F name* (transform name* *B ty)]
;; necessary to avoid infinite loops
@ -762,7 +711,7 @@
(define (sb t) (loop outer t))
(define sf (sub-f sb))
(type-case
(#:Type sb #:Prop sf #:Object (sub-o sb))
(#:Type sb #:Filter sf #:Object (sub-o sb))
ty
[#:B idx (transform idx values ty)]
;; necessary to avoid infinite loops

19
typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt
View File

@ -33,25 +33,6 @@
(struct simple-contract static-contract (syntax kind name)
#:transparent
#:methods gen:equal+hash
[(define (equal-proc s1 s2 recur)
(and ;; only check s-expression equality because it's
;; unlikely that TR will compile contracts that are
;; s-exp equal but aren't actually the same contract
(recur (syntax->datum (simple-contract-syntax s1))
(syntax->datum (simple-contract-syntax s2)))
(recur (simple-contract-kind s1)
(simple-contract-kind s2))
(recur (simple-contract-name s1)
(simple-contract-name s2))))
(define (hash-proc sc hash-code)
(hash-code (list (syntax->datum (simple-contract-syntax sc))
(simple-contract-kind sc)
(simple-contract-name sc))))
(define (hash2-proc sc hash-code)
(hash-code (list (syntax->datum (simple-contract-syntax sc))
(simple-contract-kind sc)
(simple-contract-name sc))))]
#:methods gen:sc
[(define (sc-map v f) v)
(define (sc-traverse v f) (void))

3
typed-racket-lib/typed-racket/static-contracts/constraints.rkt
View File

@ -61,8 +61,7 @@
contract-restrict-recursive-values
contract-restrict?
contract-restrict-value
kind-max-max)
)
(module structs racket/base
(require racket/contract

29
typed-racket-lib/typed-racket/static-contracts/instantiate.rkt
View File

@ -23,8 +23,7 @@
[instantiate
(parametric->/c (a) ((static-contract? (-> #:reason (or/c #f string?) a))
(contract-kind? #:cache hash?)
. ->* . (or/c a (list/c (listof syntax?) syntax?))))]
[should-inline-contract? (-> syntax? boolean?)]))
. ->* . (or/c a (list/c (listof syntax?) syntax?))))]))
;; Providing these so that tests can work directly with them.
(module* internals #f
@ -130,9 +129,7 @@
(define bound-names (make-parameter null))
;; sc-queue : records the order in which to return syntax objects
(define sc-queue null)
;; top-level? is #t only for the first call and not for recursive
;; calls, which helps for inlining
(define (recur sc [top-level? #f])
(define (recur sc)
(cond [(and cache (hash-ref cache sc #f)) => car]
[(arr/sc? sc) (make-contract sc)]
[(or (parametric->/sc? sc) (sealing->/sc? sc))
@ -147,14 +144,7 @@
(make-contract sc)]
[else
(define ctc (make-contract sc))
(cond [(and ;; when a contract benefits from inlining
;; (e.g., ->) and this contract appears
;; directly in a define-module-boundary-contract
;; position (i.e, top-level? is #t) then
;; don't generate a new identifier for it
(or (not (should-inline-contract? ctc))
(not top-level?))
cache)
(cond [(and (not (identifier? ctc)) cache)
(define fresh-id (generate-temporary))
(hash-set! cache sc (cons fresh-id ctc))
(set! sc-queue (cons sc sc-queue))
@ -180,7 +170,7 @@
(recur body)))]
[(? sc? sc)
(sc->contract sc recur)]))
(define ctc (recur sc #t))
(define ctc (recur sc))
(define name-defs (compute-defs sc))
;; These are extra contract definitions for the name static contracts
;; that are used for this type. Since these are shared across multiple
@ -206,17 +196,6 @@
#`(define #,id #,ctc)))
ctc))
;; Determine whether the given contract syntax should be inlined or not.
(define (should-inline-contract? stx)
(or
;; no need to generate an extra def for things that are already identifiers
(identifier? stx)
;; ->* are handled specially by the contract system
(let ([sexp (syntax-e stx)])
(and (pair? sexp)
(or (free-identifier=? (car sexp) #'->)
(free-identifier=? (car sexp) #'->*))))))
;; determine if a given name is free in the sc
(define (name-free-in? name sc)
(let/ec escape

135
typed-racket-lib/typed-racket/typecheck/check-below.rkt
View File

@ -3,9 +3,9 @@
(require "../utils/utils.rkt"
racket/match (prefix-in - (contract-req))
racket/format
(types utils union subtype prop-ops abbrev)
(types utils union subtype filter-ops abbrev)
(utils tc-utils)
(rep type-rep object-rep prop-rep)
(rep type-rep object-rep filter-rep)
(typecheck error-message))
(provide/cond-contract
@ -21,7 +21,7 @@
(define (print-object o)
(match o
[(or #f (Empty:)) "no object"]
[(or (NoObject:) (Empty:)) "no object"]
[_ (format "object ~a" o)]))
;; If expected is #f, then just return tr1
@ -45,36 +45,37 @@
(value-string expected) (value-string actual)
"mismatch in number of values"))
;; fix-props:
;; PropSet [PropSet] -> PropSet
;; or
;; Prop [Prop] -> Prop
;; Turns #f prop/propset into the actual prop; leaves other props alone.
(define (fix-props p1 [p2 -tt-propset])
(or p1 p2))
;; fix-filter: FilterSet [FilterSet] -> FilterSet
;; Turns NoFilter into the actual filter; leaves other filters alone.
(define (fix-filter f [f2 -top-filter])
(match f
[(NoFilter:) f2]
[else f]))
;; fix-object: Object [Object] -> Object
;; Turns #f into the actual object; leaves other objects alone.
(define (fix-object o1 [o2 -empty-obj])
(or o1 o2))
;; Turns NoObject into the actual object; leaves other objects alone.
(define (fix-object o [o2 -empty-obj])
(match o
[(NoObject:) o2]
[else o]))
;; fix-results: tc-results -> tc-results
;; Turns #f Prop or Obj into the Empty/Trivial
;; Turns NoObject/NoFilter into the Empty/TopFilter
(define (fix-results r)
(match r
[(tc-any-results: f) (tc-any-results (fix-props f -tt))]
[(tc-results: ts ps os)
(ret ts (map fix-props ps) (map fix-object os))]
[(tc-results: ts ps os dty dbound)
(ret ts (map fix-props ps) (map fix-object os) dty dbound)]))
[(tc-any-results: f) (tc-any-results (fix-filter f -top))]
[(tc-results: ts fs os)
(ret ts (map fix-filter fs) (map fix-object os))]
[(tc-results: ts fs os dty dbound)
(ret ts (map fix-filter fs) (map fix-object os) dty dbound)]))
(define (fix-results/bottom r)
(match r
[(tc-any-results: f) (tc-any-results (fix-props f -ff))]
[(tc-results: ts ps os)
(ret ts (for/list ([p ps]) (fix-props p -ff-propset)) (map fix-object os))]
[(tc-results: ts ps os dty dbound)
(ret ts (for/list ([p ps]) (fix-props p -ff-propset)) (map fix-object os) dty dbound)]))
[(tc-any-results: f) (tc-any-results (fix-filter f -bot))]
[(tc-results: ts fs os)
(ret ts (for/list ([f fs]) (fix-filter f -bot-filter)) (map fix-object os))]
[(tc-results: ts fs os dty dbound)
(ret ts (for/list ([f fs]) (fix-filter f -bot-filter)) (map fix-object os) dty dbound)]))
@ -83,74 +84,74 @@
;; (Type Results -> Type)
;; (Type Type -> Type))
(define (check-below tr1 expected)
(define (prop-set-better? p1 p2)
(match* (p1 p2)
[(p p) #t]
[(p #f) #t]
[((PropSet: p1+ p1-) (PropSet: p2+ p2-))
(and (implies-atomic? p1+ p2+)
(implies-atomic? p1- p2-))]
(define (filter-set-better? f1 f2)
(match* (f1 f2)
[(f f) #t]
[(f (NoFilter:)) #t]
[((FilterSet: f1+ f1-) (FilterSet: f2+ f2-))
(and (implied-atomic? f2+ f1+)
(implied-atomic? f2- f1-))]
[(_ _) #f]))
(define (object-better? o1 o2)
(match* (o1 o2)
[(o o) #t]
[(o (or #f (Empty:))) #t]
[(o (or (NoObject:) (Empty:))) #t]
[(_ _) #f]))
(define (prop-better? p1 p2)
(or (not p2)
(implies-atomic? p1 p2)))
(define (filter-better? f1 f2)
(or (NoFilter? f2)
(implied-atomic? f2 f1)))
(match* (tr1 expected)
;; This case has to be first so that bottom (exceptions, etc.) can be allowed in cases
;; where multiple values are expected.
;; We can ignore the props and objects in the actual value because they would never be about a value
;; We can ignore the filters and objects in the actual value because they would never be about a value
[((tc-result1: (? (lambda (t) (type-equal? t (Un))))) _)
(fix-results/bottom expected)]
[((tc-any-results: p1) (tc-any-results: p2))
(unless (prop-better? p1 p2)
(type-mismatch p2 p1 "mismatch in proposition"))
(tc-any-results (fix-props p2 p1))]
[((tc-any-results: f1) (tc-any-results: f2))
(unless (filter-better? f1 f2)
(type-mismatch f2 f1 "mismatch in filter"))
(tc-any-results (fix-filter f2 f1))]
[((or (tc-results: _ (list (PropSet: fs+ fs-) ...) _)
(tc-results: _ (list (PropSet: fs+ fs-) ...) _ _ _))
(tc-any-results: p2))
(define merged-prop (apply -and (map -or fs+ fs-)))
(unless (prop-better? merged-prop p2)
(type-mismatch p2 merged-prop "mismatch in proposition"))
(tc-any-results (fix-props p2 merged-prop))]
[((or (tc-results: _ (list (FilterSet: fs+ fs-) ...) _)
(tc-results: _ (list (FilterSet: fs+ fs-) ...) _ _ _))
(tc-any-results: f2))
(define merged-filter (apply -and (map -or fs+ fs-)))
(unless (filter-better? merged-filter f2)
(type-mismatch f2 merged-filter "mismatch in filter"))
(tc-any-results (fix-filter f2 merged-filter))]
[((tc-result1: t1 p1 o1) (tc-result1: t2 p2 o2))
[((tc-result1: t1 f1 o1) (tc-result1: t2 f2 o2))
(cond
[(not (subtype t1 t2))
(expected-but-got t2 t1)]
[(and (not (prop-set-better? p1 p2))
[(and (not (filter-set-better? f1 f2))
(object-better? o1 o2))
(type-mismatch p2 p1 "mismatch in proposition")]
[(and (prop-set-better? p1 p2)
(type-mismatch f2 f1 "mismatch in filter")]
[(and (filter-set-better? f1 f2)
(not (object-better? o1 o2)))
(type-mismatch (print-object o2) (print-object o1) "mismatch in object")]
[(and (not (prop-set-better? p1 p2))
[(and (not (filter-set-better? f1 f2))
(not (object-better? o1 o2)))
(type-mismatch (format "`~a' and `~a'" p2 (print-object o2))
(format "`~a' and `~a'" p1 (print-object o1))
"mismatch in proposition and object")])
(ret t2 (fix-props p2 p1) (fix-object o2 o1))]
(type-mismatch (format "`~a' and `~a'" f2 (print-object o2))
(format "`~a' and `~a'" f1 (print-object o1))
"mismatch in filter and object")])
(ret t2 (fix-filter f2 f1) (fix-object o2 o1))]
;; case where expected is like (Values a ... a) but got something else
[((tc-results: t1 p1 o1) (tc-results: t2 p2 o2 dty dbound))
[((tc-results: t1 f1 o1) (tc-results: t2 f2 o2 dty dbound))
(value-mismatch expected tr1)
(fix-results expected)]
;; case where you have (Values a ... a) but expected something else
[((tc-results: t1 p1 o1 dty dbound) (tc-results: t2 p2 o2))
[((tc-results: t1 f1 o1 dty dbound) (tc-results: t2 f2 o2))
(value-mismatch expected tr1)
(fix-results expected)]
[((tc-results: t1 p1 o1 dty1 dbound)
(tc-results: t2 (list (or #f (PropSet: (TrueProp:) (TrueProp:))) ...)
(list (or #f (Empty:)) ...) dty2 dbound))
[((tc-results: t1 f1 o1 dty1 dbound)
(tc-results: t2 (list (or (NoFilter:) (FilterSet: (Top:) (Top:))) ...)
(list (or (NoObject:) (Empty:)) ...) dty2 dbound))
(cond
[(= (length t1) (length t2))
(unless (andmap subtype t1 t2)
@ -161,7 +162,7 @@
(value-mismatch expected tr1)])
(fix-results expected)]
[((tc-results: t1 p1 o1 dty1 dbound) (tc-results: t2 p2 o2 dty2 dbound))
[((tc-results: t1 f1 o1 dty1 dbound) (tc-results: t2 f2 o2 dty2 dbound))
(cond
[(= (length t1) (length t2))
(unless (andmap subtype t1 t2)
@ -172,9 +173,9 @@
(value-mismatch expected tr1)])
(fix-results expected)]
[((tc-results: t1 p1 o1)
(tc-results: t2 (list (or #f (PropSet: (TrueProp:) (TrueProp:))) ...)
(list (or #f (Empty:)) ...)))
[((tc-results: t1 f1 o1)
(tc-results: t2 (list (or (NoFilter:) (FilterSet: (Top:) (Top:))) ...)
(list (or (NoObject:) (Empty:)) ...)))
(unless (= (length t1) (length t2))
(value-mismatch expected tr1))
(unless (for/and ([t (in-list t1)] [s (in-list t2)]) (subtype t s))
@ -188,7 +189,7 @@
(expected-but-got (stringify t2) (stringify t1)))
(fix-results expected)]
[((tc-results: t1 p1 o1) (tc-results: t2 p2 o2)) (=> continue)
[((tc-results: t1 f1 o1) (tc-results: t2 f2 o2)) (=> continue)
(if (= (length t1) (length t2))
(continue)
(value-mismatch expected tr1))
@ -203,5 +204,5 @@
(expected-but-got t2 t1))
expected]
[((tc-results: ts fs os dty dbound) (tc-results: ts* fs* os* dty* dbound*))
(int-err "dotted types with different bounds/propositions/objects in check-below nyi: ~a ~a" tr1 expected)]
(int-err "dotted types with different bounds/filters/objects in check-below nyi: ~a ~a" tr1 expected)]
[(a b) (int-err "unexpected input for check-below: ~a ~a" a b)]))

4
typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
View File

@ -461,7 +461,7 @@
(define-values (alias-names alias-map) (get-type-alias-info type-aliases))
(register-all-type-aliases alias-names alias-map)
;; Prop top level expressions into several groups, each processed
;; Filter top level expressions into several groups, each processed
;; into appropriate data structures
;;
;; Augment annotations go in their own table, because they're
@ -983,7 +983,7 @@
(do-timestamp (format "finished method ~a" external-name))
(cons (list external-name pre-method-type) checked)]
;; Only try to type-check if these names are in the
;; prop when it's provided. This allows us to, say, only
;; filter when it's provided. This allows us to, say, only
;; type-check pubments/augments.
[(set-member? names-to-check external-name)
(do-timestamp (format "started checking method ~a" external-name))

36
typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt
View File

@ -11,7 +11,7 @@
(utils tc-utils)
(for-syntax racket/base syntax/parse)
(for-template racket/base)
(rep type-rep prop-rep object-rep))
(rep type-rep filter-rep object-rep))
(import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-expr^)
(export check-subforms^)
@ -42,14 +42,14 @@
;; syntax tc-result1 type -> tc-results
;; The result of applying the function to a single argument of the type of its first argument
(define (get-range-result stx t prop-type)
(define (get-range-result stx t filter-type)
(let loop ((t t))
(match t
[(Function: (list _ ... (arr: (list arg1) _ _ #f (list (Keyword: _ _ #f) ...)) _ ...))
#:when (subtype prop-type arg1)
#:when (subtype filter-type arg1)
(tc/funapp #'here #'(here) t (list (ret arg1)) #f)]
[(Function: (list _ ... (arr: '() _ (? values rest) #f (list (Keyword: _ _ #f) ...)) _ ...))
#:when (subtype prop-type rest)
#:when (subtype filter-type rest)
(tc/funapp #'here #'(here) t (list (ret rest)) #f)]
[(? needs-resolving? t)
(loop (resolve t))]
@ -58,17 +58,17 @@
;; This clause should raise an error via the check-below test
[_
(cond [;; a redundant test, but it ensures an error message below
(not (subtype t (-> prop-type Univ)))
(not (subtype t (-> filter-type Univ)))
(parameterize ([current-orig-stx stx])
(check-below t (-> prop-type Univ)))]
[else (int-err "get-range-result: should not happen. type ~a prop ~a"
t prop-type)])
(check-below t (-> filter-type Univ)))]
[else (int-err "get-range-result: should not happen. type ~a filter ~a"
t filter-type)])
(ret (Un))])))
;; Syntax Type -> (Option Type)
;; Extract the type for the prop in a predicate type, or #f if
;; Extract the type for the filter in a predicate type, or #f if
;; the type is an invalid predicate type.
(define (get-prop-type stx pred-type)
(define (get-filter-type stx pred-type)
(cond [;; make sure the predicate has an appropriate type
(subtype pred-type (-> Univ Univ))
(define fun-type
@ -78,10 +78,10 @@
(match fun-type
;; FIXME: Almost all predicates fall into this case, but it may
;; be worth being more precise here for some rare code.
[(PredicateProp: ps)
(match ps
[(PropSet: (TypeProp: (Path: '() '(0 0)) ft) _) ft]
[(FalseProp:) (Un)]
[(PredicateFilter: fs)
(match fs
[(FilterSet: (TypeFilter: ft (Path: '() '(0 0))) _) ft]
[(Bot:) (Un)]
[_ Univ])]
[_ Univ])]
[else
@ -98,12 +98,12 @@
(hash-ref predicate-map key))
(match-define (list handler-stx handler-type)
(hash-ref handler-map key))
(define prop-type
(get-prop-type predicate-stx predicate-type))
(define filter-type
(get-filter-type predicate-stx predicate-type))
;; if the predicate doesn't check, then don't bother
;; with the RHS and return no result
(if prop-type
(get-range-result handler-stx handler-type prop-type)
(if filter-type
(get-range-result handler-stx handler-type filter-type)
(ret (Un)))))
(find-syntax form

4
typed-racket-lib/typed-racket/typecheck/error-message.rkt
View File

@ -18,8 +18,8 @@
(-or/c Type/c string?)
-any)]
[type-mismatch
(-->* ((-or/c Type/c Prop? string?)
(-or/c Type/c Prop? string?))
(-->* ((-or/c Type/c Filter? string?)
(-or/c Type/c Filter? string?))
((-or/c string? #f))
-any)])

10
typed-racket-lib/typed-racket/typecheck/possible-domains.rkt
View File

@ -4,7 +4,7 @@
(contract-req)
racket/list
racket/match
(rep type-rep prop-rep)
(rep type-rep filter-rep)
(except-in (types abbrev subtype tc-result)
-> ->* one-of/c))
@ -18,7 +18,7 @@
;; are relevant to this specific error
;; this is done in several ways:
;; - if a case-lambda case is subsumed by another, we don't need to show it
;; (subsumed cases may be useful for their prop information, but this is
;; (subsumed cases may be useful for their filter information, but this is
;; unrelated to error reporting)
;; - if we have an expected type, we don't need to show the domains for which
;; the result type is not a subtype of the expected type
@ -53,7 +53,7 @@
(and expected
(match expected
[(tc-result1: t) t]
[(tc-any-results: (or #f (TrueProp:))) #t] ; anything is a subtype of expected
[(tc-any-results: (or (Top:) (NoFilter:))) #t] ; anything is a subtype of expected
[_ #f]))) ; don't know what it is, don't do any pruning
(define (returns-subtype-of-expected? fun-ty)
(or (not expected) ; no expected type, anything is fine
@ -74,8 +74,8 @@
(define cases
(map (compose make-Function list make-arr)
doms
(map (match-lambda ; strip props
[(AnyValues: f) (-AnyValues -tt)]
(map (match-lambda ; strip filters
[(AnyValues: f) (-AnyValues -top)]
[(Values: (list (Result: t _ _) ...))
(-values t)]
[(ValuesDots: (list (Result: t _ _) ...) _ _)

4
typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt
View File

@ -6,7 +6,7 @@
(contract-req)
(typecheck check-below tc-subst tc-metafunctions possible-domains)
(utils tc-utils)
(rep type-rep prop-rep)
(rep type-rep filter-rep)
(except-in (types utils abbrev subtype type-table)
-> ->* one-of/c))
(require-for-cond-contract
@ -78,7 +78,7 @@
[(or (tc-results: ts)
(tc-results: ts _ _ _ _))
(-values (map cleanup-type ts))]
[(tc-any-results: f) (-AnyValues -tt)]
[(tc-any-results: f) (-AnyValues -top)]
[_ t]))
(define (stringify-domain dom rst drst [rng #f])

18
typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-eq.rkt
View File

@ -5,7 +5,7 @@
"utils.rkt"
syntax/parse syntax/stx racket/match
(typecheck signatures tc-funapp)
(types abbrev prop-ops union utils)
(types abbrev filter-ops union utils)
(rep type-rep object-rep)
(for-label racket/base racket/bool))
@ -55,14 +55,14 @@
(match* ((single-value v1) (single-value v2))
[((tc-result1: (Value: (? ok? val1)) _ o1)
(tc-result1: (Value: (? ok? val2)) _ o2))
(ret -Boolean (-PS (-and (-is-type o1 (-val val2))
(-is-type o2 (-val val1)))
(-and (-not-type o1 (-val val2))
(-not-type o2 (-val val1)))))]
(ret -Boolean (-FS (-and (-filter (-val val2) o1)
(-filter (-val val1) o2))
(-and (-not-filter (-val val2) o1)
(-not-filter (-val val1) o2))))]
[((tc-result1: t _ o) (tc-result1: (Value: (? ok? val))))
(ret -Boolean (-PS (-is-type o (-val val)) (-not-type o (-val val))))]
(ret -Boolean (-FS (-filter (-val val) o) (-not-filter (-val val) o)))]
[((tc-result1: (Value: (? ok? val))) (tc-result1: t _ o))
(ret -Boolean (-PS (-is-type o (-val val)) (-not-type o (-val val))))]
(ret -Boolean (-FS (-filter (-val val) o) (-not-filter (-val val) o)))]
[((tc-result1: t _ o)
(or (and (? (lambda _ (id=? #'member comparator)))
(tc-result1: (List: (list (and ts (Value: _)) ...))))
@ -72,8 +72,8 @@
(tc-result1: (List: (list (and ts (Value: (? eq?-able))) ...))))))
(let ([ty (apply Un ts)])
(ret (Un (-val #f) t)
(-PS (-is-type o ty)
(-not-type o ty))))]
(-FS (-filter ty o)
(-not-filter ty o))))]
[(_ _) (ret -Boolean)]))

2
typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-hetero.rkt
View File

@ -117,7 +117,7 @@
(for/list ([e (in-syntax #'(args ...))]
[t (in-list ts)])
(tc-expr/check/t e (ret t))))
-true-propset)]
-true-filter)]
[else
(tc-error/expr
"expected vector with ~a elements, but got ~a"

20
typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-main.rkt
View File

@ -7,7 +7,7 @@
syntax/parse/experimental/reflect
"../signatures.rkt" "../tc-funapp.rkt"
(types utils)
(rep type-rep prop-rep object-rep))
(rep type-rep filter-rep object-rep))
(import tc-expr^ tc-app-keywords^
tc-app-hetero^ tc-app-list^ tc-app-apply^ tc-app-values^
@ -46,13 +46,11 @@
;; TODO: handle drest, and props/objects
;; TODO: handle drest, and filters/objects
(define (arr-matches? arr args)
(match arr
[(arr: domain
(Values: (list (Result: v
(PropSet: (TrueProp:) (TrueProp:))
(Empty:)) ...))
(Values: (list (Result: v (FilterSet: (Top:) (Top:)) (Empty:)) ...))
rest #f (list (Keyword: _ _ #f) ...))
(cond
[(< (length domain) (length args)) rest]
@ -60,11 +58,9 @@
[else #f])]
[_ #f]))
(define (has-props? arr)
(define (has-filter? arr)
(match arr
[(arr: _ (Values: (list (Result: v
(PropSet: (TrueProp:) (TrueProp:))
(Empty:)) ...))
[(arr: _ (Values: (list (Result: v (FilterSet: (Top:) (Top:)) (Empty:)) ...))
_ _ (list (Keyword: _ _ #f) ...)) #f]
[else #t]))
@ -76,13 +72,13 @@
[args* (syntax->list #'args)])
(define (matching-arities arrs)
(for/list ([arr (in-list arrs)] #:when (arr-matches? arr args*)) arr))
(define (has-drest/props? arrs)
(define (has-drest/filter? arrs)
(for/or ([arr (in-list arrs)])
(or (has-props? arr) (arr-drest arr))))
(or (has-filter? arr) (arr-drest arr))))
(define arg-tys
(match f-ty
[(Function: (? has-drest/props?))
[(Function: (? has-drest/filter?))
(map single-value args*)]
[(Function:
(app matching-arities

8
typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-special.rkt
View File

@ -9,7 +9,7 @@
(typecheck signatures tc-funapp)
(types abbrev type-table utils)
(private type-annotation)
(rep type-rep prop-rep)
(rep type-rep filter-rep)
(utils tc-utils)
(for-label racket/base racket/bool '#%paramz))
@ -50,11 +50,11 @@
Univ))
(list (ret Univ) (single-value #'arg))
expected)]))
;; special-case for not - flip the props
;; special-case for not - flip the filters
(pattern ((~or false? not) arg)
(match (single-value #'arg)
[(tc-result1: t (PropSet: p+ p-) _)
(ret -Boolean (make-PropSet p- p+))]))
[(tc-result1: t (FilterSet: f+ f-) _)
(ret -Boolean (make-FilterSet f- f+))]))
;; special case for (current-contract-region)'s default expansion
;; just let it through without any typechecking, since module-name-fixup
;; is a private function from syntax/location, so this must have been

29
typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-values.rkt
View File

@ -5,7 +5,7 @@
"utils.rkt"
syntax/parse racket/match racket/sequence
(typecheck signatures tc-funapp)
(types base-abbrev utils)
(types utils)
(for-label racket/base))
@ -34,24 +34,29 @@
[(tc-result1: tp)
(single-value #'arg expected)]
[(tc-results: ts)
(single-value #'arg)] ;Type check the argument, to find other errors
(single-value #'arg) ;Type check the argument, to find other errors
(tc-error/expr
"wrong number of values: expected ~a but got one"
(length ts))]
;; match polydots case and error
[(tc-results: ts _ _ dty dbound)
(single-value #'arg)]))
(single-value #'arg)
(tc-error/expr
"Expected ~a ..., but got only one value" dty)]))
;; handle `values' specially
(pattern (values . args)
(match expected
[(tc-results: ets efs eos)
(match-let ([(list (tc-result1: ts fs os) ...)
(for/list
([arg (in-syntax #'args)]
[et (in-sequences (in-list ets) (in-cycle (in-value #f)))]
[ef (in-sequences (in-list efs) (in-cycle (in-value #f)))]
[eo (in-sequences (in-list eos) (in-cycle (in-value #f)))])
(if et
(single-value arg (ret et ef eo))
(single-value arg)))])
(ret ts fs os))]
(for/list ([arg (in-syntax #'args)]
[et (in-list ets)]
[ef (in-list efs)]
[eo (in-list eos)])
(single-value arg (ret et ef eo)))])
(if (= (length ts) (length ets) (syntax-length #'args))
(ret ts fs os)
(tc-error/expr "wrong number of values: expected ~a but got ~a"
(length ets) (syntax-length #'args))))]
[_ (match-let ([(list (tc-result1: ts fs os) ...)
(for/list ([arg (in-syntax #'args)])
(single-value arg))])

2
typed-racket-lib/typed-racket/typecheck/tc-apply.rkt
View File

@ -16,7 +16,7 @@
[(Values: (list (Result: ts _ _) ...)) (ret ts)]
[(ValuesDots: (list (Result: ts _ _) ...) dty dbound)
(ret ts
(for/list ([t (in-list ts)]) -tt-propset)
(for/list ([t (in-list ts)]) -top-filter)
(for/list ([t (in-list ts)]) -empty-obj)
dty dbound)]
[_ (int-err "do-ret fails: ~a" t)]))

87
typed-racket-lib/typed-racket/typecheck/tc-envops.rkt
View File

@ -1,12 +1,13 @@
#lang racket/base
(require "../utils/utils.rkt"
racket/match racket/list
(require (rename-in "../utils/utils.rkt" [infer infer-in]))
(require racket/match racket/list
(for-syntax racket/base syntax/parse)
(contract-req)
(rep type-rep prop-rep object-rep rep-utils)
(infer-in infer)
(rep type-rep filter-rep object-rep rep-utils)
(utils tc-utils)
(types tc-result resolve subtype remove update union prop-ops)
(types tc-result resolve subtype remove-intersect union filter-ops)
(env type-env-structs lexical-env)
(rename-in (types abbrev)
[-> -->]
@ -16,18 +17,82 @@
(provide with-lexical-env/extend-props)
(define/cond-contract (update t ft pos? lo)
(Type/c Type/c boolean? (listof PathElem?) . -> . Type/c)
;; build-type: build a type while propogating bottom
(define (build-type constructor . args)
(if (memf Bottom? args) -Bottom (apply constructor args)))
(match* ((resolve t) lo)
;; pair ops
[((Pair: t s) (list rst ... (CarPE:)))
(build-type -pair (update t ft pos? rst) s)]
[((Pair: t s) (list rst ... (CdrPE:)))
(build-type -pair t (update s ft pos? rst))]
;; syntax ops
[((Syntax: t) (list rst ... (SyntaxPE:)))
(build-type -Syntax (update t ft pos? rst))]
;; promise op
[((Promise: t) (list rst ... (ForcePE:)))
(build-type -Promise (update t ft pos? rst))]
;; struct ops
[((Struct: nm par flds proc poly pred)
(list rst ... (StructPE: (? (lambda (s) (subtype t s)) s) idx)))
;; note: this updates fields regardless of whether or not they are
;; a polymorphic field. Because subtyping is nominal and accessor
;; functions do not reflect this, this behavior is unobservable
;; except when an a variable aliases the field in a let binding
(let*-values ([(lhs rhs) (split-at flds idx)]
[(ty* acc-id) (match rhs
[(cons (fld: ty acc-id #f) _)
(values (update ty ft pos? rst) acc-id)]
[_ (int-err "update on mutable struct field")])])
(cond
[(Bottom? ty*) ty*]
[else (let ([flds* (append lhs (cons (make-fld ty* acc-id #f) (cdr rhs)))])
(make-Struct nm par flds* proc poly pred))]))]
;; class field ops
;;
;; A refinement of a private field in a class is really a refinement of the
;; return type of the accessor function for that field (rather than a variable).
;; We cannot just refine the type of the argument to the accessor, since that
;; is an object type that doesn't mention private fields. Thus we use the
;; FieldPE path element as a marker to refine the result of the accessor
;; function.
[((Function: (list (arr: doms (Values: (list (Result: rng _ _))) _ _ _)))
(list rst ... (FieldPE:)))
(make-Function
(list (make-arr* doms (update rng ft pos? rst))))]
;; otherwise
[(t '())
(if pos?
(restrict t ft)
(remove t ft))]
[((Union: ts) lo)
(apply Un (map (λ (t) (update t ft pos? lo)) ts))]
[(t* lo)
;; This likely comes up with (-lst t) and we need to improve the system to make sure this case
;; dosen't happen
;;(int-err "update along ill-typed path: ~a ~a ~a" t t* lo)
t]))
;; Returns #f if anything becomes (U)
(define (env+ env ps)
(define (env+ env fs)
(let/ec exit*
(define (exit) (exit* #f empty))
(define-values (props atoms) (combine-props ps (env-props env) exit))
(define-values (props atoms) (combine-props fs (env-props env) exit))
(values
(for/fold ([Γ (replace-props env props)]) ([p (in-list atoms)])
(match p
[(or (TypeProp: (Path: lo x) pt) (NotTypeProp: (Path: lo x) pt))
(for/fold ([Γ (replace-props env props)]) ([f (in-list atoms)])
(match f
[(or (TypeFilter: ft (Path: lo x)) (NotTypeFilter: ft (Path: lo x)))
(update-type/lexical
(lambda (x t)
(define new-t (update t pt (TypeProp? p) lo))
(define new-t (update t ft (TypeFilter? f) lo))
(when (type-equal? new-t -Bottom)
(exit))
new-t)
@ -37,7 +102,7 @@
;; run code in an extended env and with replaced props. Requires the body to return a tc-results.
;; TODO make this only add the new prop instead of the entire environment once tc-id is fixed to
;; include the interesting props in its prop.
;; include the interesting props in its filter.
;; WARNING: this may bail out when code is unreachable
(define-syntax (with-lexical-env/extend-props stx)
(define-splicing-syntax-class unreachable?

46
typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt
View File

@ -6,10 +6,10 @@
"signatures.rkt"
"check-below.rkt" "../types/kw-types.rkt"
(types utils abbrev union subtype type-table path-type
prop-ops overlap resolve generalize)
filter-ops remove-intersect resolve generalize)
(private-in syntax-properties)
(rep type-rep prop-rep object-rep)
(only-in (infer infer) intersect)
(rep type-rep filter-rep object-rep)
(only-in (infer infer) restrict)
(utils tc-utils)
(env lexical-env)
racket/list
@ -54,9 +54,9 @@
(define ty (path-type alias-path (lookup-type/lexical alias-id)))
(ret ty
(if (overlap? ty (-val #f))
(-PS (-not-type obj (-val #f)) (-is-type obj (-val #f)))
-true-propset)
(if (overlap ty (-val #f))
(-FS (-not-filter (-val #f) obj) (-filter (-val #f) obj))
-true-filter)
obj))
;; typecheck an expression, but throw away the effect
@ -140,21 +140,21 @@
[t:typecheck-failure
(explicit-fail #'t.stx #'t.message #'t.var)]
;; data
[(quote #f) (ret (-val #f) -false-propset)]
[(quote #t) (ret (-val #t) -true-propset)]
[(quote #f) (ret (-val #f) -false-filter)]
[(quote #t) (ret (-val #t) -true-filter)]
[(quote val)
(match expected
[(tc-result1: t)
(ret (tc-literal #'val t) -true-propset)]
(ret (tc-literal #'val t) -true-filter)]
[_
(ret (tc-literal #'val) -true-propset)])]
(ret (tc-literal #'val) -true-filter)])]
;; syntax
[(quote-syntax datum . _)
(define expected-type
(match expected
[(tc-result1: t) t]
[_ #f]))
(ret (find-stx-type #'datum expected-type) -true-propset)]
(ret (find-stx-type #'datum expected-type) -true-filter)]
;; mutation!
[(set! id val)
(match-let* ([(tc-result1: id-t) (single-value #'id)]
@ -200,7 +200,7 @@
[(begin0 e . es)
(begin0
(tc-expr/check #'e expected)
(tc-body/check #'es (tc-any-results -tt)))]
(tc-body/check #'es (tc-any-results -top)))]
;; if
[(if tst thn els) (tc/if-twoarm #'tst #'thn #'els expected)]
;; lambda
@ -236,7 +236,7 @@
(define actual-kws (attribute kw.value))
(check-kw-arity actual-kws f)
(tc-expr/check/type #'fun (kw-convert f actual-kws #:split #t))
(ret f -true-propset)]
(ret f -true-filter)]
[(or (tc-results: _) (tc-any-results: _))
(tc-expr/check form #f)])]
;; opt function def
@ -344,14 +344,14 @@
[else
;; Typecheck the first form.
(define e (first es))
(define results (tc-expr/check e (tc-any-results #f)))
(define results (tc-expr/check e (tc-any-results -no-filter)))
(define props
(match results
[(tc-any-results: f) (list f)]
[(tc-results: _ (list (PropSet: p+ p-) ...) _)
(map -or p+ p-)]
[(tc-results: _ (list (PropSet: p+ p-) ...) _ _ _)
(map -or p+ p-)]))
[(tc-results: _ (list (FilterSet: f+ f-) ...) _)
(map -or f+ f-)]
[(tc-results: _ (list (FilterSet: f+ f-) ...) _ _ _)
(map -or f+ f-)]))
(with-lexical-env/extend-props
props
;; If `e` bails out, mark the rest as ignored.
@ -366,18 +366,18 @@
(define (find-stx-type datum-stx [expected #f])
(match datum-stx
[(? syntax? (app syntax-e stx-e))
(match (and expected (resolve (intersect expected (-Syntax Univ))))
(match (and expected (resolve (restrict expected (-Syntax Univ) 'orig)))
[(Syntax: t) (-Syntax (find-stx-type stx-e t))]
[_ (-Syntax (find-stx-type stx-e))])]
[(or (? symbol?) (? null?) (? number?) (? extflonum?) (? boolean?) (? string?) (? char?)
(? bytes?) (? regexp?) (? byte-regexp?) (? keyword?))
(tc-literal #`#,datum-stx expected)]
[(cons car cdr)
(match (and expected (resolve (intersect expected (-pair Univ Univ))))
(match (and expected (resolve (restrict expected (-pair Univ Univ) 'orig)))
[(Pair: car-t cdr-t) (-pair (find-stx-type car car-t) (find-stx-type cdr cdr-t))]
[_ (-pair (find-stx-type car) (find-stx-type cdr))])]
[(vector xs ...)
(match (and expected (resolve (intersect expected -VectorTop)))
(match (and expected (resolve (restrict expected -VectorTop 'orig)))
[(Vector: t)
(make-Vector
(check-below
@ -393,11 +393,11 @@
[_ (make-HeterogeneousVector (for/list ([x (in-list xs)])
(generalize (find-stx-type x #f))))])]
[(box x)
(match (and expected (resolve (intersect expected -BoxTop)))
(match (and expected (resolve (restrict expected -BoxTop 'orig)))
[(Box: t) (-box (check-below (find-stx-type x t) t))]
[_ (-box (generalize (find-stx-type x)))])]
[(? hash? h)
(match (and expected (resolve (intersect expected -HashTop)))
(match (and expected (resolve (restrict expected -HashTop 'orig)))
[(Hashtable: kt vt)
(define kts (hash-map h (lambda (x y) (find-stx-type x kt))))
(define vts (hash-map h (lambda (x y) (find-stx-type y vt))))

8
typed-racket-lib/typed-racket/typecheck/tc-expression.rkt
View File

@ -34,14 +34,6 @@
(if expected
(tc-expr/check #'e expected)
(tc-expr #'e))]
[(exp:casted-expr^ e)
(define result (tc-expr #'e))
(match result
[(tc-result1: ty)
((attribute exp.value) ty)
result]
[_
(tc-error/expr "Cannot cast expression that produces multiple values")])]
[(_ e)
(if expected
(tc-expr/check #'e expected)

10
typed-racket-lib/typed-racket/typecheck/tc-funapp.rkt
View File

@ -48,7 +48,7 @@
#:when (subtypes/varargs argtys dom rest))
;; then typecheck here
;; we call the separate function so that we get the appropriate
;; props/objects
;; filters/objects
(tc/funapp1 f-stx args-stx a args-res expected #:check #f))
;; if nothing matched, error
(domain-mismatches
@ -70,7 +70,7 @@
(eq? dotted-var (cdr drest)))]
[else (= (length dom) (length argtys))]))
;; Only try to infer the free vars of the rng (which includes the vars
;; in props/objects).
;; in filters/objects).
(λ (dom rng rest drest a)
(extend-tvars fixed-vars
(cond
@ -95,7 +95,7 @@
(λ (dom _ rest kw? a)
(and (andmap not kw?) ((if rest <= =) (length dom) (length argtys))))
;; Only try to infer the free vars of the rng (which includes the vars
;; in props/objects).
;; in filters/objects).
(λ (dom rng rest kw? a)
(extend-tvars vars
(infer/vararg vars null argtys dom rest rng
@ -145,9 +145,9 @@
[(list) (ret out)]
[(list t)
(if (subtype t in)
(ret -Void -true-propset)
(ret -Void -true-filter)
(tc-error/expr
#:return (ret -Void -true-propset)
#:return (ret -Void -true-filter)
"Wrong argument to parameter - expected ~a and got ~a"
in t))]
[_ (tc-error/expr

8
typed-racket-lib/typed-racket/typecheck/tc-if.rkt
View File

@ -1,7 +1,7 @@
#lang racket/unit
(require "../utils/utils.rkt"
(rep prop-rep)
(types utils prop-ops)
(rep filter-rep)
(types utils filter-ops)
(utils tc-utils)
(typecheck signatures tc-envops tc-metafunctions)
(types type-table)
@ -13,8 +13,8 @@
(define (tc/if-twoarm tst thn els [expected #f])
(match (single-value tst)
[(tc-result1: _ (PropSet: fs+ fs-) _)
(define expected* (and expected (erase-props expected)))
[(tc-result1: _ (FilterSet: fs+ fs-) _)
(define expected* (and expected (erase-filter expected)))
(define results-t
(with-lexical-env/extend-props (list fs+)
#:unreachable (warn-unreachable thn)

4
typed-racket-lib/typed-racket/typecheck/tc-lambda-unit.rkt
View File

@ -531,8 +531,8 @@
(match expected
[(tc-result1: (app resolve t)) (or (Poly? t) (PolyDots? t) (PolyRow? t))]
[_ #f]))
(ret (tc/plambda form (get-poly-tvarss form) formals bodies expected) -true-propset)
(ret (tc/mono-lambda/type formals bodies expected) -true-propset)))
(ret (tc/plambda form (get-poly-tvarss form) formals bodies expected) -true-filter)
(ret (tc/mono-lambda/type formals bodies expected) -true-filter)))
;; formals : the formal arguments to the loop
;; body : a block containing the body of the loop

20
typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt
View File

@ -1,14 +1,14 @@
#lang racket/unit
(require "../utils/utils.rkt"
(except-in (types utils abbrev prop-ops overlap type-table)
(except-in (types utils abbrev filter-ops remove-intersect type-table)
-> ->* one-of/c)
(only-in (types abbrev) (-> t:->) [->* t:->*])
(private type-annotation parse-type syntax-properties)
(env lexical-env type-alias-helper mvar-env
global-env scoped-tvar-env
signature-env signature-helper)
(rep prop-rep object-rep type-rep)
(rep filter-rep object-rep type-rep)
syntax/free-vars
(typecheck signatures tc-metafunctions tc-subst internal-forms tc-envops)
(utils tarjan)
@ -49,13 +49,13 @@
tc-results/c)
(with-cond-contract t/p ([expected-types (listof (listof Type/c))]
[objs (listof (listof Object?))]
[props (listof (listof Prop?))])
[props (listof (listof Filter?))])
(define-values (expected-types objs props)
(for/lists (e o p)
([e-r (in-list expected-results)]
[names (in-list namess)])
(match e-r
[(list (tc-result: e-ts (PropSet: fs+ fs-) os) ...)
[(list (tc-result: e-ts (FilterSet: fs+ fs-) os) ...)
(values e-ts
(map (λ (o n t) (if (or (is-var-mutated? n) (F? t)) -empty-obj o)) os names e-ts)
(apply append
@ -65,7 +65,7 @@
[f- (in-list fs-)]
[o (in-list os)])
(cond
[(not (overlap? t (-val #f)))
[(not (overlap t (-val #f)))
(list f+)]
[(is-var-mutated? n)
(list)]
@ -75,10 +75,10 @@
[(and (Path? o) (not (F? t))) (list)]
;; n is being bound to an expression w/o an object (or whose
;; type is a type variable) so create props about n
[else (list (-or (-and (-not-type n (-val #f)) f+)
(-and (-is-type n (-val #f)) f-)))]))))]
[else (list (-or (-and (-not-filter (-val #f) n) f+)
(-and (-filter (-val #f) n) f-)))]))))]
;; amk: does this case ever occur?
[(list (tc-result: e-ts #f _) ...)
[(list (tc-result: e-ts (NoFilter:) _) ...)
(values e-ts (make-list (length e-ts) -empty-obj) null)]))))
;; extend the lexical environment for checking the body
;; with types and potential aliases
@ -102,7 +102,7 @@
;; in the context of the letrec body
(check-thunk)
;; typecheck the body
(tc-body/check body (and expected (erase-props expected)))))))
(tc-body/check body (and expected (erase-filter expected)))))))
(define (tc-expr/maybe-expected/t e names)
(syntax-parse names
@ -182,7 +182,7 @@
;; after everything, check the body expressions
[(null? remaining-names)
(check-thunk)
(tc-body/check body (and expected (erase-props expected)))]
(tc-body/check body (and expected (erase-filter expected)))]
[else
(define flat-names (apply append remaining-names))
(do-check tc-expr/check

8
typed-racket-lib/typed-racket/typecheck/tc-literal.rkt
View File

@ -6,7 +6,7 @@
(types abbrev numeric-tower resolve subtype union generalize
prefab)
(rep type-rep)
(only-in (infer infer) intersect)
(only-in (infer infer) restrict)
(utils stxclass-util)
syntax/parse
racket/function
@ -89,7 +89,7 @@
[i:regexp -Regexp]
[() -Null]
[(i . r)
(match (and expected (resolve (intersect expected (-pair Univ Univ))))
(match (and expected (resolve (restrict expected (-pair Univ Univ) 'orig)))
[(Pair: a-ty d-ty)
(-pair
(tc-literal #'i a-ty)
@ -97,7 +97,7 @@
[t
(-pair (tc-literal #'i) (tc-literal #'r))])]
[(~var i (3d vector?))
(match (and expected (resolve (intersect expected -VectorTop)))
(match (and expected (resolve (restrict expected -VectorTop 'orig)))
[(Vector: t)
(make-Vector
(check-below
@ -113,7 +113,7 @@
[_ (make-HeterogeneousVector (for/list ([l (in-vector (syntax-e #'i))])
(generalize (tc-literal l #f))))])]
[(~var i (3d hash?))
(match (and expected (resolve (intersect expected -HashTop)))
(match (and expected (resolve (restrict expected -HashTop 'orig)))
[(Hashtable: k v)
(let* ([h (syntax-e #'i)]
[ks (hash-map h (lambda (x y) (tc-literal x k)))]

57
typed-racket-lib/typed-racket/typecheck/tc-metafunctions.rkt
View File

@ -2,9 +2,9 @@
(require "../utils/utils.rkt"
racket/match racket/list
(except-in (types abbrev union utils prop-ops tc-result)
(except-in (types abbrev union utils filter-ops tc-result)
-> ->* one-of/c)
(rep type-rep prop-rep object-rep rep-utils)
(rep type-rep filter-rep object-rep rep-utils)
(typecheck tc-subst check-below)
(contract-req))
@ -36,20 +36,20 @@
(make-ValuesDots (map -result ts fs os) dty dbound)]))
(define/cond-contract (resolve atoms prop)
((listof Prop?)
Prop?
((listof Filter/c)
Filter/c
. -> .
Prop?)
Filter/c)
(for/fold ([prop prop])
([a (in-list atoms)])
(match prop
[(AndProp: ps)
[(AndFilter: ps)
(let loop ([ps ps] [result null])
(if (null? ps)
(apply -and result)
(let ([p (car ps)])
(cond [(contradictory? a p) -ff]
[(implies-atomic? a p) (loop (cdr ps) result)]
(cond [(contradictory? a p) -bot]
[(implied-atomic? p a) (loop (cdr ps) result)]
[else (loop (cdr ps) (cons p result))]))))]
[_ prop])))
@ -57,14 +57,14 @@
(let loop ([ps ps])
(match ps
[(list) null]
[(cons (AndProp: ps*) ps) (loop (append ps* ps))]
[(cons (AndFilter: ps*) ps) (loop (append ps* ps))]
[(cons p ps) (cons p (loop ps))])))
(define/cond-contract (combine-props new-props old-props exit)
((listof Prop?) (listof Prop?) (-> none/c)
((listof Filter/c) (listof Filter/c) (-> none/c)
. -> .
(values (listof OrProp?) (listof (or/c TypeProp? NotTypeProp?))))
(define (atomic-prop? p) (or (TypeProp? p) (NotTypeProp? p)))
(values (listof (or/c ImpFilter? OrFilter?)) (listof (or/c TypeFilter? NotTypeFilter?))))
(define (atomic-prop? p) (or (TypeFilter? p) (NotTypeFilter? p)))
(define-values (new-atoms new-formulas) (partition atomic-prop? (flatten-props new-props)))
(let loop ([derived-formulas null]
[derived-atoms new-atoms]
@ -74,7 +74,12 @@
(let* ([p (car worklist)]
[p (resolve derived-atoms p)])
(match p
[(OrProp: ps)
[(ImpFilter: a c)
(if (for/or ([p (in-list (append derived-formulas derived-atoms))])
(implied-atomic? a p))
(loop derived-formulas derived-atoms (cons c (cdr worklist)))
(loop (cons p derived-formulas) derived-atoms (cdr worklist)))]
[(OrFilter: ps)
(let ([new-or
(let or-loop ([ps ps] [result null])
(cond
@ -83,32 +88,32 @@
(contradictory? (car ps) other-p))
(or-loop (cdr ps) result)]
[(for/or ([other-p (in-list derived-atoms)])
(implies-atomic? other-p (car ps)))
-tt]
(implied-atomic? (car ps) other-p))
-top]
[else (or-loop (cdr ps) (cons (car ps) result))]))])
(if (OrProp? new-or)
(if (OrFilter? new-or)
(loop (cons new-or derived-formulas) derived-atoms (cdr worklist))
(loop derived-formulas derived-atoms (cons new-or (cdr worklist)))))]
[(or (? TypeProp?) (? NotTypeProp?)) (loop derived-formulas (cons p derived-atoms) (cdr worklist))]
[(or (? TypeFilter?) (? NotTypeFilter?)) (loop derived-formulas (cons p derived-atoms) (cdr worklist))]
[(AndProp: ps) (loop derived-formulas derived-atoms (append ps (cdr worklist)))]
[(TrueProp:) (loop derived-formulas derived-atoms (cdr worklist))]
[(FalseProp:) (exit)])))))
[(AndFilter: ps) (loop derived-formulas derived-atoms (append ps (cdr worklist)))]
[(Top:) (loop derived-formulas derived-atoms (cdr worklist))]
[(Bot:) (exit)])))))
(define (unconditional-prop res)
(match res
[(tc-any-results: pset) pset]
[(tc-results (list (tc-result: _ (PropSet: p+ p-) _) ...) _)
(apply -and (map -or p+ p-))]))
[(tc-any-results: f) f]
[(tc-results (list (tc-result: _ (FilterSet: f+ f-) _) ...) _)
(apply -and (map -or f+ f-))]))
(define (merge-tc-results results)
(define/match (merge-tc-result r1 r2)
[((tc-result: t1 (PropSet: p1+ p1-) o1)
(tc-result: t2 (PropSet: p2+ p2-) o2))
[((tc-result: t1 (FilterSet: f1+ f1-) o1)
(tc-result: t2 (FilterSet: f2+ f2-) o2))
(tc-result
(Un t1 t2)
(-PS (-or p1+ p2+) (-or p1- p2-))
(-FS (-or f1+ f2+) (-or f1- f2-))
(if (equal? o1 o2) o1 -empty-obj))])
(define/match (same-dty? r1 r2)

83
typed-racket-lib/typed-racket/typecheck/tc-structs.rkt
View File

@ -6,10 +6,10 @@
(prefix-in c: (contract-req))
(rep type-rep object-rep free-variance)
(private parse-type syntax-properties)
(types abbrev subtype utils resolve substitute struct-table prefab)
(types abbrev utils resolve substitute struct-table prefab)
(env global-env type-name-env type-alias-env tvar-env)
(utils tc-utils)
(typecheck def-binding internal-forms error-message)
(typecheck def-binding internal-forms check-below)
(for-syntax syntax/parse racket/base))
(require-for-cond-contract racket/struct-info)
@ -32,27 +32,17 @@
;; type-only : Boolean
(struct parsed-struct (sty names desc struct-info type-only) #:transparent)
;; struct-name : Id (the identifier for the static struct info,
;; usually the same as the type-name)
;; type-name : Id (the identifier for the type name)
;; struct-type : Id (the identifier for the struct type binding)
;; type-name : Id
;; struct-type : Id
;; constructor : Id
;; extra-constructor : (Option Id)
;; predicate : Id
;; getters : Listof[Id]
;; setters : Listof[Id] or #f
(struct struct-names (struct-name type-name struct-type constructor extra-constructor predicate getters setters) #:transparent)
(struct struct-names (type-name struct-type constructor extra-constructor predicate getters setters) #:transparent)
;; struct-desc holds all the relevant information about a struct type's types
;; parent-fields : (Listof Type)
;; self-fields : (Listof Type)
;; tvars : (Listof Symbol)
;; mutable: Any
;; parent-mutable: Any
;; proc-ty: (Option Type)
(struct struct-desc (parent-fields self-fields tvars
mutable parent-mutable proc-ty)
#:transparent)
;;struct-fields: holds all the relevant information about a struct type's types
(struct struct-desc (parent-fields self-fields tvars mutable proc-ty) #:transparent)
(define (struct-desc-all-fields fields)
(append (struct-desc-parent-fields fields) (struct-desc-self-fields fields)))
@ -99,7 +89,7 @@
(match (build-struct-names nm flds #f #f nm #:constructor-name maker*)
[(list sty maker pred getters/setters ...)
(let-values ([(getters setters) (split getters/setters)])
(struct-names nm type-name sty maker extra-maker pred getters setters))]))
(struct-names type-name sty maker extra-maker pred getters setters))]))
;; gets the fields of the parent type, if they exist
;; Option[Struct-Ty] -> Listof[Type]
@ -119,7 +109,7 @@
[g (in-list (struct-names-getters names))])
(make-fld t g (struct-desc-mutable desc)))]
[flds (append (get-flds parent) this-flds)])
(make-Struct (struct-names-struct-name names)
(make-Struct (struct-names-type-name names)
parent flds (struct-desc-proc-ty desc)
(not (null? (struct-desc-tvars desc)))
(struct-names-predicate names))))
@ -150,10 +140,8 @@
(define tvars (struct-desc-tvars desc))
(define all-fields (struct-desc-all-fields desc))
(define parent-fields (struct-desc-parent-fields desc))
(define self-fields (struct-desc-self-fields desc))
(define mutable (struct-desc-mutable desc))
(define parent-mutable (struct-desc-parent-mutable desc))
(define parent-count (struct-desc-parent-count desc))
@ -166,15 +154,12 @@
(make-App name-type (map make-F tvars) #f)))
;; is this structure covariant in *all* arguments?
(define (covariant-for? fields mutable)
(define covariant?
(for*/and ([var (in-list tvars)]
[t (in-list fields)])
[t (in-list all-fields)])
(let ([variance (hash-ref (free-vars-hash (free-vars* t)) var Constant)])
(or (eq? variance Constant)
(and (not mutable) (eq? variance Covariant))))))
(define covariant?
(and (covariant-for? self-fields mutable)
(covariant-for? parent-fields parent-mutable)))
(define (poly-wrapper t) (make-Poly tvars t))
(define bindings
@ -304,42 +289,23 @@
(define key
(normalize-prefab-key (append key-prefix parent-key)
(+ (length fld-names) (length parent-fields))))
(define parent-mutable
(match parent-key
[(list-rest _ num-fields _ mutable _)
(= num-fields (vector-length mutable))]
;; no parent, so trivially true
['() #t]))
(define desc
(struct-desc parent-fields types tvars mutable parent-mutable #f))
(define desc (struct-desc parent-fields types tvars mutable #f))
(parsed-struct (make-Prefab key (append parent-fields types))
names desc (struct-info-property nm/par) #f)]
[else
(define maybe-proc-ty
(let ([maybe-parsed-proc-ty (and proc-ty (parse-type proc-ty))])
(and maybe-parsed-proc-ty
(cond
;; ensure that the prop:procedure argument is really a procedure
[(subtype maybe-parsed-proc-ty top-func)
maybe-parsed-proc-ty]
[else (expected-but-got top-func maybe-parsed-proc-ty)
#f]))))
(define parent-mutable
;; Only valid as long as typed structs must be
;; either fully mutable or fully immutable
(or (not parent)
(andmap fld-mutable? (get-flds concrete-parent))))
(define maybe-parsed-proc-ty
(and proc-ty (parse-type proc-ty)))
;; ensure that the prop:procedure argument is really a procedure
(when maybe-parsed-proc-ty
(check-below maybe-parsed-proc-ty top-func))
(define desc (struct-desc
(map fld-t (get-flds concrete-parent))
types
tvars
mutable
parent-mutable
maybe-proc-ty))
(map fld-t (get-flds concrete-parent))
types
tvars
mutable
maybe-parsed-proc-ty))
(define sty (mk/inner-struct-type names desc concrete-parent))
(parsed-struct sty names desc (struct-info-property nm/par) type-only)]))
;; register a struct type
@ -357,8 +323,7 @@
(define parent-tys (map fld-t (get-flds parent-type)))
(define names (get-struct-names nm nm fld-names #f #f))
;; built-in structs are assumed to be immutable with immutable parents
(define desc (struct-desc parent-tys tys null #f #f #f))
(define desc (struct-desc parent-tys tys null #t #f))
(define sty (mk/inner-struct-type names desc parent-type))
(register-sty! sty names desc)

132
typed-racket-lib/typed-racket/typecheck/tc-subst.rkt
View File

@ -6,10 +6,10 @@
(require "../utils/utils.rkt"
racket/match racket/list
(contract-req)
(except-in (types abbrev utils prop-ops path-type)
(except-in (types abbrev utils filter-ops path-type)
-> ->* one-of/c)
(only-in (infer infer) intersect)
(rep type-rep object-rep prop-rep rep-utils))
(only-in (infer infer) restrict)
(rep type-rep object-rep filter-rep rep-utils))
(provide add-scope)
@ -49,12 +49,12 @@
;; This is a combination of all of thes substitions from the paper over the different parts of the
;; results.
;; t is the type of the object that we are substituting in. This allows for restriction/simplification
;; of some props if they conflict with the argument type.
;; of some filters if they conflict with the argument type.
(define/cond-contract (subst-tc-results res k o polarity t)
(-> full-tc-results/c name-ref/c Object? boolean? Type? full-tc-results/c)
(define (st ty) (subst-type ty k o polarity t))
(define (sr ty fs ob) (subst-tc-result ty fs ob k o polarity t))
(define (sf f) (subst-prop f k o polarity t))
(define (sf f) (subst-filter f k o polarity t))
(match res
[(tc-any-results: f) (tc-any-results (sf f))]
[(tc-results: ts fs os)
@ -76,36 +76,36 @@
(tc-result
(if (equal? argument-side Err)
(subst-type r-t k o polarity t)
(intersect argument-side
(subst-type r-t k o polarity t)))
(subst-prop-set r-fs k o polarity t)
(restrict argument-side
(subst-type r-t k o polarity t)))
(subst-filter-set r-fs k o polarity t)
(subst-object r-o k o polarity)))
;; Substitution of objects into a prop set
;; Substitution of objects into a filter set
;; This is essentially ψ+|ψ- [o/x] from the paper
(define/cond-contract (subst-prop-set pset k o polarity t)
(-> (or/c #f PropSet?) name-ref/c Object? boolean? Type/c PropSet?)
(define extra-prop (-is-type k t))
(define (add-extra-prop p)
(define p* (-and p extra-prop))
(define/cond-contract (subst-filter-set fs k o polarity t)
(-> (or/c FilterSet? NoFilter?) name-ref/c Object? boolean? Type/c FilterSet?)
(define extra-filter (-filter t k))
(define (add-extra-filter f)
(define f* (-and f extra-filter))
(cond
[(prop-equal? p* extra-prop) -tt]
[(FalseProp? p*) -ff]
[else p]))
(match pset
[(PropSet: p+ p-)
(-PS (subst-prop (add-extra-prop p+) k o polarity t)
(subst-prop (add-extra-prop p-) k o polarity t))]
[_ -tt-propset]))
[(filter-equal? f* extra-filter) -top]
[(Bot? f*) -bot]
[else f]))
(match fs
[(FilterSet: f+ f-)
(-FS (subst-filter (add-extra-filter f+) k o polarity t)
(subst-filter (add-extra-filter f-) k o polarity t))]
[_ -top-filter]))
;; Substitution of objects into a type
;; This is essentially t [o/x] from the paper
(define/cond-contract (subst-type t k o polarity ty)
(-> Type? name-ref/c Object? boolean? Type/c Type?)
(define (st t) (subst-type t k o polarity ty))
(define/cond-contract (sf fs) (PropSet? . -> . PropSet?) (subst-prop-set fs k o polarity ty))
(define/cond-contract (sf fs) (FilterSet? . -> . FilterSet?) (subst-filter-set fs k o polarity ty))
(type-case (#:Type st
#:Prop sf
#:Filter sf
#:Object (lambda (f) (subst-object f k o polarity)))
t
[#:arr dom rng rest drest kws
@ -135,48 +135,80 @@
(define/cond-contract (subst-object t k o polarity)
(-> Object? name-ref/c Object? boolean? Object?)
(match t
[#f t]
[(NoObject:) t]
[(Empty:) t]
[(Path: p i)
(if (name-ref=? i k)
(match o
[(Empty:) -empty-obj]
;; the result is not from an annotation, so it isn't a NoObject
[#f -empty-obj]
[(NoObject:) -empty-obj]
[(Path: p* i*) (make-Path (append p p*) i*)])
t)]))
;; Substitution of objects into a prop in a prop set
;; This is ψ+ [o/x] and ψ- [o/x] with the addition that props are restricted to
;; Substitution of objects into a filter in a filter set
;; This is ψ+ [o/x] and ψ- [o/x] with the addition that filters are restricted to
;; only those values which are a subtype of the actual argument type (ty).
(define/cond-contract (subst-prop p k o polarity ty)
(-> Prop? name-ref/c Object? boolean? Type/c Prop?)
(define (ap q) (subst-prop q k o polarity ty))
(define (tprop-matcher pes i t maker)
(define/cond-contract (subst-filter f k o polarity ty)
(-> Filter/c name-ref/c Object? boolean? Type/c Filter/c)
(define (ap f) (subst-filter f k o polarity ty))
(define (tf-matcher t p i maker)
(cond
[(name-ref=? i k)
(match o
[(Empty:)
(if polarity -tt -ff)]
(if polarity -top -bot)]
[_
;; `ty` alone doesn't account for the path, so
;; first traverse it with the path to match `t`
(define ty/path (path-type pes ty))
(define ty/path (path-type p ty))
(maker
(-acc-path pes o)
;; don't intersect if the path doesn't match the type
(if (equal? ty/path Err)
(subst-type t k o polarity ty)
(intersect ty/path
(subst-type t k o polarity ty))))])]
[else p]))
;; don't restrict if the path doesn't match the type
(if (equal? ty/path Err)
(subst-type t k o polarity ty)
(restrict ty/path
(subst-type t k o polarity ty)))
(-acc-path p o))])]
[(index-free-in? k t) (if polarity -top -bot)]
[else f]))
(match p
[(AndProp: ps) (apply -and (map ap ps))]
[(OrProp: ps) (apply -or (map ap ps))]
[(FalseProp:) -ff]
[(TrueProp:) -tt]
[(TypeProp: (Path: pes i) t)
(tprop-matcher pes i t -is-type)]
[(NotTypeProp: (Path: pes i) t)
(tprop-matcher pes i t -not-type)]))
(match f
[(ImpFilter: ant consq)
(-imp (subst-filter ant k o (not polarity) ty) (ap consq))]
[(AndFilter: fs) (apply -and (map ap fs))]
[(OrFilter: fs) (apply -or (map ap fs))]
[(Bot:) -bot]
[(Top:) -top]
[(TypeFilter: t (Path: p i))
(tf-matcher t p i -filter)]
[(NotTypeFilter: t (Path: p i))
(tf-matcher t p i -not-filter)]))
;; Determine if the object k occurs free in the given type
(define (index-free-in? k type)
(let/ec
return
(define (for-object o)
(object-case (#:Type for-type)
o
[#:Path p i
(if (name-ref=? i k)
(return #t)
o)]))
(define (for-type t)
(type-case (#:Type for-type
#:Object for-object)
t
[#:arr dom rng rest drest kws
(let* ([st* (if (pair? k)
(lambda (t) (index-free-in? (add-scope k) t))
for-type)])
(for-each for-type dom)
(st* rng)
(and rest (for-type rest))
(and drest (for-type (car drest)))
(for-each for-type kws)
;; dummy return value
(make-arr* null Univ))]))
(for-type type)
#f))

2
typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -213,7 +213,7 @@
;; typecheck the expressions of a module-top-level form
;; no side-effects
;; syntax? -> (or/c 'no-type tc-results/c)
(define (tc-toplevel/pass2 form [expected (tc-any-results -tt)])
(define (tc-toplevel/pass2 form [expected (tc-any-results -top)])
(do-time (format "pass2 ~a line ~a"
(if #t

14
typed-racket-lib/typed-racket/types/abbrev.rkt
View File

@ -12,7 +12,7 @@
racket/function
(prefix-in c: (contract-req))
(rename-in (rep type-rep prop-rep object-rep)
(rename-in (rep type-rep filter-rep object-rep)
[make-Base make-Base*])
(types union numeric-tower prefab)
;; Using this form so all-from-out works
@ -262,23 +262,23 @@
;; Function type constructors
(define/decl top-func (make-Function (list)))
(define (asym-pred dom rng prop)
(make-Function (list (make-arr* (list dom) rng #:props prop))))
(define (asym-pred dom rng filter)
(make-Function (list (make-arr* (list dom) rng #:filters filter))))
(define/cond-contract make-pred-ty
(c:case-> (c:-> Type/c Type/c)
(c:-> (c:listof Type/c) Type/c Type/c Type/c)
(c:-> (c:listof Type/c) Type/c Type/c Object? Type/c))
(case-lambda
[(in out t o)
(->* in out : (-PS (-is-type o t) (-not-type o t)))]
[(in out t p)
(->* in out : (-FS (-filter t p) (-not-filter t p)))]
[(in out t)
(make-pred-ty in out t (make-Path null (list 0 0)))]
[(t)
(make-pred-ty (list Univ) -Boolean t (make-Path null (list 0 0)))]))
(define/decl -true-propset (-PS -tt -ff))
(define/decl -false-propset (-PS -ff -tt))
(define/decl -true-filter (-FS -top -bot))
(define/decl -false-filter (-FS -bot -top))
(define (opt-fn args opt-args result #:rest [rest #f] #:kws [kws null])
(apply cl->* (for/list ([i (in-range (add1 (length opt-args)))])

102
typed-racket-lib/typed-racket/types/base-abbrev.rkt
View File

@ -6,7 +6,7 @@
;; extends it with more types and type abbreviations.
(require "../utils/utils.rkt"
(rep type-rep prop-rep object-rep rep-utils)
(rep type-rep filter-rep object-rep rep-utils)
(env mvar-env)
racket/match racket/list (prefix-in c: (contract-req))
(for-syntax racket/base syntax/parse racket/list)
@ -102,19 +102,21 @@
(make-Mu 'var ty))]))
;; Results
(define/cond-contract (-result t [pset -tt-propset] [o -empty-obj])
(c:->* (Type/c) (PropSet? Object?) Result?)
(define/cond-contract (-result t [f -top-filter] [o -empty-obj])
(c:->* (Type/c) (FilterSet? Object?) Result?)
(cond
[(or (equal? t -Bottom) (equal? pset -ff-propset))
(make-Result -Bottom -ff-propset o)]
[(or (equal? t -Bottom) (equal? f -bot-filter))
(make-Result -Bottom -bot-filter o)]
[else
(make-Result t pset o)]))
(make-Result t f o)]))
;; Propositions
(define/decl -tt (make-TrueProp))
(define/decl -ff (make-FalseProp))
(define/decl -tt-propset (make-PropSet -tt -tt))
(define/decl -ff-propset (make-PropSet -ff -ff))
;; Filters
(define/decl -top (make-Top))
(define/decl -bot (make-Bot))
(define/decl -no-filter (make-NoFilter))
(define/decl -top-filter (make-FilterSet -top -top))
(define/decl -bot-filter (make-FilterSet -bot -bot))
(define/decl -no-obj (make-NoObject))
(define/decl -empty-obj (make-Empty))
(define (-id-path id)
(cond
@ -131,15 +133,15 @@
[(Empty:) -empty-obj]
[(Path: p o) (make-Path (append path-elems p) o)]))
(define/cond-contract (-PS + -)
(c:-> Prop? Prop? PropSet?)
(make-PropSet + -))
(define/cond-contract (-FS + -)
(c:-> Filter/c Filter/c FilterSet?)
(make-FilterSet + -))
;; Abbreviation for props
;; Abbreviation for filters
;; `i` can be an integer or name-ref/c for backwards compatibility
;; FIXME: Make all callers pass in an object and remove backwards compatibility
(define/cond-contract (-is-type i t)
(c:-> (c:or/c integer? name-ref/c Object?) Type/c Prop?)
(define/cond-contract (-filter t i)
(c:-> Type/c (c:or/c integer? name-ref/c Object?) Filter/c)
(define o
(cond
[(Object? i) i]
@ -147,17 +149,17 @@
[(list? i) (make-Path null i)]
[else (-id-path i)]))
(cond
[(Empty? o) -tt]
[(equal? Univ t) -tt]
[(equal? -Bottom t) -ff]
[else (make-TypeProp o t)]))
[(Empty? o) -top]
[(equal? Univ t) -top]
[(equal? -Bottom t) -bot]
[else (make-TypeFilter t o)]))
;; Abbreviation for not props
;; Abbreviation for not filters
;; `i` can be an integer or name-ref/c for backwards compatibility
;; FIXME: Make all callers pass in an object and remove backwards compatibility
(define/cond-contract (-not-type i t)
(c:-> (c:or/c integer? name-ref/c Object?) Type/c Prop?)
(define/cond-contract (-not-filter t i)
(c:-> Type/c (c:or/c integer? name-ref/c Object?) Filter/c)
(define o
(cond
[(Object? i) i]
@ -165,30 +167,30 @@
[(list? i) (make-Path null i)]
[else (-id-path i)]))
(cond
[(Empty? o) -tt]
[(equal? -Bottom t) -tt]
[(equal? Univ t) -ff]
[else (make-NotTypeProp o t)]))
[(Empty? o) -top]
[(equal? -Bottom t) -top]
[(equal? Univ t) -bot]
[else (make-NotTypeFilter t o)]))
;; A Type that corresponds to the any contract for the
;; return type of functions
(define (-AnyValues f) (make-AnyValues f))
(define/decl ManyUniv (make-AnyValues -tt))
(define/decl ManyUniv (make-AnyValues -top))
;; Function types
(define/cond-contract (make-arr* dom rng
#:rest [rest #f] #:drest [drest #f] #:kws [kws null]
#:props [props -tt-propset] #:object [obj -empty-obj])
#:filters [filters -top-filter] #:object [obj -empty-obj])
(c:->* ((c:listof Type/c) (c:or/c SomeValues/c Type/c))
(#:rest (c:or/c #f Type/c)
#:drest (c:or/c #f (c:cons/c Type/c symbol?))
#:kws (c:listof Keyword?)
#:props PropSet?
#:filters FilterSet?
#:object Object?)
arr?)
(make-arr dom (if (Type/c? rng)
(make-Values (list (-result rng props obj)))
(make-Values (list (-result rng filters obj)))
rng)
rest drest (sort #:key Keyword-kw kws keyword<?)))
@ -200,23 +202,23 @@
#'(make-Function (list (make-arr* dom rng)))]
[(_ dom rst rng)
#'(make-Function (list (make-arr* dom rng #:rest rst)))]
[(_ dom rng :c props)
#'(make-Function (list (make-arr* dom rng #:props props)))]
[(_ dom rng _:c props _:c object)
#'(make-Function (list (make-arr* dom rng #:props props #:object object)))]
[(_ dom rst rng _:c props)
#'(make-Function (list (make-arr* dom rng #:rest rst #:props props)))]
[(_ dom rst rng _:c props : object)
#'(make-Function (list (make-arr* dom rng #:rest rst #:props props #:object object)))]))
[(_ dom rng :c filters)
#'(make-Function (list (make-arr* dom rng #:filters filters)))]
[(_ dom rng _:c filters _:c object)
#'(make-Function (list (make-arr* dom rng #:filters filters #:object object)))]
[(_ dom rst rng _:c filters)
#'(make-Function (list (make-arr* dom rng #:rest rst #:filters filters)))]
[(_ dom rst rng _:c filters : object)
#'(make-Function (list (make-arr* dom rng #:rest rst #:filters filters #:object object)))]))
(define-syntax (-> stx)
(define-syntax-class c
(pattern x:id #:fail-unless (eq? ': (syntax-e #'x)) #f))
(syntax-parse stx
[(_ dom ... rng _:c props _:c objects)
#'(->* (list dom ...) rng : props : objects)]
[(_ dom ... rng :c props)
#'(->* (list dom ...) rng : props)]
[(_ dom ... rng _:c filters _:c objects)
#'(->* (list dom ...) rng : filters : objects)]
[(_ dom ... rng :c filters)
#'(->* (list dom ...) rng : filters)]
[(_ dom ... rng)
#'(->* (list dom ...) rng)]))
@ -226,10 +228,10 @@
(->* dom rng)]
[(_ dom (dty dbound) rng)
(make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound))))]
[(_ dom rng : props)
(->* dom rng : props)]
[(_ dom (dty dbound) rng : props)
(make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound) #:props props)))]))
[(_ dom rng : filters)
(->* dom rng : filters)]
[(_ dom (dty dbound) rng : filters)
(make-Function (list (make-arr* dom rng #:drest (cons dty 'dbound) #:filters filters)))]))
(define (simple-> doms rng)
(->* doms rng))
@ -238,8 +240,8 @@
(define obj (-acc-path path (-id-path var)))
(make-Function
(list (make-arr* dom rng
#:props (-PS (-not-type obj (-val #f))
(-is-type obj (-val #f)))
#:filters (-FS (-not-filter (-val #f) obj)
(-filter (-val #f) obj))
#:object obj))))
(define (cl->* . args)

2
typed-racket-lib/typed-racket/types/classes.rkt
View File

@ -133,7 +133,7 @@
;; class type with row variable is found.
(define (inf type)
(type-case
(#:Type inf #:Prop (sub-f inf) #:Object (sub-o inf))
(#:Type inf #:Filter (sub-f inf) #:Object (sub-o inf))
type
[#:Class row inits fields methods augments init-rest
(cond

259
typed-racket-lib/typed-racket/types/filter-ops.rkt Normal file
View File

@ -0,0 +1,259 @@
#lang racket/base
(require "../utils/utils.rkt"
racket/list racket/match
(prefix-in c: (contract-req))
(rep type-rep filter-rep object-rep rep-utils)
(only-in (infer infer) restrict)
(types union subtype remove-intersect abbrev tc-result))
(provide/cond-contract
[-and (c:->* () #:rest (c:listof Filter/c) Filter/c)]
[-or (c:->* () #:rest (c:listof Filter/c) Filter/c)]
[-imp (c:-> Filter/c Filter/c Filter/c)]
[implied-atomic? (c:-> Filter/c Filter/c boolean?)]
[complementary? (c:-> Filter/c Filter/c boolean?)]
[contradictory? (c:-> Filter/c Filter/c boolean?)]
[add-unconditional-filter-all-args (c:-> Function? Type/c Function?)]
[add-unconditional-prop (c:-> tc-results/c Filter/c tc-results/c)]
[erase-filter (c:-> tc-results/c tc-results/c)]
[name-ref=? (c:-> name-ref/c name-ref/c boolean?)])
(define (atomic-filter? p)
(or (TypeFilter? p) (NotTypeFilter? p)
(Top? p) (Bot? p)))
;; contradictory: Filter/c Filter/c -> boolean?
;; Returns true if the AND of the two filters is equivalent to Bot
(define (contradictory? f1 f2)
(match* (f1 f2)
[((TypeFilter: t1 p) (NotTypeFilter: t2 p))
(subtype t1 t2)]
[((NotTypeFilter: t2 p) (TypeFilter: t1 p))
(subtype t1 t2)]
[((Bot:) _) #t]
[(_ (Bot:)) #t]
[(_ _) #f]))
;; complementary: Filter/c Filter/c -> boolean?
;; Returns true if the OR of the two filters is equivalent to Top
(define (complementary? f1 f2)
(match* (f1 f2)
[((TypeFilter: t1 p) (NotTypeFilter: t2 p))
(subtype t2 t1)]
[((NotTypeFilter: t2 p) (TypeFilter: t1 p))
(subtype t2 t1)]
[((Top:) (Top:)) #t]
[(_ _) #f]))
(define (name-ref=? a b)
(or (equal? a b)
(and (identifier? a)
(identifier? b)
(free-identifier=? a b))))
;; is f1 implied by f2?
(define (implied-atomic? f1 f2)
(match* (f1 f2)
[(f f) #t]
[((Top:) _) #t]
[(_ (Bot:)) #t]
[((OrFilter: ps) (OrFilter: qs))
(for/and ([q (in-list qs)])
(for/or ([p (in-list ps)])
(filter-equal? p q)))]
[((OrFilter: fs) f2)
(for/or ([f (in-list fs)])
(filter-equal? f f2))]
[(f1 (AndFilter: fs))
(for/or ([f (in-list fs)])
(filter-equal? f f1))]
[((TypeFilter: t1 p) (TypeFilter: t2 p))
(subtype t2 t1)]
[((NotTypeFilter: t2 p) (NotTypeFilter: t1 p))
(subtype t2 t1)]
[((NotTypeFilter: t1 p) (TypeFilter: t2 p))
(not (overlap t1 t2))]
[(_ _) #f]))
(define (hash-name-ref i)
(if (identifier? i) (hash-id i) i))
;; compact : (Listof prop) bool -> (Listof prop)
;; props : propositions to compress
;; or? : is this an OrFilter (alternative is AndFilter)
;;
;; This combines all the TypeFilters at the same path into one TypeFilter. If it is an OrFilter the
;; combination is done using Un, otherwise, restrict. The reverse is done for NotTypeFilters. If it is
;; an OrFilter this simplifies to -top if any of the atomic filters simplified to -top, and removes
;; any -bot values. The reverse is done if this is an AndFilter.
;;
(define/cond-contract (compact props or?)
((c:listof Filter/c) boolean? . c:-> . (c:listof Filter/c))
(define tf-map (make-hash))
(define ntf-map (make-hash))
(define (restrict-update dict t1 p)
(hash-update! dict p (λ (t2) (restrict t1 t2)) Univ))
(define (union-update dict t1 p)
(hash-update! dict p (λ (t2) (Un t1 t2)) -Bottom))
(define-values (atomics others) (partition atomic-filter? props))
(for ([prop (in-list atomics)])
(match prop
[(TypeFilter: t1 p)
((if or? union-update restrict-update) tf-map t1 p) ]
[(NotTypeFilter: t1 p)
((if or? restrict-update union-update) ntf-map t1 p) ]))
(define raw-results
(append others
(for/list ([(k v) (in-hash tf-map)]) (-filter v k))
(for/list ([(k v) (in-hash ntf-map)]) (-not-filter v k))))
(if or?
(if (member -top raw-results)
(list -top)
(filter-not Bot? raw-results))
(if (member -bot raw-results)
(list -bot)
(filter-not Top? raw-results))))
;; invert-filter: Filter/c -> Filter/c
;; Logically inverts a filter.
(define (invert-filter p)
(match p
[(Bot:) -top]
[(Top:) -bot]
[(TypeFilter: t p) (-not-filter t p)]
[(NotTypeFilter: t p) (-filter t p)]
[(AndFilter: fs) (apply -or (map invert-filter fs))]
[(OrFilter: fs) (apply -and (map invert-filter fs))]
[(ImpFilter: f1 f2) (-and f1 (invert-filter f2))]))
;; -imp: Filter/c Filter/c -> Filter/c
;; Smart constructor for make-ImpFilter
(define (-imp p1 p2)
(match* (p1 p2)
[(t t) -top]
[((Bot:) _) -top]
[(_ (Top:)) -top]
[((Top:) _) p2]
[(_ (Bot:)) (invert-filter p1)]
[(_ _) (make-ImpFilter p1 p2)]))
(define (-or . args)
(define mk
(case-lambda [() -bot]
[(f) f]
[fs (make-OrFilter (sort fs filter<?))]))
(define (distribute args)
(define-values (ands others) (partition AndFilter? args))
(if (null? ands)
(apply mk others)
(match-let ([(AndFilter: elems) (car ands)])
(apply -and (for/list ([a (in-list elems)])
(apply -or a (append (cdr ands) others)))))))
(let loop ([fs args] [result null])
(if (null? fs)
(distribute (compact result #t))
(match (car fs)
[(and t (Top:)) t]
[(OrFilter: fs*) (loop (append fs* (cdr fs)) result)]
[(Bot:) (loop (cdr fs) result)]
[t
(cond [(for/or ([f (in-list (append (cdr fs) result))])
(complementary? f t))
-top]
[(let ([t-seq (Rep-seq t)])
(for/or ([f (in-list result)])
(or (= (Rep-seq f) t-seq) (implied-atomic? f t))))
(loop (cdr fs) result)]
[else
(loop (cdr fs) (cons t result))])]))))
(define (-and . args)
(define mk
(case-lambda [() -top]
[(f) f]
[fs (make-AndFilter (sort fs filter<?))]))
(define (flatten-ands fs)
(let loop ([fs fs] [results null])
(match fs
[(list) results]
[(cons (AndFilter: fs*) fs) (loop fs (append fs* results))]
[(cons f fs) (loop fs (cons f results))])))
;; Move all the type filters up front as they are the stronger props
(define-values (filters other-args)
(partition (λ (f) (or (TypeFilter? f) (NotTypeFilter? f)))
(flatten-ands (remove-duplicates args eq? #:key Rep-seq))))
(define-values (type-filters not-type-filters)
(partition TypeFilter? filters))
(let loop ([fs (append type-filters not-type-filters other-args)] [result null])
(if (null? fs)
(apply mk (compact result #f))
(match (car fs)
[(and t (Bot:)) t]
[(Top:) (loop (cdr fs) result)]
[t (cond [(for/or ([f (in-list (append (cdr fs) result))])
(contradictory? f t))
-bot]
[(let ([t-seq (Rep-seq t)])
(for/or ([f (in-list result)])
(or (= (Rep-seq f) t-seq)
(implied-atomic? t f))))
(loop (cdr fs) result)]
[else
(loop (cdr fs) (cons t result))])]))))
;; add-unconditional-prop: tc-results? Filter/c? -> tc-results?
;; Ands the given proposition to the filters in the tc-results.
;; Useful to express properties of the form: if this expressions returns at all, we learn this
(define (add-unconditional-prop results prop)
(match results
[(tc-any-results: f) (tc-any-results (-and prop f))]
[(tc-results: ts (list (FilterSet: fs+ fs-) ...) os)
(ret ts
(for/list ([f+ fs+] [f- fs-])
(-FS (-and prop f+) (-and prop f-)))
os)]
[(tc-results: ts (list (FilterSet: fs+ fs-) ...) os dty dbound)
(ret ts
(for/list ([f+ fs+] [f- fs-])
(-FS (-and prop f+) (-and prop f-)))
os)]))
;; ands the given type filter to both sides of the given arr for each argument
;; useful to express properties of the form: if this function returns at all,
;; we learn this about its arguments (like fx primitives, or car/cdr, etc.)
(define (add-unconditional-filter-all-args arr type)
(match arr
[(Function: (list (arr: dom rng rest drest kws)))
(match rng
[(Values: (list (Result: tp (FilterSet: -true-filter -false-filter) op)))
(let ([new-filters (apply -and (build-list (length dom)
(lambda (i)
(-filter type i))))])
(make-Function
(list (make-arr
dom
(make-Values
(list (-result tp
(-FS (-and -true-filter new-filters)
(-and -false-filter new-filters))
op)))
rest drest kws))))])]))
;; tc-results/c -> tc-results/c
(define (erase-filter tc)
(match tc
[(tc-any-results: _) (tc-any-results -no-filter)]
[(tc-results: ts _ _)
(ret ts
(for/list ([f (in-list ts)]) -no-filter)
(for/list ([f (in-list ts)]) -no-obj))]
[(tc-results: ts _ _ dty dbound)
(ret ts
(for/list ([f (in-list ts)]) -no-filter)
(for/list ([f (in-list ts)]) -no-obj)
dty dbound)]))

12
typed-racket-lib/typed-racket/types/kw-types.rkt
View File

@ -70,11 +70,11 @@
(list (make-arr* ts rng #:rest rest #:drest drest)))))
;; This is used to fix the props of keyword types.
;; TODO: This should also explore deeper into the actual types and remove props in there as well.
;; TODO: This should not remove the props but instead make them refer to the actual arguments after
;; This is used to fix the filters of keyword types.
;; TODO: This should also explore deeper into the actual types and remove filters in there as well.
;; TODO: This should not remove the filters but instead make them refer to the actual arguments after
;; keyword conversion.
(define (erase-props/Values values)
(define (erase-filter/Values values)
(match values
[(AnyValues: _) ManyUniv]
[(Results: ts fs os)
@ -219,7 +219,7 @@
(and rest? (last other-args)))
(make-Function
(list (make-arr* (take other-args non-kw-argc)
(erase-props/Values rng)
(erase-filter/Values rng)
#:kws actual-kws
#:rest rest-type)))]
[(and (even? (length arrs)) ; had optional args
@ -241,7 +241,7 @@
(make-Function
(for/list ([to-take (in-range (add1 (length opt-types)))])
(make-arr* (append mand-args (take opt-types to-take))
(erase-props/Values rng)
(erase-filter/Values rng)
#:kws actual-kws
#:rest rest-type)))]
[else (int-err "unsupported arrs in keyword function type")])]

10
typed-racket-lib/typed-racket/types/match-expanders.rkt
View File

@ -11,7 +11,7 @@
(for-syntax racket/base syntax/parse))
(provide Listof: List: MListof: AnyPoly: AnyPoly-names: Function/arrs:
PredicateProp:)
PredicateFilter:)
(define-match-expander Listof:
@ -95,10 +95,10 @@
[(_ doms rngs rests drests kws (~optional (~seq #:arrs arrs) #:defaults ([arrs #'_])))
#'(Function: (and arrs (list (arr: doms rngs rests drests kws) (... ...))))])))
;; A match expander for matching the prop on a predicate. This assumes a standard
;; A match expander for matching the filter on a predicate. This assumes a standard
;; predicate type of the shape (-> Any Any : SomeType)
(define-match-expander PredicateProp:
(define-match-expander PredicateFilter:
(λ (stx)
(syntax-parse stx
[(_ ps)
#'(Function: (list (arr: (list _) (Values: (list (Result: _ ps _))) _ _ _)))])))
[(_ fs)
#'(Function: (list (arr: (list _) (Values: (list (Result: _ fs _))) _ _ _)))])))

125
typed-racket-lib/typed-racket/types/overlap.rkt
View File

@ -1,125 +0,0 @@
#lang racket/base
(require "../utils/utils.rkt"
(rep type-rep rep-utils)
(prefix-in c: (contract-req))
(types abbrev subtype resolve utils)
racket/match racket/set)
(provide overlap?)
(define (simple-datum? v)
(or (null? v)
(symbol? v)
(number? v)
(boolean? v)
(pair? v)
(string? v)
(keyword? v)
(char? v)
(void? v)
(eof-object? v)))
;; overlap?
;; Type Type -> Boolean
;; a conservative check to see if two types
;; have a non-empty intersection
(define/cond-contract (overlap? t1 t2)
(c:-> Type/c Type/c boolean?)
(define k1 (Type-key t1))
(define k2 (Type-key t2))
(cond
[(type-equal? t1 t2) #t]
[(and (symbol? k1) (symbol? k2) (not (eq? k1 k2))) #f]
[(and (symbol? k1) (pair? k2) (not (memq k1 k2))) #f]
[(and (symbol? k2) (pair? k1) (not (memq k2 k1))) #f]
[(and (pair? k1) (pair? k2)
(for/and ([i (in-list k1)]) (not (memq i k2))))
#f]
[else
(match*/no-order
(t1 t2)
[((Univ:) _) #:no-order #t]
[((or (B: _) (F: _)) _) #:no-order #t]
[((Opaque: _) _) #:no-order #t]
[((Name/simple: n) (Name/simple: n*))
(or (free-identifier=? n n*)
(overlap? (resolve-once t1) (resolve-once t2)))]
[(t (? Name? s))
#:no-order
(overlap? t (resolve-once s))]
[((? Mu? t) s) #:no-order (overlap? (unfold t) s)]
[((Refinement: t _) s) #:no-order (overlap? t s)]
[((Union: ts) s)
#:no-order
(ormap (λ (t) (overlap? t s)) ts)]
[((Intersection: ts) s)
#:no-order
(for/and ([t (in-immutable-set ts)])
(overlap? t s))]
[((? Poly?) _) #:no-order #t] ;; conservative
[((Base: s1 _ _ _) (Base: s2 _ _ _)) (or (subtype t1 t2) (subtype t2 t1))]
[((? Base? t) (? Value? s)) #:no-order (subtype s t)] ;; conservative
[((Syntax: t) (Syntax: t*)) (overlap? t t*)]
[((Syntax: _) _) #:no-order #f]
[((Base: _ _ _ _) _) #:no-order #f]
[((Value: (? pair?)) (Pair: _ _)) #:no-order #t]
[((Pair: a b) (Pair: a* b*)) (and (overlap? a a*)
(overlap? b b*))]
;; lots of things are sequences, but not values where sequence? produces #f
[((Sequence: _) (Value: v)) #:no-order (sequence? v)]
[((Sequence: _) _) #:no-order #t]
;; Values where evt? produces #f cannot be Evt
[((Evt: _) (Value: v)) #:no-order (evt? v)]
[((Pair: _ _) _) #:no-order #f]
[((Value: (? simple-datum? v1))
(Value: (? simple-datum? v2)))
(equal? v1 v2)]
[((Value: (? simple-datum?))
(or (? Struct?) (? StructTop?) (? Function?)))
#:no-order
#f]
[((Value: (not (? hash?)))
(or (? Hashtable?) (? HashtableTop?)))
#:no-order
#f]
[((Struct: n _ flds _ _ _)
(Struct: n* _ flds* _ _ _))
#:when (free-identifier=? n n*)
(for/and ([f (in-list flds)] [f* (in-list flds*)])
(match* (f f*)
[((fld: t _ _) (fld: t* _ _)) (overlap? t t*)]))]
[((Struct: n #f _ _ _ _)
(StructTop: (Struct: n* #f _ _ _ _)))
#:when (free-identifier=? n n*)
#t]
;; n and n* must be different, so there's no overlap
[((Struct: n #f flds _ _ _)
(Struct: n* #f flds* _ _ _))
#f]
[((Struct: n #f flds _ _ _)
(StructTop: (Struct: n* #f flds* _ _ _)))
#f]
[((and t1 (Struct: _ _ _ _ _ _))
(and t2 (Struct: _ _ _ _ _ _)))
(or (subtype t1 t2) (subtype t2 t1)
(parent-of? t1 t2) (parent-of? t2 t1))]
[(_ _) #t])]))
;; Type Type -> Boolean
;; Given two struct types, check if the second is a parent struct
;; type of the other (though possibly at different type instantiations
;; if they are polymorphic)
(define (parent-of? t1 t2)
(match* (t1 t2)
[((Struct: _ (Struct: pname1 _ _ _ _ _) _ _ _ _)
(Struct: pname2 _ _ _ _ _))
#:when (free-identifier=? pname1 pname2)
#t]
[((Struct: _ #f _ _ _ _)
other)
#f]
[((Struct: _ parent _ _ _ _)
other)
(parent-of? parent other)]))

86
typed-racket-lib/typed-racket/types/printer.rkt
View File

@ -1,13 +1,13 @@
#lang racket/base
;; This module provides functions for printing types and related
;; data structures such as propositions and objects
;; data structures such as filters and objects
(require racket/require racket/match racket/dict racket/string racket/promise
racket/pretty
racket/list
racket/set
(path-up "rep/type-rep.rkt" "rep/prop-rep.rkt" "rep/object-rep.rkt"
(path-up "rep/type-rep.rkt" "rep/filter-rep.rkt" "rep/object-rep.rkt"
"rep/rep-utils.rkt" "types/subtype.rkt"
"types/match-expanders.rkt"
"types/kw-types.rkt"
@ -24,15 +24,15 @@
(define-syntax (provide-printer stx)
(if (eq? printer-type 'debug)
#'(provide (rename-out [debug-printer print-type]
[debug-printer print-prop]
[debug-printer print-filter]
[debug-printer print-object]
[debug-printer print-pathelem]
[debug-pretty-format-type pretty-format-type]))
#'(provide print-type print-prop print-object print-pathelem
#'(provide print-type print-filter print-object print-pathelem
pretty-format-type)))
(provide-printer)
(provide print-complex-props? type-output-sexpr-tweaker
(provide print-complex-filters? type-output-sexpr-tweaker
current-print-type-fuel current-print-unexpanded)
@ -43,7 +43,7 @@
(define print-aliases #t)
(define type-output-sexpr-tweaker (make-parameter values))
(define print-complex-props? (make-parameter #f))
(define print-complex-filters? (make-parameter #f))
;; this parameter controls how far down the type to expand type names
;; interp. 0 -> don't expand
@ -69,15 +69,15 @@
;; print-type also takes an optional (Listof Symbol)
;;
;; These four functions call the helpers below to print an
;; s-expression representation of the given type/pathelem/prop/object.
;; s-expression representation of the given type/pathelem/filter/object.
(define (print-type type port write? [ignored-names '()])
(display (type->sexp type ignored-names) port))
(define (print-pathelem pe port write?)
(display (pathelem->sexp pe) port))
(define (print-prop prop port write?)
(display (prop->sexp prop) port))
(define (print-filter filter port write?)
(display (filter->sexp filter) port))
(define (print-object obj port write?)
(display (object->sexp obj) port))
@ -98,9 +98,9 @@
out))
(string-trim #:left? #f (substring (get-output-string out) indent)))
;; prop->sexp : Prop -> S-expression
;; Print a Prop (see prop-rep.rkt) to the given port
(define (prop->sexp filt)
;; filter->sexp : Filter -> S-expression
;; Print a Filter (see filter-rep.rkt) to the given port
(define (filter->sexp filt)
(define (name-ref->sexp name-ref)
(if (syntax? name-ref)
(syntax-e name-ref)
@ -110,16 +110,19 @@
'()
(list (map pathelem->sexp path))))
(match filt
[(PropSet: thn els) `(,(prop->sexp thn) \| ,(prop->sexp els))]
[(NotTypeProp: (Path: path nm) type)
[(FilterSet: thn els) `(,(filter->sexp thn) \| ,(filter->sexp els))]
[(NoFilter:) '-]
[(NotTypeFilter: type (Path: path nm))
`(! ,(type->sexp type) @ ,@(path->sexps path) ,(name-ref->sexp nm))]
[(TypeProp: (Path: path nm) type)
[(TypeFilter: type (Path: path nm))
`(,(type->sexp type) @ ,@(path->sexps path) ,(name-ref->sexp nm))]
[(TrueProp:) 'Top]
[(FalseProp:) 'Bot]
[(AndProp: a) `(AndProp ,@(map prop->sexp a))]
[(OrProp: a) `(OrProp ,@(map prop->sexp a))]
[else `(Unknown Prop: ,(struct->vector filt))]))
[(Bot:) 'Bot]
[(Top:) 'Top]
[(ImpFilter: a c)
`(ImpFilter ,(filter->sexp a) ,(filter->sexp c))]
[(AndFilter: a) `(AndFilter ,@(map filter->sexp a))]
[(OrFilter: a) `(OrFilter ,@(map filter->sexp a))]
[else `(Unknown Filter: ,(struct->vector filt))]))
;; pathelem->sexp : PathElem -> S-expression
;; Print a PathElem (see object-rep.rkt) to the given port
@ -136,6 +139,7 @@
;; Print an Object (see object-rep.rkt) to the given port
(define (object->sexp object)
(match object
[(NoObject:) '-]
[(Empty:) '-]
[(Path: pes i) (append (map pathelem->sexp pes) (list i))]
[else `(Unknown Object: ,(struct->vector object))]))
@ -218,37 +222,37 @@
(if rest `(,(type->sexp rest) *) null)
(if drest `(,(type->sexp (car drest)) ... ,(cdr drest)) null)
(match rng
[(AnyValues: (TrueProp:)) '(AnyValues)]
[(AnyValues: f) `(AnyValues : ,(prop->sexp f))]
[(Values: (list (Result: t (PropSet: (TrueProp:) (TrueProp:)) (Empty:))))
[(AnyValues: (Top:)) '(AnyValues)]
[(AnyValues: f) `(AnyValues : ,(filter->sexp f))]
[(Values: (list (Result: t (FilterSet: (Top:) (Top:)) (Empty:))))
(list (type->sexp t))]
[(Values: (list (Result: t
(PropSet: (TypeProp: (Path: pth (list 0 0)) ft)
(NotTypeProp: (Path: pth (list 0 0)) ft))
(FilterSet: (TypeFilter: ft (Path: pth (list 0 0)))
(NotTypeFilter: ft (Path: pth (list 0 0))))
(Empty:))))
;; Only print a simple prop for single argument functions,
;; since parse-type only accepts simple latent props on single
;; Only print a simple filter for single argument functions,
;; since parse-type only accepts simple latent filters on single
;; argument functions.
#:when (= 1 (length dom))
(if (null? pth)
`(,(type->sexp t) : ,(type->sexp ft))
`(,(type->sexp t) : ,(type->sexp ft) @
,@(map pathelem->sexp pth)))]
;; Print asymmetric props with only a positive prop as a
;; Print asymmetric filters with only a positive filter as a
;; special case (even when complex printing is off) because it's
;; useful to users who use functions like `prop`.
;; useful to users who use functions like `filter`.
[(Values: (list (Result: t
(PropSet: (TypeProp: (Path: '() (list 0 0)) ft) (TrueProp:))
(FilterSet: (TypeFilter: ft (Path: '() (list 0 0))) (Top:))
(Empty:))))
#:when (= 1 (length dom))
`(,(type->sexp t) : #:+ ,(type->sexp ft))]
[(Values: (list (Result: t fs (Empty:))))
(if (print-complex-props?)
`(,(type->sexp t) : ,(prop->sexp fs))
(if (print-complex-filters?)
`(,(type->sexp t) : ,(filter->sexp fs))
(list (type->sexp t)))]
[(Values: (list (Result: t lf lo)))
(if (print-complex-props?)
`(,(type->sexp t) : ,(prop->sexp lf) ,(object->sexp lo))
(if (print-complex-filters?)
`(,(type->sexp t) : ,(filter->sexp lf) ,(object->sexp lo))
(list (type->sexp t)))]
[_ (list (type->sexp rng))]))]
[else `(Unknown Function Type: ,(struct->vector arr))]))
@ -460,14 +464,12 @@
[(Union: elems)
(define-values (covered remaining) (cover-union type ignored-names))
(cons 'U (append covered (map t->s remaining)))]
[(Intersection: elems)
(cons '∩ (for/list ([elem (in-immutable-set elems)]) (t->s elem)))]
[(Pair: l r) `(Pairof ,(t->s l) ,(t->s r))]
[(ListDots: dty dbound) `(List ,(t->s dty) ... ,dbound)]
[(F: nm) nm]
;; FIXME (Values are not types and shouldn't need to be considered here
[(AnyValues: (TrueProp:)) 'AnyValues]
[(AnyValues: f) `(AnyValues : ,(prop->sexp f))]
[(AnyValues: (Top:)) 'AnyValues]
[(AnyValues: f) `(AnyValues : ,(filter->sexp f))]
[(Values: (list v)) v]
[(Values: (list v ...)) (cons 'values (map t->s v))]
[(ValuesDots: v dty dbound)
@ -516,11 +518,9 @@
,(t->s body))]
[(Signature: name extends mapping)
(syntax->datum name)]
[(Result: t
(or #f (PropSet: (TrueProp:) (TrueProp:)))
(or #f (Empty:))) (type->sexp t)]
[(Result: t fs (Empty:)) `(,(type->sexp t) : ,(prop->sexp fs))]
[(Result: t fs lo) `(,(type->sexp t) : ,(prop->sexp fs) : ,(object->sexp lo))]
[(Result: t (or (NoFilter:) (FilterSet: (Top:) (Top:))) (or (NoObject:) (Empty:))) (type->sexp t)]
[(Result: t fs (Empty:)) `(,(type->sexp t) : ,(filter->sexp fs))]
[(Result: t fs lo) `(,(type->sexp t) : ,(filter->sexp fs) : ,(object->sexp lo))]
[(MPair: s t) `(MPairof ,(t->s s) ,(t->s t))]
[(Refinement: parent p?)
`(Refinement ,(t->s parent) ,(syntax-e p?))]

257
typed-racket-lib/typed-racket/types/prop-ops.rkt
View File

@ -1,257 +0,0 @@
#lang racket/base
(require "../utils/utils.rkt"
racket/list racket/match
(prefix-in c: (contract-req))
(rep type-rep prop-rep object-rep rep-utils)
(only-in (infer infer) intersect)
(types union subtype overlap abbrev tc-result))
(provide/cond-contract
[-and (c:->* () #:rest (c:listof Prop?) Prop?)]
[-or (c:->* () #:rest (c:listof Prop?) Prop?)]
[implies-atomic? (c:-> Prop? Prop? boolean?)]
[negate-prop (c:-> Prop? Prop?)]
[complementary? (c:-> Prop? Prop? boolean?)]
[contradictory? (c:-> Prop? Prop? boolean?)]
[add-unconditional-prop-all-args (c:-> Function? Type/c Function?)]
[add-unconditional-prop (c:-> tc-results/c Prop? tc-results/c)]
[erase-props (c:-> tc-results/c tc-results/c)]
[name-ref=? (c:-> name-ref/c name-ref/c boolean?)])
(define (atomic-prop? p)
(or (TypeProp? p) (NotTypeProp? p)
(TrueProp? p) (FalseProp? p)))
;; contradictory: Prop? Prop? -> boolean?
;; Returns true if the AND of the two props is equivalent to FalseProp
(define (contradictory? f1 f2)
(match* (f1 f2)
[((TypeProp: o t1) (NotTypeProp: o t2))
(subtype t1 t2)]
[((NotTypeProp: o t2) (TypeProp: o t1))
(subtype t1 t2)]
[((FalseProp:) _) #t]
[(_ (FalseProp:)) #t]
[(_ _) #f]))
;; complementary: Prop? Prop? -> boolean?
;; Returns true if the OR of the two props is equivalent to Top
(define (complementary? f1 f2)
(match* (f1 f2)
[((TypeProp: o t1) (NotTypeProp: o t2))
(subtype t2 t1)]
[((NotTypeProp: o t2) (TypeProp: o t1))
(subtype t2 t1)]
[((TrueProp:) (TrueProp:)) #t]
[(_ _) #f]))
(define (name-ref=? a b)
(or (equal? a b)
(and (identifier? a)
(identifier? b)
(free-identifier=? a b))))
;; does p imply q? (but only directly/simply)
(define (implies-atomic? p q)
(match* (p q)
;; reflexivity
[(p p) #t]
;; trivial prop is always satisfied
[(_ (TrueProp:)) #t]
;; ex falso quodlibet
[((FalseProp:) _) #t]
;; ps ⊆ qs ?
[((OrProp: ps) (OrProp: qs))
(and (for/and ([p (in-list ps)])
(member p qs prop-equal?))
#t)]
;; p ∈ qs ?
[(p (OrProp: qs))
(and (member p qs prop-equal?) #t)]
;; q ∈ ps ?
[((AndProp: ps) q)
(and (member q ps prop-equal?) #t)]
;; t1 <: t2 ?
[((TypeProp: o t1) (TypeProp: o t2))
(subtype t1 t2)]
;; t2 <: t1 ?
[((NotTypeProp: o t1) (NotTypeProp: o t2))
(subtype t2 t1)]
;; t1 ∩ t2 = ∅ ?
[((TypeProp: o t1) (NotTypeProp: o t2))
(not (overlap? t1 t2))]
;; otherwise we give up
[(_ _) #f]))
(define (hash-name-ref i)
(if (identifier? i) (hash-id i) i))
;; compact : (Listof prop) bool -> (Listof prop)
;; props : propositions to compress
;; or? : is this an Or (alternative is And)
;;
;; This combines all the TypeProps at the same path into one TypeProp. If it is an Or the
;; combination is done using Un, otherwise, intersect. The reverse is done for NotTypeProps. If it is
;; an Or this simplifies to -tt if any of the atomic props simplified to -tt, and removes
;; any -ff values. The reverse is done if this is an And.
;;
(define/cond-contract (compact props or?)
((c:listof Prop?) boolean? . c:-> . (c:listof Prop?))
(define tf-map (make-hash))
(define ntf-map (make-hash))
(define (intersect-update dict t1 p)
(hash-update! dict p (λ (t2) (intersect t1 t2)) Univ))
(define (union-update dict t1 p)
(hash-update! dict p (λ (t2) (Un t1 t2)) -Bottom))
(define-values (atomics others) (partition atomic-prop? props))
(for ([prop (in-list atomics)])
(match prop
[(TypeProp: o t1)
((if or? union-update intersect-update) tf-map t1 o) ]
[(NotTypeProp: o t1)
((if or? intersect-update union-update) ntf-map t1 o) ]))
(define raw-results
(append others
(for/list ([(k v) (in-hash tf-map)]) (-is-type k v))
(for/list ([(k v) (in-hash ntf-map)]) (-not-type k v))))
(if or?
(if (member -tt raw-results)
(list -tt)
(filter-not FalseProp? raw-results))
(if (member -ff raw-results)
(list -ff)
(filter-not TrueProp? raw-results))))
;; negate-prop: Prop? -> Prop?
;; Logically inverts a prop.
(define (negate-prop p)
(match p
[(FalseProp:) -tt]
[(TrueProp:) -ff]
[(TypeProp: o t) (-not-type o t)]
[(NotTypeProp: o t) (-is-type o t)]
[(AndProp: ps) (apply -or (map negate-prop ps))]
[(OrProp: ps) (apply -and (map negate-prop ps))]))
(define (-or . args)
(define mk
(case-lambda [() -ff]
[(f) f]
[ps (make-OrProp (sort ps prop<?))]))
(define (distribute args)
(define-values (ands others) (partition AndProp? args))
(if (null? ands)
(apply mk others)
(match-let ([(AndProp: elems) (car ands)])
(apply -and (for/list ([a (in-list elems)])
(apply -or a (append (cdr ands) others)))))))
(let loop ([ps args] [result null])
(if (null? ps)
(distribute (compact result #t))
(match (car ps)
[(and t (TrueProp:)) t]
[(OrProp: ps*) (loop (append ps* (cdr ps)) result)]
[(FalseProp:) (loop (cdr ps) result)]
[t
(cond [(for/or ([f (in-list (append (cdr ps) result))])
(complementary? f t))
-tt]
[(let ([t-seq (Rep-seq t)])
(for/or ([f (in-list result)])
(or (= (Rep-seq f) t-seq) (implies-atomic? t f))))
(loop (cdr ps) result)]
[else
(loop (cdr ps) (cons t result))])]))))
(define (-and . args)
(define mk
(case-lambda [() -tt]
[(f) f]
[ps (make-AndProp (sort ps prop<?))]))
(define (flatten-ands ps)
(let loop ([ps ps] [results null])
(match ps
[(list) results]
[(cons (AndProp: ps*) ps) (loop ps (append ps* results))]
[(cons f ps) (loop ps (cons f results))])))
;; Move all the type props up front as they are the stronger props
(define-values (props other-args)
(partition (λ (p) (or (TypeProp? p) (NotTypeProp? p)))
(flatten-ands (remove-duplicates args eq? #:key Rep-seq))))
(define-values (type-props not-type-props)
(partition TypeProp? props))
(let loop ([ps (append type-props not-type-props other-args)] [result null])
(if (null? ps)
(apply mk (compact result #f))
(match (car ps)
[(and t (FalseProp:)) t]
[(TrueProp:) (loop (cdr ps) result)]
[t (cond [(for/or ([f (in-list (append (cdr ps) result))])
(contradictory? f t))
-ff]
[(let ([t-seq (Rep-seq t)])
(for/or ([f (in-list result)])
(or (= (Rep-seq f) t-seq)
(implies-atomic? f t))))
(loop (cdr ps) result)]
[else
(loop (cdr ps) (cons t result))])]))))
;; add-unconditional-prop: tc-results? Prop? -> tc-results?
;; Ands the given proposition to the props in the tc-results.
;; Useful to express properties of the form: if this expressions returns at all, we learn this
(define (add-unconditional-prop results prop)
(match results
[(tc-any-results: f) (tc-any-results (-and prop f))]
[(tc-results: ts (list (PropSet: ps+ ps-) ...) os)
(ret ts
(for/list ([f+ ps+] [f- ps-])
(-PS (-and prop f+) (-and prop f-)))
os)]
[(tc-results: ts (list (PropSet: ps+ ps-) ...) os dty dbound)
(ret ts
(for/list ([f+ ps+] [f- ps-])
(-PS (-and prop f+) (-and prop f-)))
os)]))
;; ands the given type prop to both sides of the given arr for each argument
;; useful to express properties of the form: if this function returns at all,
;; we learn this about its arguments (like fx primitives, or car/cdr, etc.)
(define (add-unconditional-prop-all-args arr type)
(match arr
[(Function: (list (arr: dom rng rest drest kws)))
(match rng
[(Values: (list (Result: tp (PropSet: -true-prop -false-prop) op)))
(let ([new-props (apply -and (build-list (length dom)
(lambda (i)
(-is-type i type))))])
(make-Function
(list (make-arr
dom
(make-Values
(list (-result tp
(-PS (-and -true-prop new-props)
(-and -false-prop new-props))
op)))
rest drest kws))))])]))
;; tc-results/c -> tc-results/c
(define (erase-props tc)
(match tc
[(tc-any-results: _) (tc-any-results #f)]
[(tc-results: ts _ _)
(define empties (make-list (length ts) #f))
(ret ts
empties
empties)]
[(tc-results: ts _ _ dty dbound)
(define empties (make-list (length ts) #f))
(ret ts
empties
empties
dty dbound)]))

114
typed-racket-lib/typed-racket/types/remove-intersect.rkt Normal file
View File

@ -0,0 +1,114 @@
#lang racket/base
(require "../utils/utils.rkt"
(rep type-rep rep-utils)
(types union subtype resolve utils)
racket/match)
(provide (rename-out [*remove remove]) overlap)
(define (simple-datum? v)
(or (null? v)
(symbol? v)
(number? v)
(boolean? v)
(pair? v)
(string? v)
(keyword? v)
(char? v)
(void? v)
(eof-object? v)))
(define (overlap t1 t2)
(let ([ks (Type-key t1)] [kt (Type-key t2)])
(cond
[(type-equal? t1 t2) #t]
[(and (symbol? ks) (symbol? kt) (not (eq? ks kt))) #f]
[(and (symbol? ks) (pair? kt) (not (memq ks kt))) #f]
[(and (symbol? kt) (pair? ks) (not (memq kt ks))) #f]
[(and (pair? ks) (pair? kt)
(for/and ([i (in-list ks)]) (not (memq i kt))))
#f]
[else
(match (list t1 t2)
[(list-no-order (Univ:) _) #t]
[(list-no-order (F: _) _) #t]
[(list-no-order (Opaque: _) _) #t]
[(list (Name/simple: n) (Name/simple: n*))
(or (free-identifier=? n n*)
(overlap (resolve-once t1) (resolve-once t2)))]
[(list-no-order t (? Name? s))
(overlap t (resolve-once s))]
[(list-no-order (? Mu? t) s) (overlap (unfold t) s)]
[(list-no-order (Refinement: t _) s) (overlap t s)]
[(list-no-order (Union: ts) s)
(ormap (lambda (t*) (overlap t* s)) ts)]
[(list-no-order (? Poly?) _) #t] ;; conservative
[(list (Base: s1 _ _ _) (Base: s2 _ _ _)) (or (subtype t1 t2) (subtype t2 t1))]
[(list-no-order (? Base? t) (? Value? s)) (subtype s t)] ;; conservative
[(list (Syntax: t) (Syntax: t*)) (overlap t t*)]
[(list-no-order (Syntax: _) _) #f]
[(list-no-order (Base: _ _ _ _) _) #f]
[(list-no-order (Value: (? pair?)) (Pair: _ _)) #t]
[(list (Pair: a b) (Pair: a* b*)) (and (overlap a a*)
(overlap b b*))]
;; lots of things are sequences, but not values where sequence? produces #f
[(list-no-order (Sequence: _) (Value: v)) (sequence? v)]
[(list-no-order (Sequence: _) _) #t]
;; Values where evt? produces #f cannot be Evt
[(list-no-order (Evt: _) (Value: v)) (evt? v)]
[(list-no-order (Pair: _ _) _) #f]
[(list (Value: (? simple-datum? v1))
(Value: (? simple-datum? v2)))
(equal? v1 v2)]
[(list-no-order (Value: (? simple-datum?))
(or (? Struct?) (? StructTop?) (? Function?)))
#f]
[(list-no-order (Value: (not (? hash?)))
(or (? Hashtable?) (? HashtableTop?)))
#f]
[(list (Struct: n _ flds _ _ _)
(Struct: n* _ flds* _ _ _))
#:when (free-identifier=? n n*)
(for/and ([f (in-list flds)] [f* (in-list flds*)])
(match* (f f*)
[((fld: t _ _) (fld: t* _ _)) (overlap t t*)]))]
[(list (Struct: n #f _ _ _ _)
(StructTop: (Struct: n* #f _ _ _ _)))
#:when (free-identifier=? n n*)
#t]
;; n and n* must be different, so there's no overlap
[(list (Struct: n #f flds _ _ _)
(Struct: n* #f flds* _ _ _))
#f]
[(list (Struct: n #f flds _ _ _)
(StructTop: (Struct: n* #f flds* _ _ _)))
#f]
[(list (and t1 (Struct: _ _ _ _ _ _))
(and t2 (Struct: _ _ _ _ _ _)))
(or (subtype t1 t2) (subtype t2 t1))]
[else #t])])))
;(trace overlap)
;; also not yet correct
;; produces old without the contents of rem
(define (*remove old rem)
(define initial
(if (subtype old rem)
(Un) ;; the empty type
(match (list old rem)
[(list (or (App: _ _ _) (? Name?)) t)
;; must be different, since they're not subtypes
;; and n must refer to a distinct struct type
old]
[(list (Union: l) rem)
(apply Un (map (lambda (e) (*remove e rem)) l))]
[(list (? Mu? old) t) (*remove (unfold old) t)]
[(list (Poly: vs b) t) (make-Poly vs (*remove b rem))]
[_ old])))
(if (subtype old initial) old initial))
;(trace *remove)

32
typed-racket-lib/typed-racket/types/remove.rkt
View File

@ -1,32 +0,0 @@
#lang racket/base
(require "../utils/utils.rkt"
(rep type-rep rep-utils)
(types abbrev union subtype resolve utils)
racket/match racket/set)
(provide remove)
;; remove
;; Type Type -> Type
;; conservatively calculates set subtraction
;; between the types (i.e. t - s)
(define (remove t s)
(define result
(let rem ([t t])
(match t
[_ #:when (subtype t s) -Bottom]
[(or (App: _ _ _) (? Name?))
;; must be different, since they're not subtypes
;; and n must refer to a distinct struct type
t]
[(Union: elems) (apply Un (map rem elems))]
[(Intersection: ts)
(apply -unsafe-intersect (set-map ts rem))]
[(? Mu?) (rem (unfold t))]
[(Poly: vs b) (make-Poly vs (rem b))]
[_ t])))
(cond
[(subtype t result) t]
[else result]))

2
typed-racket-lib/typed-racket/types/struct-table.rkt
View File

@ -4,7 +4,7 @@
mzlib/pconvert racket/syntax
"../utils/utils.rkt"
(prefix-in c: (contract-req))
(rep type-rep prop-rep object-rep)
(rep type-rep filter-rep object-rep)
(utils tc-utils)
(env init-envs env-utils))

3
typed-racket-lib/typed-racket/types/structural.rkt
View File

@ -1,4 +1,3 @@
#lang racket/base
;; Module for providing recursive operations over types when the operation doesn't care about the
@ -104,7 +103,7 @@
#'(lambda (t)
(or (type.pred? t) ...))]))
;; Returns true if the type/prop/object supports structural operations.
;; Returns true if the type/filter/object supports structural operations.
(define structural? (gen-structural?))

6
typed-racket-lib/typed-racket/types/substitute.rkt
View File

@ -44,7 +44,7 @@
(define names (hash-keys subst))
(define fvs (free-vars* target))
(if (ormap (lambda (name) (free-vars-has-key? fvs name)) names)
(type-case (#:Type sb #:Prop (sub-f sb) #:Object (sub-o sb))
(type-case (#:Type sb #:Filter (sub-f sb) #:Object (sub-o sb))
target
[#:Union tys (apply Un (map sb tys))]
[#:F name (hash-ref subst name target)]
@ -92,7 +92,7 @@
(define (sb t) (substitute-dots images rimage name t))
(if (or (set-member? (free-vars-names (free-idxs* target)) name)
(set-member? (free-vars-names (free-vars* target)) name))
(type-case (#:Type sb #:Prop (sub-f sb)) target
(type-case (#:Type sb #:Filter (sub-f sb)) target
[#:ListDots dty dbound
(if (eq? name dbound)
;; We need to recur first, just to expand out any dotted usages of this.
@ -140,7 +140,7 @@
;; We do a quick check on the free variables to see if we can short circuit the substitution
(if (or (set-member? (free-vars-names (free-idxs* target)) name)
(set-member? (free-vars-names (free-vars* target)) name))
(type-case (#:Type sb #:Prop (sub-f sb))
(type-case (#:Type sb #:Filter (sub-f sb))
target
[#:ValuesDots types dty dbound
(let ([extra-types (if (eq? name dbound) pre-image null)])

59
typed-racket-lib/typed-racket/types/subtype.rkt
View File

@ -1,9 +1,8 @@
#lang racket/base
(require (except-in "../utils/utils.rkt" infer)
racket/match racket/function racket/lazy-require
racket/list racket/set
racket/match racket/function racket/lazy-require racket/list
(prefix-in c: (contract-req))
(rep type-rep prop-rep object-rep rep-utils)
(rep type-rep filter-rep object-rep rep-utils)
(utils tc-utils early-return)
(types utils resolve base-abbrev match-expanders
numeric-tower substitute current-seen prefab signatures)
@ -138,15 +137,15 @@
(subtype* (restrict-values s-rng t-dom) t-rng))]
[(_ _) #f]))
;; check subtyping of props, so that predicates subtype correctly
(define (prop-subtype* A0 s t)
;; check subtyping of filters, so that predicates subtype correctly
(define (filter-subtype* A0 s t)
(match* (s t)
[(f f) A0]
[((FalseProp:) t) A0]
[(s (TrueProp:)) A0]
[((TypeProp: o t1) (TypeProp: o t2))
[((Bot:) t) A0]
[(s (Top:)) A0]
[((TypeFilter: t1 p) (TypeFilter: t2 p))
(subtype* A0 t1 t2)]
[((NotTypeProp: o t1) (NotTypeProp: o t2))
[((NotTypeFilter: t1 p) (NotTypeFilter: t2 p))
(subtype* A0 t2 t1)]
[(_ _) #f]))
@ -273,18 +272,6 @@
;; value types
[((Value: v1) (Value: v2))
#:when (equal? v1 v2) A0]
[((Intersection: ss) t)
(and
(for/or ([s (in-immutable-set ss)])
(subtype* A0 s t))
A0)]
[(s (Intersection: ts))
(and
(for/fold ([A A0])
([t (in-immutable-set ts)]
#:break (not A))
(subtype* A s t))
A0)]
;; values are subtypes of their "type"
[((Value: v) (Base: _ _ pred _)) (if (pred v) A0 #f)]
;; tvars are equal if they are the same variable
@ -480,12 +467,14 @@
(loop (cdr l1) (cdr l2))]
[else
(loop l1 (cdr l2))]))]
[((Union: elems) t)
[((Union: es) t)
(and
(andmap (λ (elem) (subtype* A0 elem t)) elems)
(for/and ([elem (in-list es)])
(subtype* A0 elem t))
A0)]
[(s (Union: elems))
(and (ormap (λ (elem) (subtype* A0 s elem)) elems)
[(s (Union: es))
(and (for/or ([elem (in-list es)])
(subtype* A0 s elem))
A0)]
;; subtyping on immutable structs is covariant
[((Struct: nm _ flds proc _ _) (Struct: nm* _ flds* proc* _ _))
@ -607,26 +596,26 @@
(subtypes* s-rs t-rs)
(subtype* s-dty t-dty))]
[((AnyValues: s-f) (AnyValues: t-f))
(prop-subtype* A0 s-f t-f)]
(filter-subtype* A0 s-f t-f)]
[((or (Values: (list (Result: _ fs _) ...))
(ValuesDots: (list (Result: _ fs _) ...) _ _))
(AnyValues: t-f))
(for/or ([f (in-list fs)])
(match f
[(PropSet: f+ f-)
[(FilterSet: f+ f-)
(subtype-seq A0
(prop-subtype* f+ t-f)
(prop-subtype* f- t-f))]))]
[((Result: t (PropSet: ft ff) o) (Result: t* (PropSet: ft* ff*) o))
(filter-subtype* f+ t-f)
(filter-subtype* f- t-f))]))]
[((Result: t (FilterSet: ft ff) o) (Result: t* (FilterSet: ft* ff*) o))
(subtype-seq A0
(subtype* t t*)
(prop-subtype* ft ft*)
(prop-subtype* ff ff*))]
[((Result: t (PropSet: ft ff) o) (Result: t* (PropSet: ft* ff*) (Empty:)))
(filter-subtype* ft ft*)
(filter-subtype* ff ff*))]
[((Result: t (FilterSet: ft ff) o) (Result: t* (FilterSet: ft* ff*) (Empty:)))
(subtype-seq A0
(subtype* t t*)
(prop-subtype* ft ft*)
(prop-subtype* ff ff*))]
(filter-subtype* ft ft*)
(filter-subtype* ff ff*))]
;; subtyping on other stuff
[((Syntax: t) (Syntax: t*))
(subtype* A0 t t*)]

83
typed-racket-lib/typed-racket/types/tc-result.rkt
View File

@ -1,21 +1,20 @@
#lang racket/base
(require "../utils/utils.rkt"
(rep type-rep prop-rep)
(rep type-rep filter-rep)
(utils tc-utils)
(types base-abbrev)
racket/match
(prefix-in c: (contract-req)))
;; this structure represents the result of typechecking an expression
;; fields are #f only when the direct result of parsing or annotations
(define-struct/cond-contract tc-result
([t Type/c] [pset (c:or/c PropSet? #f)] [o (c:or/c Object? #f)])
([t Type/c] [f FilterSet/c] [o Object?])
#:transparent)
(define-struct/cond-contract tc-results
([ts (c:listof tc-result?)] [drest (c:or/c (c:cons/c Type/c symbol?) #f)])
#:transparent)
(define-struct/cond-contract tc-any-results ([f (c:or/c Prop? #f)]) #:transparent)
(define-struct/cond-contract tc-any-results ([f (c:or/c Filter/c NoFilter?)]) #:transparent)
(define (tc-results/c v)
(or (tc-results? v)
@ -25,17 +24,19 @@
(and (tc-results? v)
(= (length (tc-results-ts v)) 1)))
;; Contract to check that values are tc-results/c and do not contain #f propset or obj
;; Contract to check that values are tc-results/c and do not contain -no-filter or -no-obj.
;; Used to contract the return values of typechecking functions.
(define (full-tc-results/c r)
(match r
[(tc-any-results: p) (and p #t)]
[(tc-results: _ ps os)
(and (andmap (λ (x) x) ps)
(andmap (λ (x) x) os))]
[(tc-results: _ ps os _ _)
(and (andmap (λ (x) x) ps)
(andmap (λ (x) x) os))]
[(tc-any-results: f) (not (equal? -no-filter f))]
[(tc-results: _ fs os)
(and
(not (member -no-filter fs))
(not (member -no-obj os)))]
[(tc-results: _ fs os _ _)
(and
(not (member -no-filter fs))
(not (member -no-obj os)))]
[else #f]))
@ -44,9 +45,9 @@
[(_ tp fp op) (tc-result tp fp op)]
[(_ tp) (tc-result tp _ _)]))
;; expand-tc-results: (Listof tc-result) -> (Values (Listof Type) (Listof PropSet) (Listof Object))
;; expand-tc-results: (Listof tc-result) -> (Values (Listof Type) (Listof FilterSet) (Listof Object))
(define (expand-tc-results results)
(values (map tc-result-t results) (map tc-result-pset results) (map tc-result-o results)))
(values (map tc-result-t results) (map tc-result-f results) (map tc-result-o results)))
(define-match-expander tc-results:
(syntax-rules ()
@ -77,7 +78,7 @@
[(_ tp) (Results: (list tp))]
[(_ tp fp op) (Results: (list tp) (list fp) (list op))]))
;; expand-Results: (Listof Rresult) -> (Values (Listof Type) (Listof PropSet) (Listof Object))
;; expand-Results: (Listof Rresult) -> (Values (Listof Type) (Listof FilterSet) (Listof Object))
(define (expand-Results results)
(values (map Result-t results) (map Result-f results) (map Result-o results)))
@ -88,14 +89,14 @@
[(_ tp fp op) (Values: (app expand-Results tp fp op))]
[(_ tp fp op dty dbound) (ValuesDots: (app expand-Results tp fp op) dty dbound)]))
;; make-tc-result*: Type/c PropSet/c Object? -> tc-result?
;; make-tc-result*: Type/c FilterSet/c Object? -> tc-result?
;; Smart constructor for a tc-result.
(define (-tc-result type [prop -tt-propset] [object -empty-obj])
(define (-tc-result type [filter -top-filter] [object -empty-obj])
(cond
[(or (equal? type -Bottom) (equal? prop -ff-propset))
(tc-result -Bottom -ff-propset object)]
[(or (equal? type -Bottom) (equal? filter -bot-filter))
(tc-result -Bottom -bot-filter object)]
[else
(tc-result type prop object)]))
(tc-result type filter object)]))
;; convenience function for returning the result of typechecking an expression
@ -103,31 +104,31 @@
(case-lambda [(t)
(make-tc-results
(cond [(Type/c? t)
(list (-tc-result t -tt-propset -empty-obj))]
(list (-tc-result t -top-filter -empty-obj))]
[else
(for/list ([i (in-list t)])
(-tc-result i -tt-propset -empty-obj))])
(-tc-result i -top-filter -empty-obj))])
#f)]
[(t pset)
[(t f)
(make-tc-results
(if (Type/c? t)
(list (-tc-result t pset -empty-obj))
(for/list ([i (in-list t)] [pset (in-list pset)])
(-tc-result i pset -empty-obj)))
(list (-tc-result t f -empty-obj))
(for/list ([i (in-list t)] [f (in-list f)])
(-tc-result i f -empty-obj)))
#f)]
[(t pset o)
[(t f o)
(make-tc-results
(if (and (list? t) (list? pset) (list? o))
(map -tc-result t pset o)
(list (-tc-result t pset o)))
(if (and (list? t) (list? f) (list? o))
(map -tc-result t f o)
(list (-tc-result t f o)))
#f)]
[(t pset o dty)
[(t f o dty)
(int-err "ret used with dty without dbound")]
[(t pset o dty dbound)
[(t f o dty dbound)
(make-tc-results
(if (and (list? t) (list? pset) (list? o))
(map -tc-result t pset o)
(list (-tc-result t pset o)))
(if (and (list? t) (list? f) (list? o))
(map -tc-result t f o)
(list (-tc-result t f o)))
(cons dty dbound))]))
;(trace ret)
@ -136,11 +137,11 @@
[ret
(c:->i ([t (c:or/c Type/c (c:listof Type/c))])
([f (t) (if (list? t)
(c:listof (c:or/c #f PropSet?))
(c:or/c #f PropSet?))]
(c:listof FilterSet/c)
FilterSet/c)]
[o (t) (if (list? t)
(c:listof (c:or/c #f Object?))
(c:or/c #f Object?))]
(c:listof Object?)
Object?)]
[dty Type/c]
[dbound symbol?])
[res tc-results/c])])
@ -153,8 +154,8 @@
[rename -tc-result tc-result
(c:case->
(Type/c . c:-> . tc-result?)
(Type/c PropSet? Object? . c:-> . tc-result?))]
[tc-any-results ((c:or/c Prop? #f) . c:-> . tc-any-results?)]
(Type/c FilterSet/c Object? . c:-> . tc-result?))]
[tc-any-results ((c:or/c Filter/c NoFilter?) . c:-> . tc-any-results?)]
[tc-result-t (tc-result? . c:-> . Type/c)]
[rename tc-results-ts* tc-results-ts (tc-results? . c:-> . (c:listof Type/c))]
[tc-result-equal? (tc-result? tc-result? . c:-> . boolean?)]

23
typed-racket-lib/typed-racket/types/type-table.rkt
View File

@ -11,7 +11,7 @@
(contract-req)
(rep type-rep)
(types utils union printer)
(typecheck possible-domains tc-metafunctions)
(typecheck possible-domains)
(utils tc-utils)
(for-template racket/base))
@ -65,11 +65,28 @@
;; the car should be the latest stx for the location
(if (equal? e (car seen))
;; combine types seen at the latest
(tooltip seen (merge-tc-results (list t results)))
(tooltip seen ((combine t) results))
old)
(tooltip (cons e seen) t)))
(tooltip (list e) t)))
(hash-update! type-table e (λ (res) (merge-tc-results (list t res))) t))
(when (optimize?)
(hash-update! type-table e (combine t) t)))
;; when typechecking a case-> type, types get added for
;; the same subexpression multiple times, combine them
(define ((combine new) old)
(match* (old new)
[((tc-result1: old-t) (tc-result1: t-t))
(ret (Un old-t t-t))]
[((tc-results: old-ts) (tc-results: t-ts))
;; filters don't matter at this point, since only
;; the optimizer reads this table
(unless (= (length old-ts) (length t-ts))
(int-err
"type table: number of values don't agree ~a ~a"
old-ts t-ts))
(ret (map Un old-ts t-ts))]
[(_ _) new])) ; irrelevant to the optimizer, just clobber
(define (type-of e)
(hash-ref type-table e

95
typed-racket-lib/typed-racket/types/update.rkt
View File

@ -1,95 +0,0 @@
#lang racket/base
(require (rename-in "../utils/utils.rkt" [infer infer-in]))
(require racket/match racket/list
(contract-req)
(infer-in infer)
(rep type-rep prop-rep object-rep rep-utils)
(utils tc-utils)
(types resolve subtype remove union)
(rename-in (types abbrev)
[-> -->]
[->* -->*]
[one-of/c -one-of/c]))
(provide update)
;; update
;; t : type being updated
;; new-t : new type
;; pos? : whether the update is positive or negative
;; path-elems : which fields we're traversing to update,
;; in *syntactic order* (e.g. (car (cdr x)) -> '(car cdr))
(define/cond-contract (update t new-t pos? path-elems)
(Type/c Type/c boolean? (listof PathElem?) . -> . Type/c)
;; build-type: build a type while propogating bottom
(define (build constructor . args)
(if (memf Bottom? args) -Bottom (apply constructor args)))
;; update's inner recursive loop
;; puts path in *accessed* order
;; (i.e. (car (cdr x)) --> (list cdr car))
(let update
([t t] [path (reverse path-elems)])
(match path
;; path is empty (base case)
[(list) (cond
[pos? (intersect (resolve t) new-t)]
[else (remove (resolve t) new-t)])]
;; path is non-empty
;; (i.e. there is some field access we'll try and traverse)
[(cons path-elem rst)
(match* ((resolve t) path-elem)
;; pair ops
[((Pair: t s) (CarPE:))
(build -pair (update t rst) s)]
[((Pair: t s) (CdrPE:))
(build -pair t (update s rst))]
;; syntax ops
[((Syntax: t) (SyntaxPE:))
(build -Syntax (update t rst))]
;; promise op
[((Promise: t) (ForcePE:))
(build -Promise (update t rst))]
;; struct ops
[((Struct: nm par flds proc poly pred)
(StructPE: (? (λ (s) (subtype t s))) idx))
;; Note: this updates fields even if they are not polymorphic.
;; Because subtyping is nominal and accessor functions do not
;; reflect this, this behavior is unobservable except when a
;; variable aliases the field in a let binding
(define-values (lhs rhs) (split-at flds idx))
(define-values (ty* acc-id)
(match rhs
[(cons (fld: ty acc-id #f) _)
(values (update ty rst) acc-id)]
[_ (int-err "update on mutable struct field")]))
(cond
[(Bottom? ty*) ty*]
[else
(define flds*
(append lhs (cons (make-fld ty* acc-id #f) (cdr rhs))))
(make-Struct nm par flds* proc poly pred)])]
;; class field ops
;;
;; A refinement of a private field in a class is really a refinement of the
;; return type of the accessor function for that field (rather than a variable).
;; We cannot just refine the type of the argument to the accessor, since that
;; is an object type that doesn't mention private fields. Thus we use the
;; FieldPE path element as a marker to refine the result of the accessor
;; function.
[((Function: (list (arr: doms (Values: (list (Result: rng _ _))) _ _ _)))
(FieldPE:))
(make-Function
(list (make-arr* doms (update rng rst))))]
[((Union: ts) _)
(apply Un (map (λ (t) (update t path)) ts))]
[(_ _)
;; This likely comes up with (-lst t) and we need to improve the system to make sure this case
;; dosen't happen
;;(int-err "update along ill-typed path: ~a ~a ~a" t t* lo)
t])])))

2
typed-racket-lib/typed-racket/types/utils.rkt
View File

@ -20,7 +20,7 @@
(match t
[(Mu: name b)
(define (sb target)
(type-case (#:Type sb #:Prop (sub-f sb) #:Object (sub-o sb))
(type-case (#:Type sb #:Filter (sub-f sb) #:Object (sub-o sb))
target
[#:F name* (if (eq? name name*) t target)]))
(sb b)]))

23
typed-racket-lib/typed-racket/utils/redirect-contract.rkt
View File

@ -1,8 +1,6 @@
#lang racket/base
(require syntax/private/modcollapse-noctc
syntax/id-table
(for-template racket/base))
(require syntax/private/modcollapse-noctc (for-template racket/base))
(provide make-make-redirect-to-contract)
;; This is used to define identifiers that expand to a local-require
@ -26,23 +24,16 @@
;; This code was originally written by mflatt for the plai-typed
;; language, and then slightly adapted for TR by samth.
(define id-table (make-free-id-table))
(define ((make-make-redirect-to-contract contract-defs-submod-modidx) id)
(define (redirect stx)
(cond
[(identifier? stx)
(cond [(free-id-table-ref id-table stx #f)]
[else
(with-syntax ([mp (collapse-module-path-index
contract-defs-submod-modidx)]
[i (datum->syntax id (syntax-e id) stx stx)])
(define new-id
(syntax-local-lift-require
#`(rename mp i #,(datum->syntax #'mp (syntax-e #'i)))
#'i))
(free-id-table-set! id-table stx new-id)
new-id)])]
(with-syntax ([mp (collapse-module-path-index
contract-defs-submod-modidx)]
[i (datum->syntax id (syntax-e id) stx stx)])
(syntax-local-lift-require
#`(rename mp i #,(datum->syntax #'mp (syntax-e #'i)))
#'i))]
[else
(datum->syntax stx
(cons (redirect (car (syntax-e stx)))

13
typed-racket-lib/typed-racket/utils/simple-result-arrow.rkt
View File

@ -17,19 +17,6 @@
#:late-neg-projection
(λ (blm)
(lambda (v neg)
(unless (procedure? v)
(raise-blame-error
#:missing-party neg
blm #f
(list 'expected: "a procedure" 'given: (~s v))))
(unless (procedure-arity-includes? v arity)
(raise-blame-error
#:missing-party neg
blm #f
(list 'expected:
(format "a procedure that accepts ~a non-keyword argument"
arity)
'given: (~s v))))
;; We could have separate kinda-fast paths for when one of these conditions
;; is true, but that is unlikely to be an important case in practice.
(if (and (equal? arity (procedure-arity v))

23
typed-racket-lib/typed-racket/utils/utils.rkt
View File

@ -7,7 +7,6 @@ at least theoretically.
(require (for-syntax racket/base syntax/parse/pre racket/string)
racket/require-syntax racket/provide-syntax
racket/match
racket/struct-info "timing.rkt")
(provide
@ -21,8 +20,7 @@ at least theoretically.
list-extend
filter-multiple
syntax-length
in-sequence-forever
match*/no-order)
in-sequence-forever)
(define optimize? (make-parameter #t))
(define-for-syntax enable-contracts? (and (getenv "PLT_TR_CONTRACTS") #t))
@ -234,22 +232,3 @@ at least theoretically.
(λ (_) #t)
(λ _ #t)
(λ _ #t))))))
(define-syntax (match*/no-order stx)
(define (parse-clauses clauses)
(syntax-parse clauses
[() #'()]
[([(lpat rpat) #:no-order . body]
. rst)
#`([(lpat rpat) . body]
[(rpat lpat) . body]
. #,(parse-clauses #'rst))]
[((~and cl [(lpat rpat) . body])
. rst)
#`(#,(syntax/loc #'cl [(lpat rpat) . body])
. #,(parse-clauses #'rst))]))
(syntax-parse stx
[(_ (val1:expr val2:expr)
. clauses)
#`(match* (val1 val2)
. #,(parse-clauses #'clauses))]))

3
typed-racket-more/info.rkt
View File

@ -13,7 +13,6 @@
"typed-racket-lib"
"gui-lib"
"pict-lib"
"images-lib"
"racket-index"
"sandbox-lib"))
@ -21,4 +20,4 @@
(define pkg-authors '(samth stamourv))
(define version "1.5")
(define version "1.3")

210
typed-racket-more/typed/images/icons.rkt
View File

@ -1,210 +0,0 @@
#lang typed/racket/gui
(require typed/racket/draw)
(require "../private/require-batch.rkt")
;;; The Ray Tracer API has not stable enough yet,
;;; hence all the commented #:material arguments.
;;; As an alternative, please consider working
;;; with images/private/deep-flomap.rkt.
(require/typed/provide
images/icons/style
[default-icon-height (Parameterof Nonnegative-Real)]
[toolbar-icon-height (Parameterof Nonnegative-Real)]
[default-icon-backing-scale (Parameterof Positive-Real)]
[light-metal-icon-color (U String (Instance Color%))]
[metal-icon-color (U String (Instance Color%))]
[dark-metal-icon-color (U String (Instance Color%))]
[syntax-icon-color (U String (Instance Color%))]
[halt-icon-color (U String (Instance Color%))]
[run-icon-color (U String (Instance Color%))]
[bitmap-render-icon
(->* ((Instance Bitmap%))
(Nonnegative-Real #| Flomap-Material |#)
(Instance Bitmap%))]
[icon-color->outline-color
(-> (U String (Instance Color%)) (Instance Color%))])
(require/typed/provide
images/icons/file
[floppy-disk-icon
(-> [#:color (U String (Instance Color%))]
[#:height Nonnegative-Real]
[#:backing-scale Nonnegative-Real]
(Instance Bitmap%))])
(require/typed/provide
images/icons/symbol
[text-icon
(->* (String)
((Instance Font%)
#:trim? Boolean
#:color (U String (Instance Color%))
#:height Nonnegative-Real
;#:material Flomap-Material
#:outline Nonnegative-Real
#:backing-scale Nonnegative-Real)
(Instance Bitmap%))]
[x-icon
(-> [#:color (U String (Instance Color%))]
[#:height Nonnegative-Real]
;[#:material Flomap-Material]
[#:thickness Nonnegative-Real]
[#:backing-scale Nonnegative-Real]
(Instance Bitmap%))])
(require/typed/provide
images/icons/misc
[regular-polygon-icon
(->* (Positive-Integer #:color (U String (Instance Color%)))
(Real #:height Nonnegative-Real
;#:material Flomap-Material
#:backing-scale Nonnegative-Real)
(Instance Bitmap%))]
[foot-icon
(-> #:color (U String (Instance Color%))
[#:height Nonnegative-Real]
;[#:material Flomap-Material]
[#:backing-scale Nonnegative-Real]
(Instance Bitmap%))]
[close-icon
(-> [#:color (U String (Instance Color%))]
[#:height Nonnegative-Real]
;[#:material Flomap-Material]
[#:backing-scale Nonnegative-Real]
(Instance Bitmap%))]
[lock-icon
(->* ()
(Boolean #:body-color (U String (Instance Color%))
#:shackle-color (U String (Instance Color%))
#:height Nonnegative-Real
;#:material Flomap-Material
#:backing-scale Nonnegative-Real)
(Instance Bitmap%))])
(require/typed/provide
images/icons/stickman
[standing-stickman-icon
(-> [#:head-color (U String (Instance Color%))]
[#:arm-color (U String (Instance Color%))]
[#:body-color (U String (Instance Color%))]
[#:height Nonnegative-Real]
;[#:material Flomap-Material]
[#:backing-scale Nonnegative-Real]
(Instance Bitmap%))]
[running-stickman-icon
(-> Real
[#:head-color (U String (Instance Color%))]
[#:arm-color (U String (Instance Color%))]
[#:body-color (U String (Instance Color%))]
[#:height Nonnegative-Real]
;[#:material Flomap-Material]
[#:backing-scale Nonnegative-Real]
(Instance Bitmap%))])
(require/typed/provide
images/icons/tool
[debugger-bomb-color (U String (Instance Color%))]
[macro-stepper-hash-color (U String (Instance Color%))]
[small-macro-stepper-hash-color (U String (Instance Color%))])
(require/typed/provide/batch
images/icons/arrow
[id: right-arrow-icon left-arrow-icon up-arrow-icon down-arrow-icon
right-over-arrow-icon left-over-arrow-icon
right-under-arrow-icon left-under-arrow-icon]
(-> #:color (U String (Instance Color%))
[#:height Nonnegative-Real]
;[#:material Flomap-Material]
[#:backing-scale Nonnegative-Real]
(Instance Bitmap%)))
(require/typed/provide/batch
images/icons/control
[id: bar-icon play-icon back-icon fast-forward-icon rewind-icon
stop-icon record-icon pause-icon step-icon step-back-icon
continue-forward-icon continue-backward-icon search-forward-icon
search-backward-icon]
(-> #:color (U String (Instance Color%))
[#:height Nonnegative-Real]
;[#:material Flomap-Material]
[#:backing-scale Nonnegative-Real]
(Instance Bitmap%)))
(require/typed/provide/batch
images/icons/file
[save-icon load-icon small-save-icon small-load-icon]
(-> [#:disk-color (U String (Instance Color%))]
[#:arrow-color (U String (Instance Color%))]
[#:height Nonnegative-Real]
;[#:material Flomap-Material]
[#:backing-scale Nonnegative-Real]
(Instance Bitmap%)))
(require/typed/provide/batch
images/icons/symbol
[check-icon recycle-icon lambda-icon hash-quote-icon]
(-> [#:color (U String (Instance Color%))]
[#:height Nonnegative-Real]
;[#:material Flomap-Material]
[#:backing-scale Nonnegative-Real]
(Instance Bitmap%)))
(require/typed/provide/batch
images/icons/misc
[stop-sign-icon stop-signs-icon]
(-> [#:color (U String (Instance Color%))]
[#:height Nonnegative-Real]
;[#:material Flomap-Material]
[#:backing-scale Nonnegative-Real]
(Instance Bitmap%)))
(require/typed/provide/batch
images/icons/misc
[clock-icon stopwatch-icon]
(->* ()
(Byte Byte
#:face-color (U String (Instance Color%))
#:hand-color (U String (Instance Color%))
#:height Nonnegative-Real
#:backing-scale Nonnegative-Real)
(Instance Bitmap%)))
(require/typed/provide/batch
images/icons/misc
[stethoscope-icon short-stethoscope-icon]
(-> [#:color (U String (Instance Color%))]
[#:height Nonnegative-Real]
[#:backing-scale Nonnegative-Real]
(Instance Bitmap%)))
(require/typed/provide/batch
images/icons/misc
[bomb-icon left-bomb-icon]
(-> [#:cap-color (U String (Instance Color%))]
[#:bomb-color (U String (Instance Color%))]
[#:height Nonnegative-Real]
;[#:material Flomap-Material]
[#:backing-scale Nonnegative-Real]
(Instance Bitmap%)))
(require/typed/provide/batch
images/icons/misc
[magnifying-glass-icon left-magnifying-glass-icon]
(-> [#:frame-color (U String (Instance Color%))]
[#:handle-color (U String (Instance Color%))]
[#:height Nonnegative-Real]
;[#:material Flomap-Material]
[#:backing-scale Nonnegative-Real]
(Instance Bitmap%)))
(require/typed/provide/batch
images/icons/tool
[id: check-syntax-icon small-check-syntax-icon macro-stepper-icon
small-macro-stepper-icon debugger-icon small-debugger-icon]
(-> [#:height Nonnegative-Real]
;[#:material Flomap-Material]
[#:backing-scale Nonnegative-Real]
(Instance Bitmap%)))

11
typed-racket-more/typed/images/logos.rkt
View File

@ -1,11 +0,0 @@
#lang typed/racket
(require typed/racket/draw)
(require "../private/require-batch.rkt")
(require/typed/provide/batch
images/logos
[plt-logo planet-logo stepper-logo macro-stepper-logo]
(-> [#:height Nonnegative-Real]
[#:backing-scale Nonnegative-Real]
(Instance Bitmap%)))

17
typed-racket-more/typed/private/require-batch.rkt
View File

@ -1,17 +0,0 @@
#lang typed/racket
(provide (all-defined-out))
(define-syntax (require/typed/batch stx)
(syntax-case stx [id:]
[(_ modpath [id: id ...] type-definition)
#'(require/typed/batch modpath [id ...] type-definition)]
[(_ modpath [id ...] type-definition)
#'(require/typed modpath [id type-definition] ...)]))
(define-syntax (require/typed/provide/batch stx)
(syntax-case stx [id:]
[(_ modpath [id: id ...] type-definition)
#'(require/typed/provide/batch modpath [id ...] type-definition)]
[(_ modpath [id ...] type-definition)
#'(require/typed/provide modpath [id type-definition] ...)]))

7
typed-racket-more/typed/racket/fasl.rkt
View File

@ -1,7 +0,0 @@
#lang typed/racket/base
(require/typed/provide
racket/fasl
[s-exp->fasl (case-> [-> Any Bytes]
[-> Any Output-Port Void])]
[fasl->s-exp (-> (U Input-Port Bytes) Any)])

21
typed-racket-more/typed/racket/random.rkt
View File

@ -1,21 +0,0 @@
#lang typed/racket/base
;; Provides base types for racket/random
(require typed/racket/unsafe)
(unsafe-require/typed
racket/random
[crypto-random-bytes (-> Integer Bytes)]
[random-ref
(All (X)
(->* [(Sequenceof X)] [Pseudo-Random-Generator] X))]
[random-sample
(All (X)
(->* [(Sequenceof X) Integer]
[Pseudo-Random-Generator #:replacement? Any]
(Listof X)))])
(unsafe-provide crypto-random-bytes
random-ref
random-sample)

2
typed-racket-more/typed/rackunit/type-env-ext.rkt
View File

@ -6,7 +6,7 @@
racket/base syntax/parse
(utils tc-utils)
(env init-envs)
(except-in (rep prop-rep object-rep type-rep) make-arr)
(except-in (rep filter-rep object-rep type-rep) make-arr)
(rename-in (types abbrev union) [make-arr* make-arr])))
(define-for-syntax unit-env

7
typed-racket-test/fail/gh-issue-342.rkt
View File

@ -1,7 +0,0 @@
#;
(exn-pred 2)
#lang typed/racket
(: f (case→ (→ (→ (Values Any Any)) Any)
(→ 'sym Any)))
(define (f g) (g))

8
typed-racket-test/fail/no-setters-for-built-in-structs.rkt
View File

@ -1,8 +0,0 @@
#;
(exn-pred #rx"missing type for top-level")
#lang racket/load
;; Test that built-in struct fields don't have types for setters
(require typed/racket/base)
set-date-second!

20
typed-racket-test/fail/poly-struct-mutable-parent.rkt
View File

@ -1,20 +0,0 @@
#lang typed/racket
;; The call to `set-foo-x!` below should fail because the
;; predicate filter on `bar?` has to be restrictive.
(struct (A) foo ([x : A]) #:mutable)
(struct (A) baz foo ())
(define (f [i : Integer]) : (foo Integer)
(baz i))
(: x (foo Integer))
(define x (f 1))
(: y Any)
(define y x)
(if (baz? y) (set-foo-x! y "foo") 2)
(foo-x x)

2
typed-racket-test/fail/pr13365-variation-3.rkt
View File

@ -1,5 +1,5 @@
#;
(exn-pred #rx"mismatch in.*a ...")
(exn-pred #rx"Expected a ...")
#lang typed/racket
(: f (All (a ...) (a ... a -> (Values a ... a))))

2
typed-racket-test/fail/user-filter-with-bad-index-object.rkt
View File

@ -1,5 +1,5 @@
#;
(exn-pred #rx"Proposition's object index 3 is larger than argument length 1")
(exn-pred #rx"Filter proposition's object index 3 is larger than argument length 1")
#lang typed/racket
;; This test ensures that a filter object like '3' is

4
typed-racket-test/info.rkt
View File

@ -29,7 +29,7 @@
(define pkg-authors '(samth stamourv endobson asumu))
(define version "1.5")
(define version "1.3")
;; Collection info
@ -39,7 +39,7 @@
(define test-timeouts
'(("optimizer/run.rkt" 1200)
("run.rkt" 1800)
("with-tr-contracts.rkt" 3000)))
("with-tr-contracts.rkt" 2000)))
;; No need to compile the actual integration tests, just the harness.

Some files were not shown because too many files have changed in this diff Show More