From af2ced2967ea10f7c00d346222cbde9b3bcaf891 Mon Sep 17 00:00:00 2001 From: ben Date: Tue, 2 Feb 2016 04:36:42 -0500 Subject: [PATCH 1/7] add type-out provide-spec --- .../scribblings/reference/special-forms.scrbl | 41 +++- .../typed-racket/base-env/prims.rkt | 55 ++++++ .../typed-racket/typecheck/tc-toplevel.rkt | 11 +- .../fail/type-out-for-syntax.rkt | 14 ++ .../fail/type-out-omit-constructor-1.rkt | 11 ++ .../fail/type-out-omit-constructor-2.rkt | 7 + .../fail/type-out-omit-constructor-3.rkt | 7 + typed-racket-test/fail/type-out-rename.rkt | 15 ++ typed-racket-test/succeed/type-out.rkt | 178 ++++++++++++++++++ 9 files changed, 335 insertions(+), 4 deletions(-) create mode 100644 typed-racket-test/fail/type-out-for-syntax.rkt create mode 100644 typed-racket-test/fail/type-out-omit-constructor-1.rkt create mode 100644 typed-racket-test/fail/type-out-omit-constructor-2.rkt create mode 100644 typed-racket-test/fail/type-out-omit-constructor-3.rkt create mode 100644 typed-racket-test/fail/type-out-rename.rkt create mode 100644 typed-racket-test/succeed/type-out.rkt diff --git a/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl b/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl index d4395af14..157749e29 100644 --- a/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl +++ b/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl @@ -2,6 +2,7 @@ @begin[(require "../utils.rkt" scribble/example racket/sandbox) (require (for-label (only-meta-in 0 [except-in typed/racket]) + (only-in racket/contract contract-out) (only-in racket/base)))] @(define the-eval (make-base-eval)) @@ -514,9 +515,6 @@ for function types. (: var4 : String -> Integer)] } -@defform[(provide: [v t] ...)]{This declares that the @racket[v]s have -the types @racket[t], and also provides all of the @racket[v]s.} - @defform/none[#{v : t}]{ This declares that the variable @racket[v] has type @racket[t]. This is legal only for binding occurrences of @racket[_v]. @@ -677,6 +675,43 @@ Uses outside of a module top-level raise an error. (sync (alarm-evt (+ 100 (current-inexact-milliseconds))))] } +@section{Provide} + +@defform[(provide: [v t] ...)]{This declares that the @racket[v]s have +the types @racket[t], and also provides all of the @racket[v]s.} + +@defform/subs[ +#:literals (rename struct type) +(type-out type-out-spec ...) +([type-out-spec + (id t) + (rename orig-id id t) + (struct maybe-type-vars name-spec ([f : t] ...) struct-option ...) + (type id t)] + [struct-option (code:line options) + #:omit-constructor])]{ +A @racket[_provide-spec] similar to @racket[contract-out] for use in @racket[provide] + (currently only for the same phase level as the enclosing @racket[provide] form). +Declarations in a @racket[type-out] are visible within the module and exported to clients. + +The basic @racket[(id t)] form applies the type annotation @racket[t] to the identifier + @racket[id] and exports @racket[id]. +This has the same effect as the sequence @racket[(begin (: id t) (provide id))]. + +The @racket[rename] form assigns @racket[orig-id] the type @racket[t] and exports + @racket[orig-id] under the name @racket[id]. +Within the module only @racket[orig-id] is visible, but clients may only use @racket[id]. + +The @racket[struct] form accepts the same syntax as Typed Racket's @racket[struct] form + along with the @racket[#:omit-constructor] option from @racket[contract-out]. +This form defines a new structure type and exports the newly generated bindings; + if @racket[#:omit-constructor] is given the constructor name is not exported. + +The @racket[type] form defines @racket[id] as an alias for type @racket[t] + (using @racket[define-type]) and exports @racket[id]. +} + + @section{Other Forms} @defidform[with-handlers]{ diff --git a/typed-racket-lib/typed-racket/base-env/prims.rkt b/typed-racket-lib/typed-racket/base-env/prims.rkt index 0ac4028b1..f11b61da7 100644 --- a/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -34,6 +34,7 @@ the typed racket language. def-redirect define-for*-variants with-handlers: define-for/acc:-variants base-for/flvector: base-for/vector -lambda -define -do -let + provide-typed-vars -let* -let*-values -let-values -let/cc -let/ec -letrec -letrec-values) (all-from-out "top-interaction.rkt") (all-from-out "case-lambda.rkt") @@ -125,6 +126,7 @@ the typed racket language. syntax/parse/pre syntax/stx racket/list + racket/provide-transform racket/syntax racket/base (only-in "../typecheck/internal-forms.rkt" internal) @@ -636,6 +638,59 @@ the typed racket language. (begin (: i* t) ... (provide (rename-out [i* i] ...))))])) +(begin-for-syntax + (define-syntax-class (type-out-spec stx) + #:attributes (type-decl* provide-spec*) + #:datum-literals (rename struct type) + (pattern [n:id t] + #:attr type-decl* (syntax/loc stx ((: n t))) + #:attr provide-spec* (syntax/loc stx (n))) + (pattern [rename old-n:id new-n:id t] + #:attr type-decl* (syntax/loc stx ((: old-n t))) + #:attr provide-spec* (syntax/loc stx ((rename-out (old-n new-n))))) + (pattern [struct n:id e* ... + (~or + (~seq #:constructor-name c-id opt-1* ... #:omit-constructor opt-2* ...) + (~seq #:omit-constructor opt-1* ... #:constructor-name c-id opt-2* ...))] + #:attr type-decl* + (syntax/loc stx ((-struct n e* ... #:constructor-name c-id opt-1* ... opt-2* ...))) + #:attr provide-spec* + (syntax/loc stx ((except-out (struct-out n) c-id)))) + (pattern [struct n:id e* ... #:omit-constructor opt* ...] + #:attr type-decl* + (syntax/loc stx ((-struct n e* ... opt* ...))) + #:attr provide-spec* + (syntax/loc stx ((except-out (struct-out n) n)))) + (pattern [struct n:id e* ...] + #:attr type-decl* (syntax/loc stx ((-struct n e* ...))) + #:attr provide-spec* (syntax/loc stx ((struct-out n)))) + (pattern [type t e] + #:attr type-decl* (syntax/loc stx ((define-type-alias t e))) + #:attr provide-spec* (syntax/loc stx (t))))) + +(define-syntax provide-typed-vars + (make-provide-transformer + (λ (stx modes) + (for*/list ([provide-clause (in-list (syntax->list stx))] + [export (in-list (expand-export provide-clause modes))]) + export)))) + +(define-syntax type-out + (make-provide-pre-transformer + (lambda (stx modes) + (syntax-parse stx + [(_ (~var e* (type-out-spec stx)) ...) + ;; Move type declarations to the toplevel + (for ([t* (in-list (syntax->list #'(e*.type-decl* ...)))]) + (syntax-local-lift-module-end-declaration + (quasisyntax/loc stx (begin #,@t*)))) + ;; Collect a flat list of provide specs & expand + (with-syntax ([(name* ...) + (for*/list ([decl* (in-list (syntax->list #'(e*.provide-spec* ...)))] + [decl (in-list (syntax->list decl*))]) + decl)]) + (syntax/loc stx (provide-typed-vars name* ...)))])))) + (define-syntax (declare-refinement stx) (syntax-parse stx [(_ p:id) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt index 7550a59df..a564b7d88 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt @@ -315,11 +315,20 @@ (~datum prefix-all-defined) (~datum prefix-all-defined-except) (~datum expand))))) +;; Move type declarations to the beginning of the list, +;; keep other declarations in the same relative order. +;; (-> (Listof Syntax) (Listof Syntax)) +(define (lift-type-declarations form*) + (define (is-type-decl? form) + (syntax-parse form [_:type-declaration #t] [_ #f])) + (let*-values ([(type-decl* form*) (partition is-type-decl? form*)]) + (append type-decl* form*))) + ;; actually do the work on a module ;; produces prelude and post-lude syntax objects ;; syntax-list -> (values syntax syntax) (define (type-check forms0) - (define forms (syntax->list forms0)) + (define forms (lift-type-declarations (syntax->list forms0))) (do-time "before form splitting") (define-values (type-aliases struct-defs stx-defs0 val-defs0 provs signature-defs) (filter-multiple diff --git a/typed-racket-test/fail/type-out-for-syntax.rkt b/typed-racket-test/fail/type-out-for-syntax.rkt new file mode 100644 index 000000000..37f819841 --- /dev/null +++ b/typed-racket-test/fail/type-out-for-syntax.rkt @@ -0,0 +1,14 @@ +#lang racket/base + +;; type-out only works at phase 0, +;; because it inserts definitions at phase 0 +; in the enclosing module + +(module for-stx typed/racket/base + (require (for-syntax typed/racket/base)) + + (provide + (for-syntax (type-out [s (-> String String)]))) + + (define-for-syntax (s str) "")) +(require 'for-stx) diff --git a/typed-racket-test/fail/type-out-omit-constructor-1.rkt b/typed-racket-test/fail/type-out-omit-constructor-1.rkt new file mode 100644 index 000000000..f2c0d8f45 --- /dev/null +++ b/typed-racket-test/fail/type-out-omit-constructor-1.rkt @@ -0,0 +1,11 @@ +#lang racket/base + +;; (type-out (struct ... #:omit-constructor)) +;; Makes the struct constructor invisible + +(module omit-constructor typed/racket/base + (provide + (type-out (struct foo () #:omit-constructor)))) + +(require 'omit-constructor) +foo diff --git a/typed-racket-test/fail/type-out-omit-constructor-2.rkt b/typed-racket-test/fail/type-out-omit-constructor-2.rkt new file mode 100644 index 000000000..925f719e3 --- /dev/null +++ b/typed-racket-test/fail/type-out-omit-constructor-2.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(module constr-name typed/racket/base + (provide (type-out + (struct s () #:constructor-name makes #:omit-constructor)))) +(require 'constr-name) +makes diff --git a/typed-racket-test/fail/type-out-omit-constructor-3.rkt b/typed-racket-test/fail/type-out-omit-constructor-3.rkt new file mode 100644 index 000000000..9dc1e1c4d --- /dev/null +++ b/typed-racket-test/fail/type-out-omit-constructor-3.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +(module constr-name typed/racket/base + (provide (type-out + (struct s () #:omit-constructor #:constructor-name makes)))) +(require 'constr-name) +makes diff --git a/typed-racket-test/fail/type-out-rename.rkt b/typed-racket-test/fail/type-out-rename.rkt new file mode 100644 index 000000000..89809f658 --- /dev/null +++ b/typed-racket-test/fail/type-out-rename.rkt @@ -0,0 +1,15 @@ +#lang racket/base + +;; (type-out (rename ...)) +;; Does not provide original identifier + +(module rename typed/racket/base + (provide + (type-out (rename f g (-> Natural Natural)))) + (define (f n) + (let ([n-1 (- n 1)]) + (if (positive? n-1) (* n (f n-1)) 1)))) + +(require 'rename) +(f 4) + diff --git a/typed-racket-test/succeed/type-out.rkt b/typed-racket-test/succeed/type-out.rkt new file mode 100644 index 000000000..980b67844 --- /dev/null +++ b/typed-racket-test/succeed/type-out.rkt @@ -0,0 +1,178 @@ +#lang racket/base + +;; Tests for type-out +;; - submodules test different type-out forms, these should all compile + +;; ----------------------------------------------------------------------------- +;; basics / rename + +;; type-out a single definition +(module single typed/racket/base + (provide + (type-out [f (-> Natural Natural)])) + + (define (f n) + (define n-1 (- n 1)) + (if (positive? n-1) (* n (f n-1)) 1))) +(require 'single) + +;; type-out multiple definitions, along with ordinary provides +(module multi typed/racket/base + (provide + (type-out [n Natural] + [fact (-> Natural Natural)]) + fib) + + (define n 12) + + (define (fact n) + (define n-1 (- n 1)) + (if (positive? n-1) (* n (fact n-1)) 1)) + + (: fib (-> Natural Natural)) + (define (fib n) + (define n-1 (- n 1)) + (define n-2 (- n 2)) + (if (and (positive? n-1) (positive? n-2)) + (+ (fib n-1) (fib n-2)) 1))) +(require 'multi) + +;; use rename form +(module rename typed/racket/base + (provide + (type-out + [rename fact g (-> Natural Natural)])) + + (define (fact n) + (define n-1 (- n 1)) + (if (positive? n-1) (* n (fact n-1)) 1))) +(require 'rename) + +;; ----------------------------------------------------------------------------- +;; struct + +;; basic struct definition +(module defstruct typed/racket/base + (provide + (type-out + [struct foo ([a : Natural] [b : (-> Boolean String)])])) + (define f foo)) +(require 'defstruct) + +;; compatible with struct #:type-name +;; (but not cooperative -- need to provide new name explicitly) +(module defstruct/type-name typed/racket/base + (provide + Bar + (type-out + [struct bar () #:type-name Bar]))) +(module defstruct/type-name-user typed/racket/base + (require (submod ".." defstruct/type-name)) + (: barry Bar) + (define barry (bar))) +(require 'defstruct/type-name-user) + +;; struct with parent +(module struct/parent typed/racket/base + (provide (type-out + (struct bar ([x : Natural] [y : Boolean])) + (struct baz bar ([z : MyType])) + )) + (define-type MyType (-> Natural Boolean String))) +(require 'struct/parent) + +;; struct, #:omit-constructor +(module omit-constructor-1 typed/racket/base + (provide (type-out + (struct qux ([x : Natural] [y : Boolean]) #:omit-constructor)))) +(require 'omit-constructor-1) + +;; can re-order #:omit-constructor relative to other options +(module omit-constructor-2 typed/racket/base + (provide (type-out + (struct quux () #:type-name Quux #:omit-constructor) + (struct quuux () #:omit-constructor #:type-name Quuux)))) +(require 'omit-constructor-2) + +;; ----------------------------------------------------------------------------- +;; type + +(module deftype typed/racket/base + (provide (type-out + (type Person (Pairof String Natural)) + (person Person Person Boolean)))) + (define (person People People Boolean)) + (define (person Str Natural)]) + + (provide (type-out + (type MyTuple (Pairof String Natural)) + (a (-> MyTuple Boolean)))) + + (define (a x) + (and (cdr x) #t))) +(require 'opaque-1) + +(module opaque-2 typed/racket/base + (define-type MyTuple (Pairof Str Boolean)) + + (require/typed racket/base + [#:opaque Str string?] + [string-length (-> Str Natural)]) + + (define (b x) + #t)) +(require 'opaque-2) + +(module opaque-3 typed/racket/base + (define-type Foobar (-> Pict)) + + (require/typed pict + [#:opaque Pict pict?] + [blank (-> Real Real Pict)]) + + (provide (type-out + (c (-> Pict Boolean)))) + + (define (c x) + #t)) +(require 'opaque-3) + +;; ----------------------------------------------------------------------------- +;; compatible with #:constructor-name + +(module constr-name-1 typed/racket/base + (provide (type-out + (struct s () #:constructor-name makes))) + makes) +(require 'constr-name-1) + +(module constr-name-2 typed/racket/base + (provide (type-out + (struct r () #:omit-constructor #:constructor-name maker))) + maker) +(require 'constr-name-2) From 73561471c40eaf6170b4f07183078ccd920d219a Mon Sep 17 00:00:00 2001 From: ben Date: Wed, 3 Feb 2016 19:53:19 -0500 Subject: [PATCH 2/7] checkpoint: type-out is only annotations --- .../scribblings/reference/special-forms.scrbl | 20 +- .../typed-racket/base-env/prims.rkt | 51 +++-- .../private/syntax-properties.rkt | 1 + .../typed-racket/typecheck/tc-toplevel.rkt | 18 +- .../fail/type-out-struct-bad-option.rkt | 8 + .../fail/type-out-struct-missing-def.rkt | 7 + .../type-out-struct-missing-parent-field.rkt | 10 + typed-racket-test/succeed/type-out.rkt | 197 ++++++++++++------ 8 files changed, 207 insertions(+), 105 deletions(-) create mode 100644 typed-racket-test/fail/type-out-struct-bad-option.rkt create mode 100644 typed-racket-test/fail/type-out-struct-missing-def.rkt create mode 100644 typed-racket-test/fail/type-out-struct-missing-parent-field.rkt diff --git a/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl b/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl index 157749e29..e27c9041a 100644 --- a/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl +++ b/typed-racket-doc/typed-racket/scribblings/reference/special-forms.scrbl @@ -686,13 +686,16 @@ the types @racket[t], and also provides all of the @racket[v]s.} ([type-out-spec (id t) (rename orig-id id t) - (struct maybe-type-vars name-spec ([f : t] ...) struct-option ...) - (type id t)] - [struct-option (code:line options) + (struct maybe-type-vars id/super ((id : t) ...) + struct-option)] + [maybe-type-vars code:blank + (v ...)] + [id/super id + (id super-id)] + [struct-option (code:line) #:omit-constructor])]{ A @racket[_provide-spec] similar to @racket[contract-out] for use in @racket[provide] (currently only for the same phase level as the enclosing @racket[provide] form). -Declarations in a @racket[type-out] are visible within the module and exported to clients. The basic @racket[(id t)] form applies the type annotation @racket[t] to the identifier @racket[id] and exports @racket[id]. @@ -702,13 +705,8 @@ The @racket[rename] form assigns @racket[orig-id] the type @racket[t] and export @racket[orig-id] under the name @racket[id]. Within the module only @racket[orig-id] is visible, but clients may only use @racket[id]. -The @racket[struct] form accepts the same syntax as Typed Racket's @racket[struct] form - along with the @racket[#:omit-constructor] option from @racket[contract-out]. -This form defines a new structure type and exports the newly generated bindings; - if @racket[#:omit-constructor] is given the constructor name is not exported. - -The @racket[type] form defines @racket[id] as an alias for type @racket[t] - (using @racket[define-type]) and exports @racket[id]. +The @racket[struct] form describes the name and public fields of an existing structure type. +When the @racket[#:omit-constructor] option is given, the constructor name is not exported. } diff --git a/typed-racket-lib/typed-racket/base-env/prims.rkt b/typed-racket-lib/typed-racket/base-env/prims.rkt index f11b61da7..3436fce01 100644 --- a/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -30,6 +30,7 @@ the typed racket language. |# + (provide (except-out (all-defined-out) -let-internal define-for-variants def-redirect define-for*-variants with-handlers: define-for/acc:-variants @@ -641,32 +642,29 @@ the typed racket language. (begin-for-syntax (define-syntax-class (type-out-spec stx) #:attributes (type-decl* provide-spec*) - #:datum-literals (rename struct type) + #:datum-literals (rename struct type :) ;; 2016-02-03 'type' is unused for now (pattern [n:id t] #:attr type-decl* (syntax/loc stx ((: n t))) #:attr provide-spec* (syntax/loc stx (n))) (pattern [rename old-n:id new-n:id t] #:attr type-decl* (syntax/loc stx ((: old-n t))) #:attr provide-spec* (syntax/loc stx ((rename-out (old-n new-n))))) - (pattern [struct n:id e* ... - (~or - (~seq #:constructor-name c-id opt-1* ... #:omit-constructor opt-2* ...) - (~seq #:omit-constructor opt-1* ... #:constructor-name c-id opt-2* ...))] - #:attr type-decl* - (syntax/loc stx ((-struct n e* ... #:constructor-name c-id opt-1* ... opt-2* ...))) - #:attr provide-spec* - (syntax/loc stx ((except-out (struct-out n) c-id)))) - (pattern [struct n:id e* ... #:omit-constructor opt* ...] - #:attr type-decl* - (syntax/loc stx ((-struct n e* ... opt* ...))) - #:attr provide-spec* - (syntax/loc stx ((except-out (struct-out n) n)))) - (pattern [struct n:id e* ...] - #:attr type-decl* (syntax/loc stx ((-struct n e* ...))) - #:attr provide-spec* (syntax/loc stx ((struct-out n)))) - (pattern [type t e] - #:attr type-decl* (syntax/loc stx ((define-type-alias t e))) - #:attr provide-spec* (syntax/loc stx (t))))) + (pattern [struct (~optional (~seq (v*:id ...))) + (~or n:id (n:id parent:id)) + ((f*:id : t*) ...) + (~optional (~and #:omit-constructor omit?))] + #:attr type-decl* + (syntax/loc stx + ((let () + ;; TODO + ;; 1. If parent given, check that struct is supertype of parent + ;; 2. Check all field types + (void)))) + #:attr provide-spec* + ;; TODO `n` is not always the constructor name. See `contract-out` for help. + (if (attribute omit?) + (syntax/loc stx ((except-out (struct-out n) n))) + (syntax/loc stx ((struct-out n))))))) (define-syntax provide-typed-vars (make-provide-transformer @@ -681,15 +679,14 @@ the typed racket language. (syntax-parse stx [(_ (~var e* (type-out-spec stx)) ...) ;; Move type declarations to the toplevel - (for ([t* (in-list (syntax->list #'(e*.type-decl* ...)))]) + (with-syntax ([((t** ...) ...) #'(e*.type-decl* ...)]) (syntax-local-lift-module-end-declaration - (quasisyntax/loc stx (begin #,@t*)))) + (syntax-property ;; Mark, so we can lift to beginning of module later + (quasisyntax/loc stx (begin t** ... ...)) + tr:type-out:type-annotation-property #t))) ;; Collect a flat list of provide specs & expand - (with-syntax ([(name* ...) - (for*/list ([decl* (in-list (syntax->list #'(e*.provide-spec* ...)))] - [decl (in-list (syntax->list decl*))]) - decl)]) - (syntax/loc stx (provide-typed-vars name* ...)))])))) + (with-syntax ([((spec** ...) ...) #'(e*.provide-spec* ...)]) + (syntax/loc stx (provide-typed-vars spec** ... ...)))])))) (define-syntax (declare-refinement stx) (syntax-parse stx diff --git a/typed-racket-lib/typed-racket/private/syntax-properties.rkt b/typed-racket-lib/typed-racket/private/syntax-properties.rkt index f9b4500eb..3a1ac8b8f 100644 --- a/typed-racket-lib/typed-racket/private/syntax-properties.rkt +++ b/typed-racket-lib/typed-racket/private/syntax-properties.rkt @@ -74,6 +74,7 @@ (tr:class:local-table tr:class:local-table) (tr:class:name-table tr:class:name-table) (tr:class:def tr:class:def) + (tr:type-out:type-annotation tr:type-out:type-annotation) (tr:unit tr:unit #:mark) (tr:unit:body-exp-def-type tr:unit:body-exp-def-type) (tr:unit:invoke tr:unit:invoke) diff --git a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt index a564b7d88..9f45a2bcd 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt @@ -315,20 +315,22 @@ (~datum prefix-all-defined) (~datum prefix-all-defined-except) (~datum expand))))) -;; Move type declarations to the beginning of the list, -;; keep other declarations in the same relative order. +;; Move type declarations introduced by 'type-out' to the beginning +;; of a list of forms. +;; Maintain relative ordering of lifted declarations and of other declarations. +;; Exists because typechecking depends on the ordering of annotations vs. defs, +;; and there is no `syntax-local-lift-module-begin-declaration` function. ;; (-> (Listof Syntax) (Listof Syntax)) -(define (lift-type-declarations form*) - (define (is-type-decl? form) - (syntax-parse form [_:type-declaration #t] [_ #f])) - (let*-values ([(type-decl* form*) (partition is-type-decl? form*)]) - (append type-decl* form*))) +(define (lift-type-out-declarations form*) + (define (is-type-out-decl? form) + (syntax-property form tr:type-out:type-annotation-property)) + (call-with-values (lambda () (partition is-type-out-decl? form*)) append)) ;; actually do the work on a module ;; produces prelude and post-lude syntax objects ;; syntax-list -> (values syntax syntax) (define (type-check forms0) - (define forms (lift-type-declarations (syntax->list forms0))) + (define forms (lift-type-out-declarations (syntax->list forms0))) (do-time "before form splitting") (define-values (type-aliases struct-defs stx-defs0 val-defs0 provs signature-defs) (filter-multiple diff --git a/typed-racket-test/fail/type-out-struct-bad-option.rkt b/typed-racket-test/fail/type-out-struct-bad-option.rkt new file mode 100644 index 000000000..a259544d6 --- /dev/null +++ b/typed-racket-test/fail/type-out-struct-bad-option.rkt @@ -0,0 +1,8 @@ +#lang racket/base + +;; #:omit-constructor is the only option + +(module struct-def typed/racket/base + (provide (type-out + (struct A ((a : String)) #:type-name Foo))) + (struct A ((a : String)) #:type-name Foo)) diff --git a/typed-racket-test/fail/type-out-struct-missing-def.rkt b/typed-racket-test/fail/type-out-struct-missing-def.rkt new file mode 100644 index 000000000..564697643 --- /dev/null +++ b/typed-racket-test/fail/type-out-struct-missing-def.rkt @@ -0,0 +1,7 @@ +#lang racket/base + +;; Must define the struct before providing it + +(module defstruct/type-name typed/racket/base + (provide + (type-out [struct bar ()]))) diff --git a/typed-racket-test/fail/type-out-struct-missing-parent-field.rkt b/typed-racket-test/fail/type-out-struct-missing-parent-field.rkt new file mode 100644 index 000000000..406d31ca7 --- /dev/null +++ b/typed-racket-test/fail/type-out-struct-missing-parent-field.rkt @@ -0,0 +1,10 @@ +#lang typed/racket/base + +;; Type-out structs need types for each field, including parent fields + +(provide (type-out + (struct bar ([x : Natural])) + (struct (baz bar) ([y : Boolean])))) + +(struct bar ([x : Natural])) +(struct baz bar ([y : Boolean])) diff --git a/typed-racket-test/succeed/type-out.rkt b/typed-racket-test/succeed/type-out.rkt index 980b67844..149cde9a7 100644 --- a/typed-racket-test/succeed/type-out.rkt +++ b/typed-racket-test/succeed/type-out.rkt @@ -48,77 +48,153 @@ (if (positive? n-1) (* n (fact n-1)) 1))) (require 'rename) +;; ----------------------------------------------------------------------------- +;; begin-for-syntax +;; Can 'type-out' at a different phase level + +(module bfs typed/racket/base + (require (for-syntax typed/racket/base)) + + (begin-for-syntax + (provide + (type-out (f (-> String Boolean)))) + (define (f s) + (= 8 (string-length s))))) +(require 'bfs) + ;; ----------------------------------------------------------------------------- ;; struct -;; basic struct definition -(module defstruct typed/racket/base +;; basic struct definitions, order of declarations does not matter +(module defstruct-1 typed/racket/base + (struct foo-1 ([a : Natural] [b : (-> Boolean String)])) (provide - (type-out - [struct foo ([a : Natural] [b : (-> Boolean String)])])) - (define f foo)) -(require 'defstruct) + (type-out [struct foo-1 ([a : Natural] [b : (-> Boolean String)])])) + (define f foo-1)) +(require 'defstruct-1) -;; compatible with struct #:type-name -;; (but not cooperative -- need to provide new name explicitly) -(module defstruct/type-name typed/racket/base +(module defstruct-2 typed/racket/base (provide - Bar - (type-out - [struct bar () #:type-name Bar]))) -(module defstruct/type-name-user typed/racket/base - (require (submod ".." defstruct/type-name)) - (: barry Bar) - (define barry (bar))) -(require 'defstruct/type-name-user) + (type-out [struct foo-2 ([a : Natural] [b : (-> Boolean String)])])) + (struct foo-2 ([a : Natural] [b : (-> Boolean String)])) + (define f foo-2)) +(require 'defstruct-2) ;; struct with parent (module struct/parent typed/racket/base (provide (type-out (struct bar ([x : Natural] [y : Boolean])) - (struct baz bar ([z : MyType])) - )) - (define-type MyType (-> Natural Boolean String))) + (struct (baz bar) ([x : Natural] [y : Boolean] [z : MyType])))) + (define-type MyType (-> Natural Boolean String)) + (struct bar ([x : Natural] [y : Boolean])) + (struct baz bar ([z : MyType]) #:property prop:procedure (struct-field-index z))) (require 'struct/parent) ;; struct, #:omit-constructor (module omit-constructor-1 typed/racket/base + (struct qux ([x : Natural] [y : Boolean])) (provide (type-out (struct qux ([x : Natural] [y : Boolean]) #:omit-constructor)))) (require 'omit-constructor-1) -;; can re-order #:omit-constructor relative to other options -(module omit-constructor-2 typed/racket/base - (provide (type-out - (struct quux () #:type-name Quux #:omit-constructor) - (struct quuux () #:omit-constructor #:type-name Quuux)))) -(require 'omit-constructor-2) +;; compatible with type-name +(module type-name typed/racket/base + (provide + (type-out (struct secret ([x : Key])))) + (define-type Key String) + (struct secret ([x : Key]) #:type-name SecretKey)) +(require 'type-name) + +;; compatible with polymorphic type-name? wait for issue #304 +;(module type-name-poly typed/racket/base +; (struct (A) secret-poly ([x : A]) #:type-name SecretPoly) +; (provide +; (type-out (struct (A) secret-poly ([x : A]))))) +;(require 'type-name-poly) + +;; more intense use of type variables +;(module type-var typed/racket/base +; (provide +; (type-out +; (struct (A B C) ski ([S : (-> (-> A B C) (-> A B) A C)] +; [K : (-> A B A)] +; [I : (-> A A)])))) +; (struct (A B C) ski ([S : (-> (-> A B C) (-> A B) A C)] +; [K : (-> A B A)] +; [I : (-> A A)]) +; #:type-name SKI +; #:extra-constructor-name make-SKI +; #:property prop:procedure +; (struct-field-index S))) +;(require 'type-var) ;; ----------------------------------------------------------------------------- -;; type - -(module deftype typed/racket/base - (provide (type-out - (type Person (Pairof String Natural)) - (person Person Person Boolean)))) - (define (person People People Boolean)) - (define (person oAutomaton Natural (values oAutomaton oAutomaton))] + [jump (-> State Payoff Void)] + [pay (-> Payoff)] + [reset (-> oAutomaton)] + [clone (-> oAutomaton)] + [equal (-> oAutomaton Boolean)])) + + (define automaton% + (let () + (class object% + (init-field + current + payoff + table + (original current)) + (super-new) + + (define/public (match-pair other r) + ;; Implementation omitted + (values this other)) + + (define/public (jump input delta) + (set! current (vector-ref (vector-ref table current) input)) + (set! payoff (+ payoff delta))) + + (define/public (pay) + payoff) + + (define/public (reset) + (new automaton% [current original][payoff 0][table table])) + + (define/public (clone) + (new automaton% [current original][payoff 0][table table])) + + (: compute-payoffs (-> State [cons Payoff Payoff])) + (define/private (compute-payoffs other-current) + (vector-ref (vector-ref #(#()) current) other-current)) + + (define/public (equal other) + (and (= current (get-field current other)) + (= original (get-field original other)) + (= payoff (get-field payoff other)) + (equal? table (get-field table other))))))) + + (define a (new automaton% (current 0) (payoff 999) (table '#(#(0 0) #(1 1))))) + + (provide (type-out + (automaton% Automaton) + (a oAutomaton)))) +(require 'class) ;; ----------------------------------------------------------------------------- ;; test compatibility with #:opaque types @@ -129,11 +205,12 @@ [#:opaque Str string?] [string-length (-> Str Natural)]) - (provide (type-out - (type MyTuple (Pairof String Natural)) - (a (-> MyTuple Boolean)))) + (provide + MyTuple + (type-out (and-cdr (-> MyTuple Boolean)))) + (define-type MyTuple (Pairof String Natural)) - (define (a x) + (define (and-cdr x) (and (cdr x) #t))) (require 'opaque-1) @@ -162,17 +239,19 @@ #t)) (require 'opaque-3) -;; ----------------------------------------------------------------------------- +;;; ----------------------------------------------------------------------------- ;; compatible with #:constructor-name (module constr-name-1 typed/racket/base (provide (type-out - (struct s () #:constructor-name makes))) - makes) + (struct s ()))) + (struct s () #:constructor-name makes) + (define f makes)) (require 'constr-name-1) (module constr-name-2 typed/racket/base (provide (type-out - (struct r () #:omit-constructor #:constructor-name maker))) - maker) + (struct r () #:omit-constructor))) + (struct r () #:constructor-name maker) + (define f maker)) (require 'constr-name-2) From ea4fb97a6147a838dd22b9297fa851f54bf4264e Mon Sep 17 00:00:00 2001 From: ben Date: Thu, 4 Feb 2016 03:39:14 -0500 Subject: [PATCH 3/7] checkpoint: consolidate tests --- .../fail/type-out-for-syntax.rkt | 14 - .../fail/type-out-omit-constructor-1.rkt | 11 - .../fail/type-out-omit-constructor-2.rkt | 7 - .../fail/type-out-omit-constructor-3.rkt | 7 - typed-racket-test/fail/type-out-rename.rkt | 15 - .../fail/type-out-struct-bad-option.rkt | 8 - .../fail/type-out-struct-missing-def.rkt | 7 - .../type-out-struct-missing-parent-field.rkt | 10 - typed-racket-test/succeed/type-out.rkt | 257 ----------- typed-racket-test/unit-tests/all-tests.rkt | 1 + .../unit-tests/type-out-tests.rkt | 411 ++++++++++++++++++ 11 files changed, 412 insertions(+), 336 deletions(-) delete mode 100644 typed-racket-test/fail/type-out-for-syntax.rkt delete mode 100644 typed-racket-test/fail/type-out-omit-constructor-1.rkt delete mode 100644 typed-racket-test/fail/type-out-omit-constructor-2.rkt delete mode 100644 typed-racket-test/fail/type-out-omit-constructor-3.rkt delete mode 100644 typed-racket-test/fail/type-out-rename.rkt delete mode 100644 typed-racket-test/fail/type-out-struct-bad-option.rkt delete mode 100644 typed-racket-test/fail/type-out-struct-missing-def.rkt delete mode 100644 typed-racket-test/fail/type-out-struct-missing-parent-field.rkt delete mode 100644 typed-racket-test/succeed/type-out.rkt create mode 100644 typed-racket-test/unit-tests/type-out-tests.rkt diff --git a/typed-racket-test/fail/type-out-for-syntax.rkt b/typed-racket-test/fail/type-out-for-syntax.rkt deleted file mode 100644 index 37f819841..000000000 --- a/typed-racket-test/fail/type-out-for-syntax.rkt +++ /dev/null @@ -1,14 +0,0 @@ -#lang racket/base - -;; type-out only works at phase 0, -;; because it inserts definitions at phase 0 -; in the enclosing module - -(module for-stx typed/racket/base - (require (for-syntax typed/racket/base)) - - (provide - (for-syntax (type-out [s (-> String String)]))) - - (define-for-syntax (s str) "")) -(require 'for-stx) diff --git a/typed-racket-test/fail/type-out-omit-constructor-1.rkt b/typed-racket-test/fail/type-out-omit-constructor-1.rkt deleted file mode 100644 index f2c0d8f45..000000000 --- a/typed-racket-test/fail/type-out-omit-constructor-1.rkt +++ /dev/null @@ -1,11 +0,0 @@ -#lang racket/base - -;; (type-out (struct ... #:omit-constructor)) -;; Makes the struct constructor invisible - -(module omit-constructor typed/racket/base - (provide - (type-out (struct foo () #:omit-constructor)))) - -(require 'omit-constructor) -foo diff --git a/typed-racket-test/fail/type-out-omit-constructor-2.rkt b/typed-racket-test/fail/type-out-omit-constructor-2.rkt deleted file mode 100644 index 925f719e3..000000000 --- a/typed-racket-test/fail/type-out-omit-constructor-2.rkt +++ /dev/null @@ -1,7 +0,0 @@ -#lang racket/base - -(module constr-name typed/racket/base - (provide (type-out - (struct s () #:constructor-name makes #:omit-constructor)))) -(require 'constr-name) -makes diff --git a/typed-racket-test/fail/type-out-omit-constructor-3.rkt b/typed-racket-test/fail/type-out-omit-constructor-3.rkt deleted file mode 100644 index 9dc1e1c4d..000000000 --- a/typed-racket-test/fail/type-out-omit-constructor-3.rkt +++ /dev/null @@ -1,7 +0,0 @@ -#lang racket/base - -(module constr-name typed/racket/base - (provide (type-out - (struct s () #:omit-constructor #:constructor-name makes)))) -(require 'constr-name) -makes diff --git a/typed-racket-test/fail/type-out-rename.rkt b/typed-racket-test/fail/type-out-rename.rkt deleted file mode 100644 index 89809f658..000000000 --- a/typed-racket-test/fail/type-out-rename.rkt +++ /dev/null @@ -1,15 +0,0 @@ -#lang racket/base - -;; (type-out (rename ...)) -;; Does not provide original identifier - -(module rename typed/racket/base - (provide - (type-out (rename f g (-> Natural Natural)))) - (define (f n) - (let ([n-1 (- n 1)]) - (if (positive? n-1) (* n (f n-1)) 1)))) - -(require 'rename) -(f 4) - diff --git a/typed-racket-test/fail/type-out-struct-bad-option.rkt b/typed-racket-test/fail/type-out-struct-bad-option.rkt deleted file mode 100644 index a259544d6..000000000 --- a/typed-racket-test/fail/type-out-struct-bad-option.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang racket/base - -;; #:omit-constructor is the only option - -(module struct-def typed/racket/base - (provide (type-out - (struct A ((a : String)) #:type-name Foo))) - (struct A ((a : String)) #:type-name Foo)) diff --git a/typed-racket-test/fail/type-out-struct-missing-def.rkt b/typed-racket-test/fail/type-out-struct-missing-def.rkt deleted file mode 100644 index 564697643..000000000 --- a/typed-racket-test/fail/type-out-struct-missing-def.rkt +++ /dev/null @@ -1,7 +0,0 @@ -#lang racket/base - -;; Must define the struct before providing it - -(module defstruct/type-name typed/racket/base - (provide - (type-out [struct bar ()]))) diff --git a/typed-racket-test/fail/type-out-struct-missing-parent-field.rkt b/typed-racket-test/fail/type-out-struct-missing-parent-field.rkt deleted file mode 100644 index 406d31ca7..000000000 --- a/typed-racket-test/fail/type-out-struct-missing-parent-field.rkt +++ /dev/null @@ -1,10 +0,0 @@ -#lang typed/racket/base - -;; Type-out structs need types for each field, including parent fields - -(provide (type-out - (struct bar ([x : Natural])) - (struct (baz bar) ([y : Boolean])))) - -(struct bar ([x : Natural])) -(struct baz bar ([y : Boolean])) diff --git a/typed-racket-test/succeed/type-out.rkt b/typed-racket-test/succeed/type-out.rkt deleted file mode 100644 index 149cde9a7..000000000 --- a/typed-racket-test/succeed/type-out.rkt +++ /dev/null @@ -1,257 +0,0 @@ -#lang racket/base - -;; Tests for type-out -;; - submodules test different type-out forms, these should all compile - -;; ----------------------------------------------------------------------------- -;; basics / rename - -;; type-out a single definition -(module single typed/racket/base - (provide - (type-out [f (-> Natural Natural)])) - - (define (f n) - (define n-1 (- n 1)) - (if (positive? n-1) (* n (f n-1)) 1))) -(require 'single) - -;; type-out multiple definitions, along with ordinary provides -(module multi typed/racket/base - (provide - (type-out [n Natural] - [fact (-> Natural Natural)]) - fib) - - (define n 12) - - (define (fact n) - (define n-1 (- n 1)) - (if (positive? n-1) (* n (fact n-1)) 1)) - - (: fib (-> Natural Natural)) - (define (fib n) - (define n-1 (- n 1)) - (define n-2 (- n 2)) - (if (and (positive? n-1) (positive? n-2)) - (+ (fib n-1) (fib n-2)) 1))) -(require 'multi) - -;; use rename form -(module rename typed/racket/base - (provide - (type-out - [rename fact g (-> Natural Natural)])) - - (define (fact n) - (define n-1 (- n 1)) - (if (positive? n-1) (* n (fact n-1)) 1))) -(require 'rename) - -;; ----------------------------------------------------------------------------- -;; begin-for-syntax -;; Can 'type-out' at a different phase level - -(module bfs typed/racket/base - (require (for-syntax typed/racket/base)) - - (begin-for-syntax - (provide - (type-out (f (-> String Boolean)))) - (define (f s) - (= 8 (string-length s))))) -(require 'bfs) - -;; ----------------------------------------------------------------------------- -;; struct - -;; basic struct definitions, order of declarations does not matter -(module defstruct-1 typed/racket/base - (struct foo-1 ([a : Natural] [b : (-> Boolean String)])) - (provide - (type-out [struct foo-1 ([a : Natural] [b : (-> Boolean String)])])) - (define f foo-1)) -(require 'defstruct-1) - -(module defstruct-2 typed/racket/base - (provide - (type-out [struct foo-2 ([a : Natural] [b : (-> Boolean String)])])) - (struct foo-2 ([a : Natural] [b : (-> Boolean String)])) - (define f foo-2)) -(require 'defstruct-2) - -;; struct with parent -(module struct/parent typed/racket/base - (provide (type-out - (struct bar ([x : Natural] [y : Boolean])) - (struct (baz bar) ([x : Natural] [y : Boolean] [z : MyType])))) - (define-type MyType (-> Natural Boolean String)) - (struct bar ([x : Natural] [y : Boolean])) - (struct baz bar ([z : MyType]) #:property prop:procedure (struct-field-index z))) -(require 'struct/parent) - -;; struct, #:omit-constructor -(module omit-constructor-1 typed/racket/base - (struct qux ([x : Natural] [y : Boolean])) - (provide (type-out - (struct qux ([x : Natural] [y : Boolean]) #:omit-constructor)))) -(require 'omit-constructor-1) - -;; compatible with type-name -(module type-name typed/racket/base - (provide - (type-out (struct secret ([x : Key])))) - (define-type Key String) - (struct secret ([x : Key]) #:type-name SecretKey)) -(require 'type-name) - -;; compatible with polymorphic type-name? wait for issue #304 -;(module type-name-poly typed/racket/base -; (struct (A) secret-poly ([x : A]) #:type-name SecretPoly) -; (provide -; (type-out (struct (A) secret-poly ([x : A]))))) -;(require 'type-name-poly) - -;; more intense use of type variables -;(module type-var typed/racket/base -; (provide -; (type-out -; (struct (A B C) ski ([S : (-> (-> A B C) (-> A B) A C)] -; [K : (-> A B A)] -; [I : (-> A A)])))) -; (struct (A B C) ski ([S : (-> (-> A B C) (-> A B) A C)] -; [K : (-> A B A)] -; [I : (-> A A)]) -; #:type-name SKI -; #:extra-constructor-name make-SKI -; #:property prop:procedure -; (struct-field-index S))) -;(require 'type-var) - -;; ----------------------------------------------------------------------------- -;; Example class - -(module class typed/racket/base - ;; Example OO code - (require typed/racket/class) - - (define-type State Natural) - (define-type Payoff Natural) - (define-type Transition* (Vectorof (Vectorof Payoff))) - (define-type oAutomaton (Instance Automaton)) - (define-type Automaton - (Class - (init-field [current State] - [payoff Payoff] - [table Transition*] - [original State #:optional]) - [match-pair (-> oAutomaton Natural (values oAutomaton oAutomaton))] - [jump (-> State Payoff Void)] - [pay (-> Payoff)] - [reset (-> oAutomaton)] - [clone (-> oAutomaton)] - [equal (-> oAutomaton Boolean)])) - - (define automaton% - (let () - (class object% - (init-field - current - payoff - table - (original current)) - (super-new) - - (define/public (match-pair other r) - ;; Implementation omitted - (values this other)) - - (define/public (jump input delta) - (set! current (vector-ref (vector-ref table current) input)) - (set! payoff (+ payoff delta))) - - (define/public (pay) - payoff) - - (define/public (reset) - (new automaton% [current original][payoff 0][table table])) - - (define/public (clone) - (new automaton% [current original][payoff 0][table table])) - - (: compute-payoffs (-> State [cons Payoff Payoff])) - (define/private (compute-payoffs other-current) - (vector-ref (vector-ref #(#()) current) other-current)) - - (define/public (equal other) - (and (= current (get-field current other)) - (= original (get-field original other)) - (= payoff (get-field payoff other)) - (equal? table (get-field table other))))))) - - (define a (new automaton% (current 0) (payoff 999) (table '#(#(0 0) #(1 1))))) - - (provide (type-out - (automaton% Automaton) - (a oAutomaton)))) -(require 'class) - -;; ----------------------------------------------------------------------------- -;; test compatibility with #:opaque types -;; (to check if reordering type declarations breaks things) - -(module opaque-1 typed/racket/base - (require/typed racket/base - [#:opaque Str string?] - [string-length (-> Str Natural)]) - - (provide - MyTuple - (type-out (and-cdr (-> MyTuple Boolean)))) - (define-type MyTuple (Pairof String Natural)) - - (define (and-cdr x) - (and (cdr x) #t))) -(require 'opaque-1) - -(module opaque-2 typed/racket/base - (define-type MyTuple (Pairof Str Boolean)) - - (require/typed racket/base - [#:opaque Str string?] - [string-length (-> Str Natural)]) - - (define (b x) - #t)) -(require 'opaque-2) - -(module opaque-3 typed/racket/base - (define-type Foobar (-> Pict)) - - (require/typed pict - [#:opaque Pict pict?] - [blank (-> Real Real Pict)]) - - (provide (type-out - (c (-> Pict Boolean)))) - - (define (c x) - #t)) -(require 'opaque-3) - -;;; ----------------------------------------------------------------------------- -;; compatible with #:constructor-name - -(module constr-name-1 typed/racket/base - (provide (type-out - (struct s ()))) - (struct s () #:constructor-name makes) - (define f makes)) -(require 'constr-name-1) - -(module constr-name-2 typed/racket/base - (provide (type-out - (struct r () #:omit-constructor))) - (struct r () #:constructor-name maker) - (define f maker)) -(require 'constr-name-2) diff --git a/typed-racket-test/unit-tests/all-tests.rkt b/typed-racket-test/unit-tests/all-tests.rkt index 1ff12e20f..bf29e66de 100644 --- a/typed-racket-test/unit-tests/all-tests.rkt +++ b/typed-racket-test/unit-tests/all-tests.rkt @@ -44,4 +44,5 @@ "prims-tests.rkt" "tooltip-tests.rkt" "prefab-tests.rkt" + "type-out-tests.rkt" "typed-units-tests.rkt") diff --git a/typed-racket-test/unit-tests/type-out-tests.rkt b/typed-racket-test/unit-tests/type-out-tests.rkt new file mode 100644 index 000000000..4f364b91f --- /dev/null +++ b/typed-racket-test/unit-tests/type-out-tests.rkt @@ -0,0 +1,411 @@ +#lang racket/base + +;; Tests for type-out +;; - submodules test different type-out forms, these should all compile + +;; ------------------------------------------------------------------------------------------------------ +;; utilities + +(define (eval/pass e) + (eval e (make-base-namespace))) + +;; TODO not catching syntax errors +(define (eval/fail exn-regexp e) + (define (check-exn e) + (if (regexp-match? exn-regexp (exn-message e)) #t (raise e))) + (unless (with-handlers ([exn? check-exn]) + (begin (eval e (make-base-namespace)) #f)) + (error 'type-out-tests "expression did not raise an exception"))) + +;; ------------------------------------------------------------------------------------------------------ +;; basics / rename + +;; type-out a single definition +(eval/pass + '(begin + (module single typed/racket/base + (provide + (type-out [f (-> Natural Natural)])) + (define (f n) + (define n-1 (- n 1)) + (if (positive? n-1) (* n (f n-1)) 1))) + (require 'single))) + +;; type-out multiple definitions, along with ordinary provides +(eval/pass + '(begin + (module multi typed/racket/base + (provide + (type-out [n Natural] + [fact (-> Natural Natural)]) + fib) + + (define n 12) + + (define (fact n) + (define n-1 (- n 1)) + (if (positive? n-1) (* n (fact n-1)) 1)) + + (: fib (-> Natural Natural)) + (define (fib n) + (define n-1 (- n 1)) + (define n-2 (- n 2)) + (if (and (positive? n-1) (positive? n-2)) + (+ (fib n-1) (fib n-2)) 1))) + (require 'multi))) + +;; use rename form +(eval/pass + '(begin + (module rename typed/racket/base + (provide + (type-out + [rename fact g (-> Natural Natural)])) + + (define (fact n) + (define n-1 (- n 1)) + (if (positive? n-1) (* n (fact n-1)) 1))) + (require 'rename))) + +;; (type-out (rename ...)) +;; Does not provide original identifier +(eval/fail "f: unbound identifier" + '(begin + (module rename typed/racket/base + (provide + (type-out (rename f g (-> Natural Natural)))) + (define (f n) + (let ([n-1 (- n 1)]) + (if (positive? n-1) (* n (f n-1)) 1)))) + (require 'rename) + (f 4))) + +;; ------------------------------------------------------------------------------------------------------ +;; begin-for-syntax +;; Can 'type-out' at a different phase level, as long as it's the same phase as the provide + +(eval/pass + '(begin + (module bfs typed/racket/base + (require (for-syntax typed/racket/base)) + + (begin-for-syntax + (provide + (type-out (f (-> String Boolean)))) + (define (f s) + (= 8 (string-length s))))) + (require 'bfs))) + +;; Cannot type-out at a different phase from the provide +(eval/fail "foobear" + '(begin + (module for-stx typed/racket/base + (require (for-syntax typed/racket/base)) + + (provide + (for-syntax (type-out [s (-> String String)]))) + + (define-for-syntax (s str) "")) + (require 'for-stx))) + +;; ------------------------------------------------------------------------------------------------------ +;; struct + +;; basic struct definitions, order of declarations does not matter +(eval/pass + '(begin + (module defstruct-1 typed/racket/base + (struct foo-1 ([a : Natural] [b : (-> Boolean String)])) + (provide + (type-out [struct foo-1 ([a : Natural] [b : (-> Boolean String)])])) + (define f foo-1)) + (require 'defstruct-1))) + +(eval/pass + '(begin + (module defstruct-2 typed/racket/base + (provide + (type-out [struct foo-2 ([a : Natural] [b : (-> Boolean String)])])) + (struct foo-2 ([a : Natural] [b : (-> Boolean String)])) + (define f foo-2)) + (require 'defstruct-2))) + +;; struct with parent +(eval/pass + '(begin + (module struct/parent typed/racket/base + (provide (type-out + (struct bar ([x : Natural] [y : Boolean])) + (struct (baz bar) ([x : Natural] [y : Boolean] [z : MyType])))) + (define-type MyType (-> Natural Boolean String)) + (struct bar ([x : Natural] [y : Boolean])) + (struct baz bar ([z : MyType]) #:property prop:procedure (struct-field-index z))) + (require 'struct/parent))) + +;; struct, #:omit-constructor +(eval/pass + '(begin + (module omit-constructor-1 typed/racket/base + (struct qux ([x : Natural] [y : Boolean])) + (provide (type-out + (struct qux ([x : Natural] [y : Boolean]) #:omit-constructor)))) + (require 'omit-constructor-1))) + +;; #:omit-constructor should hide #:constructor-name constructors +(eval/fail "TODO" + '(begin + (module constr-name typed/racket/base + (struct s () #:constructor-name makes) + (provide (type-out + (struct s () #:omit-constructor)))) + (require 'constr-name) + makes)) + +;; compatible with type-name +(eval/pass + '(begin + (module type-name typed/racket/base + (provide + (type-out (struct secret ([x : Key])))) + (define-type Key String) + (struct secret ([x : Key]) #:type-name SecretKey)) + (require 'type-name))) + +;; Must define the struct before providing it +(eval/fail "TODO" + '(begin + (module defstruct/type-name typed/racket/base + (provide + (type-out [struct bar ()]))))) + +;; Test incorrect field type +(eval/fail "TODO" + '(begin + (module s typed/racket/base + (provide + (type-out (struct s ([f : Boolean])))) + (struct s ([f : (-> Boolean String)]))) + (require 's))) + +;; Must declare all struct fields +(eval/fail "TODO" + '(begin + (module s typed/racket/base + (provide + (type-out (struct s ()))) + (struct s ([f : (-> Boolean String)]))) + (require 's) + (define my-s (s (lambda (x) "hi"))) + ((s-f my-s) #t))) + +;; Type-out structs need types for each field, including parent fields +(eval/fail "TODO" + '(begin + (module t typed/racket/base + (provide (type-out + (struct bar ([x : Natural])) + (struct (baz bar) ([y : Boolean])))) + (struct bar ([x : Natural])) + (struct baz bar ([y : Boolean]))))) + +;; type-out should not declare extra fields +(eval/fail "TODO" + '(begin + (module s typed/racket/base + (provide + (type-out (struct s ([f : (-> Boolean String)] + [g : Natural])))) + (struct s ([f : (-> Boolean String)]))) + (require 's))) + +;; Can only use '#:omit-constructor' in `type-out` +(eval/fail "TODO" + '(begin + (module struct-def typed/racket/base + (provide (type-out + (struct A ((a : String)) #:type-name Foo))) + (struct A ((a : String)) #:type-name Foo)))) + +;; fail: can't use omitted name outside module +(eval/fail "foo: unbound identifier" + '(begin + (module omit-constructor typed/racket/base + (struct foo ()) + (provide + (type-out (struct foo () #:omit-constructor)))) + + (require 'omit-constructor) + foo)) + +;; Type name should not be a constructor if #:constructor-name is used +(eval/fail "s: unbound identifier" + '(begin + (module constr-name typed/racket/base + (struct s () #:constructor-name makes) + (provide (type-out + (struct s () #:omit-constructor)))) + (require 'constr-name) + (define my-s (s)))) + +;; compatible with polymorphic type-name? wait for issue #304 +;(module type-name-poly typed/racket/base +; (struct (A) secret-poly ([x : A]) #:type-name SecretPoly) +; (provide +; (type-out (struct (A) secret-poly ([x : A]))))) +;(require 'type-name-poly) + +;; more intense use of type variables +;(module type-var typed/racket/base +; (provide +; (type-out +; (struct (A B C) ski ([S : (-> (-> A B C) (-> A B) A C)] +; [K : (-> A B A)] +; [I : (-> A A)])))) +; (struct (A B C) ski ([S : (-> (-> A B C) (-> A B) A C)] +; [K : (-> A B A)] +; [I : (-> A A)]) +; #:type-name SKI +; #:extra-constructor-name make-SKI +; #:property prop:procedure +; (struct-field-index S))) +;(require 'type-var) + +;; ------------------------------------------------------------------------------------------------------ +;; Example class + +(eval/pass + '(begin + (module class typed/racket/base + ;; Example OO code + (require typed/racket/class) + + (define-type State Natural) + (define-type Payoff Natural) + (define-type Transition* (Vectorof (Vectorof Payoff))) + (define-type oAutomaton (Instance Automaton)) + (define-type Automaton + (Class + (init-field [current State] + [payoff Payoff] + [table Transition*] + [original State #:optional]) + [match-pair (-> oAutomaton Natural (values oAutomaton oAutomaton))] + [jump (-> State Payoff Void)] + [pay (-> Payoff)] + [reset (-> oAutomaton)] + [clone (-> oAutomaton)] + [equal (-> oAutomaton Boolean)])) + + (define automaton% + (let () + (class object% + (init-field + current + payoff + table + (original current)) + (super-new) + + (define/public (match-pair other r) + ;; Implementation omitted + (values this other)) + + (define/public (jump input delta) + (set! current (vector-ref (vector-ref table current) input)) + (set! payoff (+ payoff delta))) + + (define/public (pay) + payoff) + + (define/public (reset) + (new automaton% [current original][payoff 0][table table])) + + (define/public (clone) + (new automaton% [current original][payoff 0][table table])) + + (: compute-payoffs (-> State [cons Payoff Payoff])) + (define/private (compute-payoffs other-current) + (vector-ref (vector-ref #(#()) current) other-current)) + + (define/public (equal other) + (and (= current (get-field current other)) + (= original (get-field original other)) + (= payoff (get-field payoff other)) + (equal? table (get-field table other))))))) + + (define a (new automaton% (current 0) (payoff 999) (table '#(#(0 0) #(1 1))))) + + (provide (type-out + (automaton% Automaton) + (a oAutomaton)))) + (require 'class))) + +;; ------------------------------------------------------------------------------------------------------ +;; test compatibility with #:opaque types +;; (to check if reordering type declarations breaks things) + +(eval/pass + '(begin + (module opaque-1 typed/racket/base + (require/typed racket/base + [#:opaque Str string?] + [string-length (-> Str Natural)]) + + (provide + MyTuple + (type-out (and-cdr (-> MyTuple Boolean)))) + (define-type MyTuple (Pairof String Natural)) + + (define (and-cdr x) + (and (cdr x) #t))) + (require 'opaque-1))) + +(eval/pass + '(begin + (module opaque-2 typed/racket/base + (define-type MyTuple (Pairof Str Boolean)) + + (require/typed racket/base + [#:opaque Str string?] + [string-length (-> Str Natural)]) + + (define (b x) + #t)) + (require 'opaque-2))) + +(eval/pass + '(begin + (module opaque-3 typed/racket/base + (define-type Foobar (-> Pict)) + + (require/typed pict + [#:opaque Pict pict?] + [blank (-> Real Real Pict)]) + + (provide (type-out + (c (-> Pict Boolean)))) + + (define (c x) + #t)) + (require 'opaque-3))) + +;; ------------------------------------------------------------------------------------------------------ +;; compatible with #:constructor-name + +(eval/pass + '(begin + (module constr-name-1 typed/racket/base + (provide (type-out + (struct s ()))) + (struct s () #:constructor-name makes) + (define f makes)) + (require 'constr-name-1))) + +(eval/pass + '(begin + (module constr-name-2 typed/racket/base + (provide (type-out + (struct r () #:omit-constructor))) + (struct r () #:constructor-name maker) + (define f maker)) + (require 'constr-name-2))) From cd973676559f828a1490128ebb09ec470f257059 Mon Sep 17 00:00:00 2001 From: ben Date: Sun, 14 Feb 2016 01:58:23 -0500 Subject: [PATCH 4/7] type-out: enforce/check struct annotations --- .../typed-racket/base-env/prims.rkt | 106 ++++-- .../unit-tests/type-out-tests.rkt | 303 ++++++++++++------ 2 files changed, 294 insertions(+), 115 deletions(-) diff --git a/typed-racket-lib/typed-racket/base-env/prims.rkt b/typed-racket-lib/typed-racket/base-env/prims.rkt index 3436fce01..ab5c98f4d 100644 --- a/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -125,12 +125,16 @@ the typed racket language. (for-syntax racket/lazy-require syntax/parse/pre + racket/struct-info syntax/stx racket/list racket/provide-transform racket/syntax racket/base + (only-in racket/string string-split) + (only-in "../typecheck/tc-structs.rkt" name-of-struct) (only-in "../typecheck/internal-forms.rkt" internal) + (only-in "../typecheck/find-annotation.rkt" find-annotation) "annotate-classes.rkt" "../utils/literal-syntax-class.rkt" "../private/parse-classes.rkt" @@ -644,27 +648,93 @@ the typed racket language. #:attributes (type-decl* provide-spec*) #:datum-literals (rename struct type :) ;; 2016-02-03 'type' is unused for now (pattern [n:id t] - #:attr type-decl* (syntax/loc stx ((: n t))) - #:attr provide-spec* (syntax/loc stx (n))) + #:attr type-decl* (syntax/loc stx (: n t)) + #:attr provide-spec* (syntax/loc stx n)) (pattern [rename old-n:id new-n:id t] - #:attr type-decl* (syntax/loc stx ((: old-n t))) - #:attr provide-spec* (syntax/loc stx ((rename-out (old-n new-n))))) + #:attr type-decl* (syntax/loc stx (: old-n t)) + #:attr provide-spec* (syntax/loc stx (rename-out (old-n new-n)))) (pattern [struct (~optional (~seq (v*:id ...))) - (~or n:id (n:id parent:id)) + (~or n:id (n:id parent:id) (~seq n:id parent:id)) ((f*:id : t*) ...) (~optional (~and #:omit-constructor omit?))] #:attr type-decl* - (syntax/loc stx - ((let () - ;; TODO - ;; 1. If parent given, check that struct is supertype of parent - ;; 2. Check all field types - (void)))) + ;; Make type annotations for each struct field accessor + ;; Also: + ;; - check that supertype information is correct + ;; - check that all struct fields have an annotation (including super fields) + (let ([struct-info (syntax-local-value #'n (lambda () #f))]) + (if (not struct-info) + (raise-syntax-error + 'type-out + "unknown struct type. (Make sure struct definitions come before their use in a type-out form)" + stx + (syntax-e #'n)) + (let*-values ([(_struct-type constr n? n-acc* _mut* super) + (apply values (extract-struct-info struct-info))] + [(acc*) + ;; Recursively collect all known struct fields / parent fields + (let loop ([acc* n-acc*] + [super super]) + (define-values (acc-prefix* acc-last) + (let loop ([acc* acc*] + [pre* '()]) + (cond + [(null? acc*) (values '() #t)] + [(null? (cdr acc*)) (values pre* (car acc*))] + [else (loop (cdr acc*) (cons (car acc*) pre*))]))) + (if acc-last + ;; then: list is reliable indicator of fields + acc* + ;; else: look for fields in supertype + (case super + [(#t) ;; No supertype + (error 'type-out "Internal Error: list of fields ~a is not exact, but struct has no supertype." acc*)] + [(#f) ;; Unknown supertype + (raise-syntax-error 'type-out (format "cannot determine field information for struct type '~a' (use struct-out instead)" (syntax-e #'n)) stx)] + [else ;; Recurse with parent struct-type-info + (define info (extract-struct-info (syntax-local-value super))) + (append acc-prefix* + (loop (cadddr info) (last info)))])))]) + ;; check parent, if given + (when (and (attribute parent) + (or (boolean? super) (not (free-identifier=? super #'parent)))) + (raise-syntax-error + 'type-out + (format "struct type ~a is not a subtype of ~a" (syntax-e #'n) (syntax-e #'parent)) + stx)) + ;; match known accessors with field information + (let* ([f+t* (sort (map syntax-e (syntax->list #'((f* . t*) ...))) + symbolstring (syntax-e acc)) "-")))) + (define f+t + (if (null? f+t*) + #f + (begin0 (car f+t*) (set! f+t* (cdr f+t*))))) + (unless (and f+t (free-identifier=? acc-id (car f+t))) + (raise-syntax-error 'type-out "missing annotation for struct field" stx (syntax-e acc-id))) + (quasisyntax/loc stx (ann #,acc (-> n #,(cdr f+t)))))]) + (unless (null? f+t*) + (raise-syntax-error 'type-out "struct field does not exist" stx (map (lambda (f+t) (syntax-e (car f+t))) f+t*))) + (quasisyntax/loc stx (let () #,@acc+type* (void))))))) #:attr provide-spec* - ;; TODO `n` is not always the constructor name. See `contract-out` for help. (if (attribute omit?) - (syntax/loc stx ((except-out (struct-out n) n))) - (syntax/loc stx ((struct-out n))))))) + (with-syntax ([constr (cadr (extract-struct-info (syntax-local-value #'n)))]) + (if (free-identifier=? #'constr #'n) + ;; Type is only constructor + (syntax/loc stx (except-out (struct-out n) constr)) + ;; We have 2 constructors (can't tell when struct name is not a constructor) + (syntax/loc stx (except-out (struct-out n) n constr)))) + (syntax/loc stx (struct-out n)))))) (define-syntax provide-typed-vars (make-provide-transformer @@ -679,14 +749,14 @@ the typed racket language. (syntax-parse stx [(_ (~var e* (type-out-spec stx)) ...) ;; Move type declarations to the toplevel - (with-syntax ([((t** ...) ...) #'(e*.type-decl* ...)]) + (with-syntax ([(t* ...) #'(e*.type-decl* ...)]) (syntax-local-lift-module-end-declaration (syntax-property ;; Mark, so we can lift to beginning of module later - (quasisyntax/loc stx (begin t** ... ...)) + (quasisyntax/loc stx (begin t* ...)) tr:type-out:type-annotation-property #t))) ;; Collect a flat list of provide specs & expand - (with-syntax ([((spec** ...) ...) #'(e*.provide-spec* ...)]) - (syntax/loc stx (provide-typed-vars spec** ... ...)))])))) + (with-syntax ([(spec* ...) #'(e*.provide-spec* ...)]) + (syntax/loc stx (provide-typed-vars spec* ...)))])))) (define-syntax (declare-refinement stx) (syntax-parse stx diff --git a/typed-racket-test/unit-tests/type-out-tests.rkt b/typed-racket-test/unit-tests/type-out-tests.rkt index 4f364b91f..06047e15c 100644 --- a/typed-racket-test/unit-tests/type-out-tests.rkt +++ b/typed-racket-test/unit-tests/type-out-tests.rkt @@ -1,21 +1,26 @@ #lang racket/base -;; Tests for type-out -;; - submodules test different type-out forms, these should all compile +;; Tests for type-out. +;; Each test is written as some Racket symbols to be eval'd in a fresh namespace. +;; Use `eval/pass DATA` and `eval/fail rx DATA` to test ;; ------------------------------------------------------------------------------------------------------ ;; utilities (define (eval/pass e) - (eval e (make-base-namespace))) + (begin (eval e (make-base-namespace)) (void))) -;; TODO not catching syntax errors (define (eval/fail exn-regexp e) (define (check-exn e) - (if (regexp-match? exn-regexp (exn-message e)) #t (raise e))) + (define msg (exn-message e)) + (if (regexp-match? exn-regexp msg) + #t + (error 'type-out-test + (format "Test raised exception with message '~e', but expected message matching '~a'" + msg exn-regexp)))) (unless (with-handlers ([exn? check-exn]) (begin (eval e (make-base-namespace)) #f)) - (error 'type-out-tests "expression did not raise an exception"))) + (error 'type-out-tests "No exception raised in ~a" e))) ;; ------------------------------------------------------------------------------------------------------ ;; basics / rename @@ -69,7 +74,7 @@ ;; (type-out (rename ...)) ;; Does not provide original identifier -(eval/fail "f: unbound identifier" +(eval/fail "f: undefined" '(begin (module rename typed/racket/base (provide @@ -80,6 +85,29 @@ (require 'rename) (f 4))) +;; Type mismatch +(eval/fail "Type Checker" + '(begin + (module bad-type-1 typed/racket/base + (provide + (type-out (n String))) + (define n 3)))) + +(eval/fail "Type Checker" + '(begin + (module bad-type-2 typed/racket/base + (provide + (type-out (n Natural))) + (define n -3)))) + +;; Arity mismatch +(eval/fail "Type Checker" + '(begin + (module bad-arity typed/racket/base + (provide + (type-out (f (-> Natural Natural)))) + (define (f x y) y)))) + ;; ------------------------------------------------------------------------------------------------------ ;; begin-for-syntax ;; Can 'type-out' at a different phase level, as long as it's the same phase as the provide @@ -97,7 +125,7 @@ (require 'bfs))) ;; Cannot type-out at a different phase from the provide -(eval/fail "foobear" +(eval/fail "Type Checker.*`s' has no definition" '(begin (module for-stx typed/racket/base (require (for-syntax typed/racket/base)) @@ -124,35 +152,61 @@ (eval/pass '(begin (module defstruct-2 typed/racket/base + (struct foo-2 ([a : Natural] [b : (-> Boolean String)])) (provide (type-out [struct foo-2 ([a : Natural] [b : (-> Boolean String)])])) - (struct foo-2 ([a : Natural] [b : (-> Boolean String)])) (define f foo-2)) - (require 'defstruct-2))) + (require 'defstruct-2) + foo-2? + foo-2-a)) -;; struct with parent +;; struct with parent, provide both struct & parent (eval/pass '(begin (module struct/parent typed/racket/base + (struct bar ([x : Natural] [y : Boolean])) + (struct baz bar ([z : MyType]) #:property prop:procedure (struct-field-index z)) (provide (type-out (struct bar ([x : Natural] [y : Boolean])) (struct (baz bar) ([x : Natural] [y : Boolean] [z : MyType])))) - (define-type MyType (-> Natural Boolean String)) + (define-type MyType (-> Natural Boolean String))) + (require 'struct/parent) + bar? baz?)) + +;; struct with parent, struct only +(eval/pass + '(begin + (module struct/parent typed/racket/base (struct bar ([x : Natural] [y : Boolean])) - (struct baz bar ([z : MyType]) #:property prop:procedure (struct-field-index z))) - (require 'struct/parent))) + (struct baz bar ([z : MyType]) #:property prop:procedure (struct-field-index z)) + (provide (type-out + (struct (baz bar) ([x : Natural] [y : Boolean] [z : MyType])))) + (define-type MyType (-> Natural Boolean String))) + (require 'struct/parent) + baz?)) -;; struct, #:omit-constructor +;; Check provides after an #:omit-constructor (eval/pass '(begin (module omit-constructor-1 typed/racket/base (struct qux ([x : Natural] [y : Boolean])) (provide (type-out (struct qux ([x : Natural] [y : Boolean]) #:omit-constructor)))) - (require 'omit-constructor-1))) + (require 'omit-constructor-1) + qux?)) -;; #:omit-constructor should hide #:constructor-name constructors -(eval/fail "TODO" +;; #:omit-constructor +(eval/fail "qux: undefined" + '(begin + (module omit-constructor-1 typed/racket/base + (struct qux ([x : Natural] [y : Boolean])) + (provide (type-out + (struct qux ([x : Natural] [y : Boolean]) #:omit-constructor)))) + (require 'omit-constructor-1) + (qux 0 #t))) + +;; #:omit-constructor should hide #:constructor-name constructors as well +(eval/fail "makes: undefined" '(begin (module constr-name typed/racket/base (struct s () #:constructor-name makes) @@ -161,114 +215,110 @@ (require 'constr-name) makes)) -;; compatible with type-name -(eval/pass +;; #:omit-constructor should hide #:extra-constructor-name too +(eval/fail "makes: undefined" + '(begin + (module constr-name typed/racket/base + (struct s () #:extra-constructor-name makes) + (provide (type-out + (struct s () #:omit-constructor)))) + (require 'constr-name) + makes)) + +;; #:extra-constructor-name also hides default constructor +(eval/fail "s: undefined" + '(begin + (module constr-name typed/racket/base + (struct s () #:extra-constructor-name makes) + (provide (type-out + (struct s () #:omit-constructor)))) + (require 'constr-name) + (s))) + +;; Must define the struct before providing it +(eval/fail "type-out: unknown struct type" '(begin - (module type-name typed/racket/base + (module defstruct/type-name typed/racket/base (provide - (type-out (struct secret ([x : Key])))) - (define-type Key String) - (struct secret ([x : Key]) #:type-name SecretKey)) - (require 'type-name))) + (type-out [struct bar ()]))))) ;; Must define the struct before providing it -(eval/fail "TODO" +(eval/fail "type-out: unknown struct type" '(begin (module defstruct/type-name typed/racket/base + (define bar 1) (provide (type-out [struct bar ()]))))) ;; Test incorrect field type -(eval/fail "TODO" +(eval/fail "Type Checker" '(begin (module s typed/racket/base + (struct s ([f : (-> Boolean String)])) (provide - (type-out (struct s ([f : Boolean])))) - (struct s ([f : (-> Boolean String)]))) + (type-out (struct s ([f : Boolean]))))) (require 's))) ;; Must declare all struct fields -(eval/fail "TODO" +(eval/fail "type-out: missing annotation" '(begin (module s typed/racket/base + (struct s ([f : (-> Boolean String)])) (provide - (type-out (struct s ()))) - (struct s ([f : (-> Boolean String)]))) + (type-out (struct s ())))) (require 's) (define my-s (s (lambda (x) "hi"))) ((s-f my-s) #t))) -;; Type-out structs need types for each field, including parent fields -(eval/fail "TODO" +;; Must declare all struct fields, including parent fields +(eval/fail "type-out: missing annotation" + '(begin + (module t typed/racket/base + (struct bar ([x : Natural])) + (struct baz bar ([y : Boolean])) + (provide (type-out + (struct bar ([x : Natural])) + (struct (baz bar) ([y : Boolean]))))))) + +;; Must declare all struct fields, including parent fields and grandparent fields +(eval/fail "type-out: missing annotation" '(begin (module t typed/racket/base + (struct bar ([x : Natural])) + (struct baz bar ([y : Boolean])) + (struct qux baz ([z : String])) (provide (type-out (struct bar ([x : Natural])) - (struct (baz bar) ([y : Boolean])))) + (struct (baz bar) ([y : Boolean] [x : Natural])) + (struct (qux baz) ([z : String] [y : Boolean]))))))) + +;; Must really be a sub-struct of parent +(eval/fail "type-out: struct type baz is not a subtype" + '(begin + (module t typed/racket/base (struct bar ([x : Natural])) - (struct baz bar ([y : Boolean]))))) + (struct baz ([y : Boolean])) + (provide (type-out + (struct bar ([x : Natural])) + (struct (baz bar) ([y : Boolean]))))))) ;; type-out should not declare extra fields -(eval/fail "TODO" +(eval/fail "type-out: struct field does not exist" '(begin (module s typed/racket/base - (provide - (type-out (struct s ([f : (-> Boolean String)] - [g : Natural])))) - (struct s ([f : (-> Boolean String)]))) + (struct s ([f : (-> Boolean String)])) + (provide + (type-out (struct s ([f : (-> Boolean String)] + [g : Natural]))))) (require 's))) -;; Can only use '#:omit-constructor' in `type-out` -(eval/fail "TODO" +;; Test bad struct option in type-out +(eval/fail "type-out: expected the literal" '(begin (module struct-def typed/racket/base + (struct A ((a : String)) #:type-name Foo) (provide (type-out - (struct A ((a : String)) #:type-name Foo))) - (struct A ((a : String)) #:type-name Foo)))) - -;; fail: can't use omitted name outside module -(eval/fail "foo: unbound identifier" - '(begin - (module omit-constructor typed/racket/base - (struct foo ()) - (provide - (type-out (struct foo () #:omit-constructor)))) - - (require 'omit-constructor) - foo)) - -;; Type name should not be a constructor if #:constructor-name is used -(eval/fail "s: unbound identifier" - '(begin - (module constr-name typed/racket/base - (struct s () #:constructor-name makes) - (provide (type-out - (struct s () #:omit-constructor)))) - (require 'constr-name) - (define my-s (s)))) - -;; compatible with polymorphic type-name? wait for issue #304 -;(module type-name-poly typed/racket/base -; (struct (A) secret-poly ([x : A]) #:type-name SecretPoly) -; (provide -; (type-out (struct (A) secret-poly ([x : A]))))) -;(require 'type-name-poly) - -;; more intense use of type variables -;(module type-var typed/racket/base -; (provide -; (type-out -; (struct (A B C) ski ([S : (-> (-> A B C) (-> A B) A C)] -; [K : (-> A B A)] -; [I : (-> A A)])))) -; (struct (A B C) ski ([S : (-> (-> A B C) (-> A B) A C)] -; [K : (-> A B A)] -; [I : (-> A A)]) -; #:type-name SKI -; #:extra-constructor-name make-SKI -; #:property prop:procedure -; (struct-field-index S))) -;(require 'type-var) + (struct A ((a : String)) #:type-name Foo)))))) ;; ------------------------------------------------------------------------------------------------------ ;; Example class @@ -276,6 +326,10 @@ (eval/pass '(begin (module class typed/racket/base + (provide (type-out + (automaton% Automaton) + (a oAutomaton))) + ;; Example OO code (require typed/racket/class) @@ -333,11 +387,7 @@ (= payoff (get-field payoff other)) (equal? table (get-field table other))))))) - (define a (new automaton% (current 0) (payoff 999) (table '#(#(0 0) #(1 1))))) - - (provide (type-out - (automaton% Automaton) - (a oAutomaton)))) + (define a (new automaton% (current 0) (payoff 999) (table '#(#(0 0) #(1 1)))))) (require 'class))) ;; ------------------------------------------------------------------------------------------------------ @@ -395,17 +445,76 @@ (eval/pass '(begin (module constr-name-1 typed/racket/base + (struct s () #:constructor-name makes) (provide (type-out (struct s ()))) - (struct s () #:constructor-name makes) (define f makes)) - (require 'constr-name-1))) + (require 'constr-name-1) + (s? (makes)))) (eval/pass '(begin (module constr-name-2 typed/racket/base + (struct r () #:constructor-name maker) (provide (type-out (struct r () #:omit-constructor))) + (define f maker)) + (require 'constr-name-2) + r?)) + +(eval/fail "maker: undefined" + '(begin + (module constr-name-2 typed/racket/base (struct r () #:constructor-name maker) + (provide (type-out + (struct r () #:omit-constructor))) (define f maker)) - (require 'constr-name-2))) + (require 'constr-name-2) + (maker))) + +;; ----------------------------------------------------------------------------- +;; TODO these tests are known to fail + +;; compatible with type-name +;(eval/pass +; '(begin +; (module type-name typed/racket/base +; (struct secret ([x : Key]) #:type-name SecretKey) +; (define-type Key String) +; (provide +; (type-out (struct secret ([x : Key]))))) +; (require 'type-name))) + +;; blocked on https://github.com/racket/typed-racket/issues/312 +;(eval/fail "identifier for static struct type information cannot be used as an expression" +; '(begin +; (module constr-name-1 typed/racket/base +; (struct s () #:constructor-name makes) +; (provide (type-out +; (struct s ()))) +; (define f (makes))) +; (require 'constr-name-1) +; (s))) + +;; blocked on https://github.com/racket/typed-racket/issues/304 +; ; compatible with polymorphic type-name? +; (module type-name-poly typed/racket/base +; (struct (A) secret-poly ([x : A]) #:type-name SecretPoly) +; (provide +; (type-out (struct (A) secret-poly ([x : A]))))) +; (require 'type-name-poly) +; ; more intense use of type variables +; (module type-var typed/racket/base +; (provide +; (type-out +; (struct (A B C) ski ([S : (-> (-> A B C) (-> A B) A C)] +; [K : (-> A B A)] +; [I : (-> A A)])))) +; (struct (A B C) ski ([S : (-> (-> A B C) (-> A B) A C)] +; [K : (-> A B A)] +; [I : (-> A A)]) +; #:type-name SKI +; #:extra-constructor-name make-SKI +; #:property prop:procedure +; (struct-field-index S))) +; (require 'type-var) From 654dad9769982f7b7f772ffca26b57a698efb7e4 Mon Sep 17 00:00:00 2001 From: ben Date: Sun, 14 Feb 2016 03:23:55 -0500 Subject: [PATCH 5/7] type-out: ignore supertype fields, enforce order on other fields --- .../typed-racket/base-env/prims.rkt | 61 +++++++------------ 1 file changed, 21 insertions(+), 40 deletions(-) diff --git a/typed-racket-lib/typed-racket/base-env/prims.rkt b/typed-racket-lib/typed-racket/base-env/prims.rkt index ab5c98f4d..d7b158bc3 100644 --- a/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -131,7 +131,7 @@ the typed racket language. racket/provide-transform racket/syntax racket/base - (only-in racket/string string-split) + (only-in racket/string string-prefix? string-split) (only-in "../typecheck/tc-structs.rkt" name-of-struct) (only-in "../typecheck/internal-forms.rkt" internal) (only-in "../typecheck/find-annotation.rkt" find-annotation) @@ -662,39 +662,20 @@ the typed racket language. ;; Also: ;; - check that supertype information is correct ;; - check that all struct fields have an annotation (including super fields) - (let ([struct-info (syntax-local-value #'n (lambda () #f))]) - (if (not struct-info) - (raise-syntax-error - 'type-out - "unknown struct type. (Make sure struct definitions come before their use in a type-out form)" - stx - (syntax-e #'n)) - (let*-values ([(_struct-type constr n? n-acc* _mut* super) + (let*-values ([(struct-info) + (or + (syntax-local-value #'n (lambda () #f)) + (raise-syntax-error 'type-out "unknown struct type. (Make sure struct definitions come before their use in a type-out form)" stx (syntax-e #'n)))] + [(_struct-type constr _n? all-acc* _mut* super) (apply values (extract-struct-info struct-info))] - [(acc*) - ;; Recursively collect all known struct fields / parent fields - (let loop ([acc* n-acc*] - [super super]) - (define-values (acc-prefix* acc-last) - (let loop ([acc* acc*] - [pre* '()]) - (cond - [(null? acc*) (values '() #t)] - [(null? (cdr acc*)) (values pre* (car acc*))] - [else (loop (cdr acc*) (cons (car acc*) pre*))]))) - (if acc-last - ;; then: list is reliable indicator of fields - acc* - ;; else: look for fields in supertype - (case super - [(#t) ;; No supertype - (error 'type-out "Internal Error: list of fields ~a is not exact, but struct has no supertype." acc*)] - [(#f) ;; Unknown supertype - (raise-syntax-error 'type-out (format "cannot determine field information for struct type '~a' (use struct-out instead)" (syntax-e #'n)) stx)] - [else ;; Recurse with parent struct-type-info - (define info (extract-struct-info (syntax-local-value super))) - (append acc-prefix* - (loop (cadddr info) (last info)))])))]) + [(acc*) ;; Reverse, filter superclass accessors, remove sentinel + (let ([n-str (symbol->string (syntax-e #'n))]) + (for/fold ([out* '()]) + ([acc (in-list all-acc*)]) + (if (and acc + (string-prefix? (symbol->string (syntax-e acc)) n-str)) + (cons acc out*) + out*)))]) ;; check parent, if given (when (and (attribute parent) (or (boolean? super) (not (free-identifier=? super #'parent)))) @@ -703,9 +684,7 @@ the typed racket language. (format "struct type ~a is not a subtype of ~a" (syntax-e #'n) (syntax-e #'parent)) stx)) ;; match known accessors with field information - (let* ([f+t* (sort (map syntax-e (syntax->list #'((f* . t*) ...))) - symbollist #'((f* . t*) ...)))] [_check-dup ;; Check for duplicate field annotations (for/fold ([prev #f]) ([f+t (in-list f+t*)]) @@ -713,19 +692,21 @@ the typed racket language. (raise-syntax-error 'type-out "duplicate annotation for struct field" (car f+t) stx)) (car f+t))] [acc+type* - (for/list ([acc (in-list (sort acc* symbolstring (syntax-e acc)) "-")))) (define f+t (if (null? f+t*) #f (begin0 (car f+t*) (set! f+t* (cdr f+t*))))) - (unless (and f+t (free-identifier=? acc-id (car f+t))) + (unless f+t (raise-syntax-error 'type-out "missing annotation for struct field" stx (syntax-e acc-id))) + (unless (free-identifier=? acc-id (car f+t)) + (raise-syntax-error 'type-out (format "expected annotation for struct field '~a'" (syntax-e acc-id)) stx (cons (syntax-e (car f+t)) (syntax-e (cdr f+t))))) (quasisyntax/loc stx (ann #,acc (-> n #,(cdr f+t)))))]) (unless (null? f+t*) - (raise-syntax-error 'type-out "struct field does not exist" stx (map (lambda (f+t) (syntax-e (car f+t))) f+t*))) - (quasisyntax/loc stx (let () #,@acc+type* (void))))))) + (raise-syntax-error 'type-out "struct field does not exist (supertype fields cannot be annotated in type-out)" stx (map (lambda (f+t) (syntax-e (car f+t))) f+t*))) + (quasisyntax/loc stx (let () #,@acc+type* (void))))) #:attr provide-spec* (if (attribute omit?) (with-syntax ([constr (cadr (extract-struct-info (syntax-local-value #'n)))]) From 8c8d48129107dcec462e4e4648142024914e7416 Mon Sep 17 00:00:00 2001 From: ben Date: Sun, 14 Feb 2016 03:51:08 -0500 Subject: [PATCH 6/7] type-out: define/provide 'tests' list --- .../unit-tests/type-out-tests.rkt | 1011 ++++++++--------- 1 file changed, 505 insertions(+), 506 deletions(-) diff --git a/typed-racket-test/unit-tests/type-out-tests.rkt b/typed-racket-test/unit-tests/type-out-tests.rkt index 06047e15c..137010a9a 100644 --- a/typed-racket-test/unit-tests/type-out-tests.rkt +++ b/typed-racket-test/unit-tests/type-out-tests.rkt @@ -4,517 +4,516 @@ ;; Each test is written as some Racket symbols to be eval'd in a fresh namespace. ;; Use `eval/pass DATA` and `eval/fail rx DATA` to test +(provide tests) +(require rackunit) + ;; ------------------------------------------------------------------------------------------------------ ;; utilities (define (eval/pass e) - (begin (eval e (make-base-namespace)) (void))) + (check-not-exn + (lambda () (eval e (make-base-namespace)) (void)))) (define (eval/fail exn-regexp e) - (define (check-exn e) - (define msg (exn-message e)) - (if (regexp-match? exn-regexp msg) - #t - (error 'type-out-test - (format "Test raised exception with message '~e', but expected message matching '~a'" - msg exn-regexp)))) - (unless (with-handlers ([exn? check-exn]) - (begin (eval e (make-base-namespace)) #f)) - (error 'type-out-tests "No exception raised in ~a" e))) - -;; ------------------------------------------------------------------------------------------------------ -;; basics / rename - -;; type-out a single definition -(eval/pass - '(begin - (module single typed/racket/base - (provide - (type-out [f (-> Natural Natural)])) - (define (f n) - (define n-1 (- n 1)) - (if (positive? n-1) (* n (f n-1)) 1))) - (require 'single))) - -;; type-out multiple definitions, along with ordinary provides -(eval/pass - '(begin - (module multi typed/racket/base - (provide - (type-out [n Natural] - [fact (-> Natural Natural)]) - fib) - - (define n 12) - - (define (fact n) - (define n-1 (- n 1)) - (if (positive? n-1) (* n (fact n-1)) 1)) - - (: fib (-> Natural Natural)) - (define (fib n) - (define n-1 (- n 1)) - (define n-2 (- n 2)) - (if (and (positive? n-1) (positive? n-2)) - (+ (fib n-1) (fib n-2)) 1))) - (require 'multi))) - -;; use rename form -(eval/pass - '(begin - (module rename typed/racket/base + (check-exn exn-regexp + (lambda () (eval e (make-base-namespace))))) + +(define tests (make-test-suite "type-out tests" (list + (test-suite "basics / (type-out ... rename ...)" ;; ------------------------- + ;; type-out a single definition + (eval/pass + '(begin + (module single typed/racket/base + (provide + (type-out [f (-> Natural Natural)])) + (define (f n) + (define n-1 (- n 1)) + (if (positive? n-1) (* n (f n-1)) 1))) + (require 'single))) + + ;; type-out multiple definitions, along with ordinary provides + (eval/pass + '(begin + (module multi typed/racket/base + (provide + (type-out [n Natural] + [fact (-> Natural Natural)]) + fib) + + (define n 12) + + (define (fact n) + (define n-1 (- n 1)) + (if (positive? n-1) (* n (fact n-1)) 1)) + + (: fib (-> Natural Natural)) + (define (fib n) + (define n-1 (- n 1)) + (define n-2 (- n 2)) + (if (and (positive? n-1) (positive? n-2)) + (+ (fib n-1) (fib n-2)) 1))) + (require 'multi))) + + ;; use rename form + (eval/pass + '(begin + (module rename typed/racket/base + (provide + (type-out + [rename fact g (-> Natural Natural)])) + + (define (fact n) + (define n-1 (- n 1)) + (if (positive? n-1) (* n (fact n-1)) 1))) + (require 'rename))) + + ;; (type-out (rename ...)) + ;; Does not provide original identifier + (eval/fail #rx"f: undefined" + '(begin + (module rename typed/racket/base + (provide + (type-out (rename f g (-> Natural Natural)))) + (define (f n) + (let ([n-1 (- n 1)]) + (if (positive? n-1) (* n (f n-1)) 1)))) + (require 'rename) + (f 4))) + + ;; Type mismatch + (eval/fail #rx"Type Checker" + '(begin + (module bad-type-1 typed/racket/base + (provide + (type-out (n String))) + (define n 3)))) + + (eval/fail #rx"Type Checker" + '(begin + (module bad-type-2 typed/racket/base + (provide + (type-out (n Natural))) + (define n -3)))) + + ;; Arity mismatch + (eval/fail #rx"Type Checker" + '(begin + (module bad-arity typed/racket/base + (provide + (type-out (f (-> Natural Natural)))) + (define (f x y) y)))) + ) + (test-suite "type-out/phase level change" ;; -------------------------------- + + (eval/pass + '(begin + (module bfs typed/racket/base + (require (for-syntax typed/racket/base)) + + (begin-for-syntax + (provide + (type-out (f (-> String Boolean)))) + (define (f s) + (= 8 (string-length s))))) + (require 'bfs))) + + ;; Cannot type-out at a different phase from the provide + (eval/fail #rx"Type Checker.*`s' has no definition" + '(begin + (module for-stx typed/racket/base + (require (for-syntax typed/racket/base)) + + (provide + (for-syntax (type-out [s (-> String String)]))) + + (define-for-syntax (s str) "")) + (require 'for-stx))) + ) + (test-suite "struct tests" ;; ----------------------------------------------- + + ;; basic struct definitions, order of declarations does not matter + (eval/pass + '(begin + (module defstruct-1 typed/racket/base + (struct foo-1 ([a : Natural] [b : (-> Boolean String)])) + (provide + (type-out [struct foo-1 ([a : Natural] [b : (-> Boolean String)])])) + (define f foo-1)) + (require 'defstruct-1))) + + (eval/pass + '(begin + (module defstruct-2 typed/racket/base + (struct foo-2 ([a : Natural] [b : (-> Boolean String)])) + (provide + (type-out [struct foo-2 ([a : Natural] [b : (-> Boolean String)])])) + (define f foo-2)) + (require 'defstruct-2) + foo-2? + foo-2-a)) + + ;; Order of field definitions is enforced + (eval/fail #rx"type-out: expected annotation" + '(begin + (module defstruct-3 typed/racket/base + (struct foo-3 ([b : (-> Boolean String)] [a : Natural])) + (provide + (type-out [struct foo-3 ([a : Natural] [b : (-> Boolean String)])])) + (define f foo-3)) + (require 'defstruct-3))) + + ;; struct with parent, provide both struct & parent + (eval/pass + '(begin + (module struct/parent typed/racket/base + (struct bar ([x : Natural] [y : Boolean])) + (struct baz bar ([z : MyType]) #:property prop:procedure (struct-field-index z)) + (provide (type-out + (struct bar ([x : Natural] [y : Boolean])) + (struct (baz bar) ([z : MyType])))) + (define-type MyType (-> Natural Boolean String))) + (require 'struct/parent) + bar? baz?)) + + ;; struct with parent, struct only + (eval/pass + '(begin + (module struct/parent typed/racket/base + (struct bar ([x : Natural] [y : Boolean])) + (struct baz bar ([z : MyType]) #:property prop:procedure (struct-field-index z)) + (provide (type-out + (struct (baz bar) ([z : MyType])))) + (define-type MyType (-> Natural Boolean String))) + (require 'struct/parent) + baz?)) + + ;; Check provides after an #:omit-constructor + (eval/pass + '(begin + (module omit-constructor-1 typed/racket/base + (struct qux ([x : Natural] [y : Boolean])) + (provide (type-out + (struct qux ([x : Natural] [y : Boolean]) #:omit-constructor)))) + (require 'omit-constructor-1) + qux?)) + + ;; #:omit-constructor + (eval/fail #rx"qux: undefined" + '(begin + (module omit-constructor-1 typed/racket/base + (struct qux ([x : Natural] [y : Boolean])) + (provide (type-out + (struct qux ([x : Natural] [y : Boolean]) #:omit-constructor)))) + (require 'omit-constructor-1) + (qux 0 #t))) + + ;; #:omit-constructor should hide #:constructor-name constructors as well + (eval/fail #rx"makes: undefined" + '(begin + (module constr-name typed/racket/base + (struct s () #:constructor-name makes) + (provide (type-out + (struct s () #:omit-constructor)))) + (require 'constr-name) + makes)) + + ;; #:omit-constructor should hide #:extra-constructor-name too + (eval/fail #rx"makes: undefined" + '(begin + (module constr-name typed/racket/base + (struct s () #:extra-constructor-name makes) + (provide (type-out + (struct s () #:omit-constructor)))) + (require 'constr-name) + makes)) + + ;; #:extra-constructor-name also hides default constructor + (eval/fail #rx"s: undefined" + '(begin + (module constr-name typed/racket/base + (struct s () #:extra-constructor-name makes) + (provide (type-out + (struct s () #:omit-constructor)))) + (require 'constr-name) + (s))) + + ;; Must define the struct before providing it + (eval/fail #rx"type-out: unknown struct type" + '(begin + (module defstruct/type-name typed/racket/base + (provide + (type-out [struct bar ()]))))) + + ;; Must define the struct before providing it + (eval/fail #rx"type-out: unknown struct type" + '(begin + (module defstruct/type-name typed/racket/base + (define bar 1) + (provide + (type-out [struct bar ()]))))) + + ;; Test incorrect field type + (eval/fail #rx"Type Checker" + '(begin + (module s typed/racket/base + (struct s ([f : (-> Boolean String)])) + (provide + (type-out (struct s ([f : Boolean]))))) + (require 's))) + + ;; Must declare all struct fields + (eval/fail #rx"type-out: missing annotation" + '(begin + (module s typed/racket/base + (struct s ([f : (-> Boolean String)])) + (provide + (type-out (struct s ())))) + (require 's) + (define my-s (s (lambda (x) "hi"))) + ((s-f my-s) #t))) + + ;; Must declare all struct fields, but not parent fields + (eval/fail #rx"type-out: struct field does not exist" + '(begin + (module t typed/racket/base + (struct bar ([x : Natural])) + (struct baz bar ([y : Boolean])) + (provide (type-out + (struct bar ([x : Natural])) + (struct (baz bar) ([y : Boolean] [x : Natural]))))))) + + ;; Must declare all struct fields, but not parent fields or grandparent fields + (eval/fail #rx"type-out: struct field does not exist" + '(begin + (module t typed/racket/base + (struct bar ([x : Natural])) + (struct baz bar ([y : Boolean])) + (struct qux baz ([z : String] [x : Natural])) + (provide (type-out + (struct bar ([x : Natural])) + (struct (baz bar) ([y : Boolean] [x : Natural])) + (struct (qux baz) ([z : String] [y : Boolean]))))))) + + ;; Must really be a sub-struct of parent + (eval/fail #rx"type-out: struct type baz is not a subtype" + '(begin + (module t typed/racket/base + (struct bar ([x : Natural])) + (struct baz ([y : Boolean])) + (provide (type-out + (struct bar ([x : Natural])) + (struct (baz bar) ([y : Boolean]))))))) + + ;; type-out should not declare extra fields + (eval/fail #rx"type-out: struct field does not exist" + '(begin + (module s typed/racket/base + (struct s ([f : (-> Boolean String)])) + (provide + (type-out (struct s ([f : (-> Boolean String)] + [g : Natural]))))) + (require 's))) + + ;; Test bad struct option in type-out + (eval/fail #rx"type-out: expected the literal" + '(begin + (module struct-def typed/racket/base + (struct A ((a : String)) #:type-name Foo) + (provide (type-out + (struct A ((a : String)) #:type-name Foo)))))) + ) + (test-suite "class" ;; ------------------------------------------------------ + + (eval/pass + '(begin + (module class typed/racket/base + (provide (type-out + (automaton% Automaton) + (a oAutomaton))) + + ;; Example OO code + (require typed/racket/class) + + (define-type State Natural) + (define-type Payoff Natural) + (define-type Transition* (Vectorof (Vectorof Payoff))) + (define-type oAutomaton (Instance Automaton)) + (define-type Automaton + (Class + (init-field [current State] + [payoff Payoff] + [table Transition*] + [original State #:optional]) + [match-pair (-> oAutomaton Natural (values oAutomaton oAutomaton))] + [jump (-> State Payoff Void)] + [pay (-> Payoff)] + [reset (-> oAutomaton)] + [clone (-> oAutomaton)] + [equal (-> oAutomaton Boolean)])) + + (define automaton% + (let () + (class object% + (init-field + current + payoff + table + (original current)) + (super-new) + + (define/public (match-pair other r) + ;; Implementation omitted + (values this other)) + + (define/public (jump input delta) + (set! current (vector-ref (vector-ref table current) input)) + (set! payoff (+ payoff delta))) + + (define/public (pay) + payoff) + + (define/public (reset) + (new automaton% [current original][payoff 0][table table])) + + (define/public (clone) + (new automaton% [current original][payoff 0][table table])) + + (: compute-payoffs (-> State [cons Payoff Payoff])) + (define/private (compute-payoffs other-current) + (vector-ref (vector-ref #(#()) current) other-current)) + + (define/public (equal other) + (and (= current (get-field current other)) + (= original (get-field original other)) + (= payoff (get-field payoff other)) + (equal? table (get-field table other))))))) + + (define a (new automaton% (current 0) (payoff 999) (table '#(#(0 0) #(1 1)))))) + (require 'class))) + ) + (test-suite "#:opaque" ;; --------------------------------------------------- + + (eval/pass + '(begin + (module opaque-1 typed/racket/base + (require/typed racket/base + [#:opaque Str string?] + [string-length (-> Str Natural)]) + + (provide + MyTuple + (type-out (and-cdr (-> MyTuple Boolean)))) + (define-type MyTuple (Pairof String Natural)) + + (define (and-cdr x) + (and (cdr x) #t))) + (require 'opaque-1))) + + (eval/pass + '(begin + (module opaque-2 typed/racket/base + (define-type MyTuple (Pairof Str Boolean)) + + (require/typed racket/base + [#:opaque Str string?] + [string-length (-> Str Natural)]) + + (define (b x) + #t)) + (require 'opaque-2))) + + (eval/pass + '(begin + (module opaque-3 typed/racket/base + (define-type Foobar (-> Pict)) + + (require/typed pict + [#:opaque Pict pict?] + [blank (-> Real Real Pict)]) + + (provide (type-out + (c (-> Pict Boolean)))) + + (define (c x) + #t)) + (require 'opaque-3))) + ) + (test-suite "#:constructor-name" ;; ----------------------------------------- + + (eval/pass + '(begin + (module constr-name-1 typed/racket/base + (struct s () #:constructor-name makes) + (provide (type-out + (struct s ()))) + (define f makes)) + (require 'constr-name-1) + (s? (makes)))) + + (eval/pass + '(begin + (module constr-name-2 typed/racket/base + (struct r () #:constructor-name maker) + (provide (type-out + (struct r () #:omit-constructor))) + (define f maker)) + (require 'constr-name-2) + r?)) + + (eval/fail #rx"maker: undefined" + '(begin + (module constr-name-2 typed/racket/base + (struct r () #:constructor-name maker) + (provide (type-out + (struct r () #:omit-constructor))) + (define f maker)) + (require 'constr-name-2) + (maker))) + ) +#;(test-suite "TODO : KNOWN FAILURES" ;; -------------------------------------- + + ;; compatible with type-name + (eval/pass + '(begin + (module type-name typed/racket/base + (struct secret ([x : Key]) #:type-name SecretKey) + (define-type Key String) + (provide + (type-out (struct secret ([x : Key]))))) + (require 'type-name))) + + ;; blocked on https://github.com/racket/typed-racket/issues/312 + (eval/fail #rx"identifier for static struct type information cannot be used as an expression" + '(begin + (module constr-name-1 typed/racket/base + (struct s () #:constructor-name makes) + (provide (type-out + (struct s ()))) + (define f (makes))) + (require 'constr-name-1) + (s))) + + ;; blocked on https://github.com/racket/typed-racket/issues/304 + ;; compatible with polymorphic type-name? + (module type-name-poly typed/racket/base + (struct (A) secret-poly ([x : A]) #:type-name SecretPoly) (provide - (type-out - [rename fact g (-> Natural Natural)])) - - (define (fact n) - (define n-1 (- n 1)) - (if (positive? n-1) (* n (fact n-1)) 1))) - (require 'rename))) - -;; (type-out (rename ...)) -;; Does not provide original identifier -(eval/fail "f: undefined" - '(begin - (module rename typed/racket/base + (type-out (struct (A) secret-poly ([x : A]))))) + (require 'type-name-poly) + ; more intense use of type variables + (module type-var typed/racket/base (provide - (type-out (rename f g (-> Natural Natural)))) - (define (f n) - (let ([n-1 (- n 1)]) - (if (positive? n-1) (* n (f n-1)) 1)))) - (require 'rename) - (f 4))) - -;; Type mismatch -(eval/fail "Type Checker" - '(begin - (module bad-type-1 typed/racket/base - (provide - (type-out (n String))) - (define n 3)))) - -(eval/fail "Type Checker" - '(begin - (module bad-type-2 typed/racket/base - (provide - (type-out (n Natural))) - (define n -3)))) - -;; Arity mismatch -(eval/fail "Type Checker" - '(begin - (module bad-arity typed/racket/base - (provide - (type-out (f (-> Natural Natural)))) - (define (f x y) y)))) - -;; ------------------------------------------------------------------------------------------------------ -;; begin-for-syntax -;; Can 'type-out' at a different phase level, as long as it's the same phase as the provide - -(eval/pass - '(begin - (module bfs typed/racket/base - (require (for-syntax typed/racket/base)) - - (begin-for-syntax - (provide - (type-out (f (-> String Boolean)))) - (define (f s) - (= 8 (string-length s))))) - (require 'bfs))) - -;; Cannot type-out at a different phase from the provide -(eval/fail "Type Checker.*`s' has no definition" - '(begin - (module for-stx typed/racket/base - (require (for-syntax typed/racket/base)) - - (provide - (for-syntax (type-out [s (-> String String)]))) - - (define-for-syntax (s str) "")) - (require 'for-stx))) - -;; ------------------------------------------------------------------------------------------------------ -;; struct - -;; basic struct definitions, order of declarations does not matter -(eval/pass - '(begin - (module defstruct-1 typed/racket/base - (struct foo-1 ([a : Natural] [b : (-> Boolean String)])) - (provide - (type-out [struct foo-1 ([a : Natural] [b : (-> Boolean String)])])) - (define f foo-1)) - (require 'defstruct-1))) - -(eval/pass - '(begin - (module defstruct-2 typed/racket/base - (struct foo-2 ([a : Natural] [b : (-> Boolean String)])) - (provide - (type-out [struct foo-2 ([a : Natural] [b : (-> Boolean String)])])) - (define f foo-2)) - (require 'defstruct-2) - foo-2? - foo-2-a)) - -;; struct with parent, provide both struct & parent -(eval/pass - '(begin - (module struct/parent typed/racket/base - (struct bar ([x : Natural] [y : Boolean])) - (struct baz bar ([z : MyType]) #:property prop:procedure (struct-field-index z)) - (provide (type-out - (struct bar ([x : Natural] [y : Boolean])) - (struct (baz bar) ([x : Natural] [y : Boolean] [z : MyType])))) - (define-type MyType (-> Natural Boolean String))) - (require 'struct/parent) - bar? baz?)) - -;; struct with parent, struct only -(eval/pass - '(begin - (module struct/parent typed/racket/base - (struct bar ([x : Natural] [y : Boolean])) - (struct baz bar ([z : MyType]) #:property prop:procedure (struct-field-index z)) - (provide (type-out - (struct (baz bar) ([x : Natural] [y : Boolean] [z : MyType])))) - (define-type MyType (-> Natural Boolean String))) - (require 'struct/parent) - baz?)) - -;; Check provides after an #:omit-constructor -(eval/pass - '(begin - (module omit-constructor-1 typed/racket/base - (struct qux ([x : Natural] [y : Boolean])) - (provide (type-out - (struct qux ([x : Natural] [y : Boolean]) #:omit-constructor)))) - (require 'omit-constructor-1) - qux?)) - -;; #:omit-constructor -(eval/fail "qux: undefined" - '(begin - (module omit-constructor-1 typed/racket/base - (struct qux ([x : Natural] [y : Boolean])) - (provide (type-out - (struct qux ([x : Natural] [y : Boolean]) #:omit-constructor)))) - (require 'omit-constructor-1) - (qux 0 #t))) - -;; #:omit-constructor should hide #:constructor-name constructors as well -(eval/fail "makes: undefined" - '(begin - (module constr-name typed/racket/base - (struct s () #:constructor-name makes) - (provide (type-out - (struct s () #:omit-constructor)))) - (require 'constr-name) - makes)) - -;; #:omit-constructor should hide #:extra-constructor-name too -(eval/fail "makes: undefined" - '(begin - (module constr-name typed/racket/base - (struct s () #:extra-constructor-name makes) - (provide (type-out - (struct s () #:omit-constructor)))) - (require 'constr-name) - makes)) - -;; #:extra-constructor-name also hides default constructor -(eval/fail "s: undefined" - '(begin - (module constr-name typed/racket/base - (struct s () #:extra-constructor-name makes) - (provide (type-out - (struct s () #:omit-constructor)))) - (require 'constr-name) - (s))) - -;; Must define the struct before providing it -(eval/fail "type-out: unknown struct type" - '(begin - (module defstruct/type-name typed/racket/base - (provide - (type-out [struct bar ()]))))) - -;; Must define the struct before providing it -(eval/fail "type-out: unknown struct type" - '(begin - (module defstruct/type-name typed/racket/base - (define bar 1) - (provide - (type-out [struct bar ()]))))) - -;; Test incorrect field type -(eval/fail "Type Checker" - '(begin - (module s typed/racket/base - (struct s ([f : (-> Boolean String)])) - (provide - (type-out (struct s ([f : Boolean]))))) - (require 's))) - -;; Must declare all struct fields -(eval/fail "type-out: missing annotation" - '(begin - (module s typed/racket/base - (struct s ([f : (-> Boolean String)])) - (provide - (type-out (struct s ())))) - (require 's) - (define my-s (s (lambda (x) "hi"))) - ((s-f my-s) #t))) - -;; Must declare all struct fields, including parent fields -(eval/fail "type-out: missing annotation" - '(begin - (module t typed/racket/base - (struct bar ([x : Natural])) - (struct baz bar ([y : Boolean])) - (provide (type-out - (struct bar ([x : Natural])) - (struct (baz bar) ([y : Boolean]))))))) - -;; Must declare all struct fields, including parent fields and grandparent fields -(eval/fail "type-out: missing annotation" - '(begin - (module t typed/racket/base - (struct bar ([x : Natural])) - (struct baz bar ([y : Boolean])) - (struct qux baz ([z : String])) - (provide (type-out - (struct bar ([x : Natural])) - (struct (baz bar) ([y : Boolean] [x : Natural])) - (struct (qux baz) ([z : String] [y : Boolean]))))))) - -;; Must really be a sub-struct of parent -(eval/fail "type-out: struct type baz is not a subtype" - '(begin - (module t typed/racket/base - (struct bar ([x : Natural])) - (struct baz ([y : Boolean])) - (provide (type-out - (struct bar ([x : Natural])) - (struct (baz bar) ([y : Boolean]))))))) - -;; type-out should not declare extra fields -(eval/fail "type-out: struct field does not exist" - '(begin - (module s typed/racket/base - (struct s ([f : (-> Boolean String)])) - (provide - (type-out (struct s ([f : (-> Boolean String)] - [g : Natural]))))) - (require 's))) - -;; Test bad struct option in type-out -(eval/fail "type-out: expected the literal" - '(begin - (module struct-def typed/racket/base - (struct A ((a : String)) #:type-name Foo) - (provide (type-out - (struct A ((a : String)) #:type-name Foo)))))) - -;; ------------------------------------------------------------------------------------------------------ -;; Example class - -(eval/pass - '(begin - (module class typed/racket/base - (provide (type-out - (automaton% Automaton) - (a oAutomaton))) - - ;; Example OO code - (require typed/racket/class) - - (define-type State Natural) - (define-type Payoff Natural) - (define-type Transition* (Vectorof (Vectorof Payoff))) - (define-type oAutomaton (Instance Automaton)) - (define-type Automaton - (Class - (init-field [current State] - [payoff Payoff] - [table Transition*] - [original State #:optional]) - [match-pair (-> oAutomaton Natural (values oAutomaton oAutomaton))] - [jump (-> State Payoff Void)] - [pay (-> Payoff)] - [reset (-> oAutomaton)] - [clone (-> oAutomaton)] - [equal (-> oAutomaton Boolean)])) - - (define automaton% - (let () - (class object% - (init-field - current - payoff - table - (original current)) - (super-new) - - (define/public (match-pair other r) - ;; Implementation omitted - (values this other)) - - (define/public (jump input delta) - (set! current (vector-ref (vector-ref table current) input)) - (set! payoff (+ payoff delta))) - - (define/public (pay) - payoff) - - (define/public (reset) - (new automaton% [current original][payoff 0][table table])) - - (define/public (clone) - (new automaton% [current original][payoff 0][table table])) - - (: compute-payoffs (-> State [cons Payoff Payoff])) - (define/private (compute-payoffs other-current) - (vector-ref (vector-ref #(#()) current) other-current)) - - (define/public (equal other) - (and (= current (get-field current other)) - (= original (get-field original other)) - (= payoff (get-field payoff other)) - (equal? table (get-field table other))))))) - - (define a (new automaton% (current 0) (payoff 999) (table '#(#(0 0) #(1 1)))))) - (require 'class))) - -;; ------------------------------------------------------------------------------------------------------ -;; test compatibility with #:opaque types -;; (to check if reordering type declarations breaks things) - -(eval/pass - '(begin - (module opaque-1 typed/racket/base - (require/typed racket/base - [#:opaque Str string?] - [string-length (-> Str Natural)]) - - (provide - MyTuple - (type-out (and-cdr (-> MyTuple Boolean)))) - (define-type MyTuple (Pairof String Natural)) - - (define (and-cdr x) - (and (cdr x) #t))) - (require 'opaque-1))) - -(eval/pass - '(begin - (module opaque-2 typed/racket/base - (define-type MyTuple (Pairof Str Boolean)) - - (require/typed racket/base - [#:opaque Str string?] - [string-length (-> Str Natural)]) - - (define (b x) - #t)) - (require 'opaque-2))) - -(eval/pass - '(begin - (module opaque-3 typed/racket/base - (define-type Foobar (-> Pict)) - - (require/typed pict - [#:opaque Pict pict?] - [blank (-> Real Real Pict)]) - - (provide (type-out - (c (-> Pict Boolean)))) - - (define (c x) - #t)) - (require 'opaque-3))) - -;; ------------------------------------------------------------------------------------------------------ -;; compatible with #:constructor-name - -(eval/pass - '(begin - (module constr-name-1 typed/racket/base - (struct s () #:constructor-name makes) - (provide (type-out - (struct s ()))) - (define f makes)) - (require 'constr-name-1) - (s? (makes)))) - -(eval/pass - '(begin - (module constr-name-2 typed/racket/base - (struct r () #:constructor-name maker) - (provide (type-out - (struct r () #:omit-constructor))) - (define f maker)) - (require 'constr-name-2) - r?)) - -(eval/fail "maker: undefined" - '(begin - (module constr-name-2 typed/racket/base - (struct r () #:constructor-name maker) - (provide (type-out - (struct r () #:omit-constructor))) - (define f maker)) - (require 'constr-name-2) - (maker))) - -;; ----------------------------------------------------------------------------- -;; TODO these tests are known to fail - -;; compatible with type-name -;(eval/pass -; '(begin -; (module type-name typed/racket/base -; (struct secret ([x : Key]) #:type-name SecretKey) -; (define-type Key String) -; (provide -; (type-out (struct secret ([x : Key]))))) -; (require 'type-name))) - -;; blocked on https://github.com/racket/typed-racket/issues/312 -;(eval/fail "identifier for static struct type information cannot be used as an expression" -; '(begin -; (module constr-name-1 typed/racket/base -; (struct s () #:constructor-name makes) -; (provide (type-out -; (struct s ()))) -; (define f (makes))) -; (require 'constr-name-1) -; (s))) - -;; blocked on https://github.com/racket/typed-racket/issues/304 -; ; compatible with polymorphic type-name? -; (module type-name-poly typed/racket/base -; (struct (A) secret-poly ([x : A]) #:type-name SecretPoly) -; (provide -; (type-out (struct (A) secret-poly ([x : A]))))) -; (require 'type-name-poly) -; ; more intense use of type variables -; (module type-var typed/racket/base -; (provide -; (type-out -; (struct (A B C) ski ([S : (-> (-> A B C) (-> A B) A C)] -; [K : (-> A B A)] -; [I : (-> A A)])))) -; (struct (A B C) ski ([S : (-> (-> A B C) (-> A B) A C)] -; [K : (-> A B A)] -; [I : (-> A A)]) -; #:type-name SKI -; #:extra-constructor-name make-SKI -; #:property prop:procedure -; (struct-field-index S))) -; (require 'type-var) + (type-out + (struct (A B C) ski ([S : (-> (-> A B C) (-> A B) A C)] + [K : (-> A B A)] + [I : (-> A A)])))) + (struct (A B C) ski ([S : (-> (-> A B C) (-> A B) A C)] + [K : (-> A B A)] + [I : (-> A A)]) + #:type-name SKI + #:extra-constructor-name make-SKI + #:property prop:procedure + (struct-field-index S))) + (require 'type-var) + ) +))) From a8153561f66dc000de5b37333d494e0e4bebd7d6 Mon Sep 17 00:00:00 2001 From: ben Date: Sun, 14 Feb 2016 13:19:29 -0500 Subject: [PATCH 7/7] type-out: fix bug inferring struct field names --- typed-racket-lib/typed-racket/base-env/prims.rkt | 3 ++- typed-racket-test/unit-tests/type-out-tests.rkt | 8 ++++++++ 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/typed-racket-lib/typed-racket/base-env/prims.rkt b/typed-racket-lib/typed-racket/base-env/prims.rkt index d7b158bc3..009768e65 100644 --- a/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -691,10 +691,11 @@ the typed racket language. (when (and prev (free-identifier=? prev (car f+t))) (raise-syntax-error 'type-out "duplicate annotation for struct field" (car f+t) stx)) (car f+t))] + [n-len (+ 1 (string-length (symbol->string (syntax-e #'n))))] ;; To infer field names [acc+type* (for/list ([acc (in-list acc*)]) (define acc-id - (format-id stx "~a" (last (string-split (symbol->string (syntax-e acc)) "-")))) + (format-id stx "~a" (substring (symbol->string (syntax-e acc)) n-len))) (define f+t (if (null? f+t*) #f diff --git a/typed-racket-test/unit-tests/type-out-tests.rkt b/typed-racket-test/unit-tests/type-out-tests.rkt index 137010a9a..b131caa87 100644 --- a/typed-racket-test/unit-tests/type-out-tests.rkt +++ b/typed-racket-test/unit-tests/type-out-tests.rkt @@ -321,6 +321,14 @@ (struct A ((a : String)) #:type-name Foo) (provide (type-out (struct A ((a : String)) #:type-name Foo)))))) + ;; Works with hyphenated struct/field names + (eval/pass + '(begin + (module t typed/racket/base + (struct a-b ([c-d : Natural])) + (provide (type-out + (struct a-b ([c-d : Natural]))))) + (require 't))) ) (test-suite "class" ;; ------------------------------------------------------