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

The get macro now works well, but needs a patch in typed/racket to fix a bug when providing promises which need to be wrapped in a contract.

Browse Source
This commit is contained in:
Georges Dupéron 2015-12-17 14:14:42 +01:00
parent 6e5bc55402
commit 2c0dfe7350
8 changed files with 261 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
graph/graph/__DEBUG_graph__.rkt
View File

@ -1,4 +1,4 @@
#lang debug typed/racket #lang typed/racket
#| #|
(require "structure.lp2.rkt") (require "structure.lp2.rkt")
@ -19,15 +19,21 @@
|# |#
(require (submod "graph3.lp2.rkt" test)) (require (submod "graph3.lp2.rkt" test))
(require "graph3.lp2.rkt")
(require "graph4.lp2.rkt") (require "graph4.lp2.rkt")
(require "structure.lp2.rkt") (require "structure.lp2.rkt")
(require "variant.lp2.rkt") (require "variant.lp2.rkt")
(require "../lib/low.rkt") (require "../lib/low.rkt")
(require "../type-expander/type-expander.lp2.rkt")
;(structure-get people) (structure-get (cadr (force g)) people)
(structure-get (cadr g) people)
(get g people) (get g people)
(get g streets cadr houses car owner name) (get g streets cadr houses car owner name)
((λget people) g)
((λget owner name) (get g streets cadr houses car))
;;((λget streets cadr houses car owner name) g)
;;(map (λget houses car owner name) (get g streets))
#| #|
(define #:∀ (A) (map-force [l : (Listof (Promise A))]) (define #:∀ (A) (map-force [l : (Listof (Promise A))])

27
graph/graph/__DEBUG_structure-supertype__.rkt Normal file
View File

@ -0,0 +1,27 @@
#lang typed/racket
(require "../type-expander/type-expander.lp2.rkt")
(define-type-expander (CPairof stx)
(syntax-case stx ()
[(_ a) #'(curry Pairof a)]
[(_ a b) #'(Pairof a b)]))
(ann (ann '(1 . "b") (CPairof Number String))
(Pairof Number String))
(ann (ann '(1 . "c") ((CPairof Number) String))
(Pairof Number String))
(require "structure.lp2.rkt")
(require "../type-expander/type-expander.lp2.rkt")
(define ab (structure [f-a 1] [f-b "b"]))
(define abc (structure [f-a 1] [f-b "b"] [f-c 'c]))
(define f
(λ ([x : (structure-supertype [f-a Number] [f-b String])])
x))
(f ab)
(f abc)

14
graph/graph/graph3.lp2.rkt
View File

@ -112,7 +112,9 @@ the root arguments as parameters.
@chunk[<use-example> @chunk[<use-example>
(define-graph make-g <example-variants>) (define-graph make-g <example-variants>)
(define g (make-g <example-root>))] #;(define g (make-g <example-root>))
(define g1 (make-g <example-root>))
(define g g1)]
@subsection{More details on the semantics} @subsection{More details on the semantics}
@ -591,14 +593,14 @@ are replaced by tagged indices:
(begin <define-with-promises>) … (begin <define-with-promises>) …
(begin <define-incomplete>) … (begin <define-incomplete>) …
(begin <define-mapping-function>) … (begin <define-mapping-function>) …
(: name (→ root-param-type … root/with-promises-type)) (: name (→ root-param-type … (Promise root/with-promises-type)))
(define (name root-param …) (define (name root-param …)
(match-let ([(list node/database …) <fold-queues>]) (match-let ([(list node/database …) <fold-queues>])
(begin <define-with-indices→with-promises>) … (begin <define-with-indices→with-promises>) …
;(list node/with-indices→with-promises …) (let ([root/with-promises (root/with-indices→with-promises
(root/with-indices→with-promises (vector-ref root/database 0))])
(vector-ref root/database 0))))))#|)|#)] (delay root/with-promises)))))))]
@section{Conclusion} @section{Conclusion}

67
graph/graph/graph4.lp2.rkt
View File

@ -14,7 +14,7 @@ is correctly taken into account. Note that @tc[car] would still work, because we
also match identifiers with the @tc[c…r] syntax, as a fallback or for chains of also match identifiers with the @tc[c…r] syntax, as a fallback or for chains of
more than 4 letters. more than 4 letters.
@CHUNK[<c*r-syntax-class> @CHUNK[<c…r-syntax-class>
(define-syntax-class c…r (define-syntax-class c…r
;(pattern (~literal car) #:with (expanded …) #'(car)) ;(pattern (~literal car) #:with (expanded …) #'(car))
;(pattern (~literal cdr) #:with (expanded …) #'(cdr)) ;(pattern (~literal cdr) #:with (expanded …) #'(cdr))
@ -85,12 +85,14 @@ otherwise throw an error:
@chunk[<get-tagged> @chunk[<get-tagged>
[((make-predicate (List Symbol Any)) v-cache) [((make-predicate (List Symbol Any)) v-cache)
(get (structure-get (cadr v-cache) field) other-fields …)]] (get (structure-get (cadr v-cache) field) other-fields …)]]
@chunk[<get-promise> @chunk[<get-promise>
[(promise? v-cache) [(promise? v-cache)
(let ([f-cache (force v-cache)]) (let ([f-cache (force v-cache)])
(if ((make-predicate (List Symbol Any)) f-cache) (if ((make-predicate (List Symbol Any)) f-cache)
(get (structure-get (cadr f-cache) field) other-fields …) (get (structure-get (cadr f-cache) field) other-fields …)
(get (structure-get f-cache field) other-fields …)))]] (get (structure-get f-cache field) other-fields …)))]]
@chunk[<get-plain-struct> @chunk[<get-plain-struct>
[else [else
(get (structure-get v-cache field) other-fields …)]] (get (structure-get v-cache field) other-fields …)]]
@ -98,6 +100,55 @@ otherwise throw an error:
@chunk[<test-get> @chunk[<test-get>
(check-equal? 'TODO 'TODO)] (check-equal? 'TODO 'TODO)]
@section{@racket[λget]}
@chunk[<λget>
(define-syntax (λget stx)
(syntax-parse stx
;[(_ v:expr (~and c?r (~or (~lit car) (~lit cdr))) other-fields …)
; #'(get (c?r v) other-fields …)]
;[(_ v:expr c…r:c…r other-fields …)
; #`(get v #,@(reverse (syntax->list #'(c…r.expanded …)))
; other-fields …)]
[(_ field:id …)
#'(ann (λ (v) (get v field …))
(∀ (T) (→ (λget-type-helper T field …) T)))]))]
The type for the function generated by @tc[λget] mirrors the cases from
@tc[get].
@; TODO: To avoid the n⁴ code size complexity (with n being the number of fields
@; in the expression (λget f₁ … fₙ), maybe we should always wrap structures in a
@; list with a dummy symbol as the first element, and wrap that in a promise
@; that just returns the value. That way, we'll always fall in the
@; @tc[(Promise (List <r>))] case. Using a named type of the form
@; @tc[(define-type (maybe-wrapped S) (U S (List Symbol S)
@; (Promise (U S (List Symbol S)))))]
@; won't work, because TR inlines these, unless they are recursive.
@; We could otherwise try to make sure that the user never sees a Promise, and
@; always force it when we return one (and node types would be
@; @tc[(U with-fields=promises with-fields=with-promises)
@; Or we could put in a fake piece of recursion to prevent TR from expanding the
@; type, but that behaviour could change in the future:
@; @tc[(define-type (maybe-wrapped S) (U S
@; (List Symbol S)
@; (Promise (U S (List Symbol S)))
@; (→ (maybe-wrapped S) unforgeable))))]
@chunk[<λget-type-helper>
(define-type-expander (λget-type-helper stx)
(syntax-parse stx
[(_ T:expr)
#'T]
[(_ T:expr field:id other-fields:id …)
#;#'(U <r>
(List Symbol <r>)
(Promise (U <r> (List Symbol <r>))))
#'(Promise (List Symbol <r>))]))]
@chunk[<r>
(structure-supertype [field (λget-type-helper T other-fields …)])]
@section{Conclusion} @section{Conclusion}
@chunk[<module-main> @chunk[<module-main>
@ -108,19 +159,23 @@ otherwise throw an error:
"../lib/low.rkt" "../lib/low.rkt"
"structure.lp2.rkt" "structure.lp2.rkt"
"variant.lp2.rkt" "variant.lp2.rkt"
"graph3.lp2.rkt") "graph3.lp2.rkt"
(provide get) "../type-expander/type-expander.lp2.rkt")
(provide get
λget)
(begin-for-syntax (begin-for-syntax
<c*r-syntax-class>) <c…r-syntax-class>)
<get>)] <get>
<λget-type-helper>
<λget>)]
@chunk[<module-test> @chunk[<module-test>
(module* test typed/racket (module* test typed/racket
(require (submod "..") (require (submod "..")
typed/rackunit) typed/rackunit)
<test-get> <test-get>
(require (submod ".." doc)))] (require (submod ".." doc)))]

14
graph/graph/remember.rkt
View File

@ -55,3 +55,17 @@
(structure houses/with-promises-type sname/with-promises-type) (structure houses/with-promises-type sname/with-promises-type)
(structure houses sname) (structure houses sname)
(structure houses sname) (structure houses sname)
(structure f-a f-b)
(structure f-a f-b f-c)
(structure people)
(structure streets)
(structure location)
(structure streets)
(structure streets)
(structure x)
(structure x)
(structure x)
(structure sname)
(structure sname)
(structure sname)
(structure st)

37
graph/graph/structure.lp2.rkt
View File

@ -26,7 +26,7 @@ types, it wouldn't be clear what fields the remaining type parameters affect).
(define-syntax-class field-descriptor (define-syntax-class field-descriptor
(pattern (pattern
(~or field:id (~or field:id
[field:id (~maybe (~lit :) type:expr) (~maybe value:expr)]))))} [field:id (~maybe :colon type:expr) (~maybe value:expr)]))))}
A call to @tc[(structure)] with no field, is ambiguous: it could return a A call to @tc[(structure)] with no field, is ambiguous: it could return a
constructor function, or an instance. We added two optional keywords, constructor function, or an instance. We added two optional keywords,
@ -41,10 +41,10 @@ handle the empty structure as a special case.
(~seq #:constructor (~parse (field …) #'())) (~seq #:constructor (~parse (field …) #'()))
(~seq (~maybe #:constructor ~!) (~seq (~maybe #:constructor ~!)
(~or (~seq (~or-bug [field:id] field:id) …+) (~or (~seq (~or-bug [field:id] field:id) …+)
(~seq [field:id (~and C (~lit :)) type:expr] …+))) (~seq [field:id (~and C :colon) type:expr] …+)))
(~seq (~maybe #:instance ~!) (~seq (~maybe #:instance ~!)
(~or (~seq [field:id value:expr] …+) (~or (~seq [field:id value:expr] …+)
(~seq [field:id (~and C (~lit :)) type:expr (~seq [field:id (~and C :colon) type:expr
value:expr] …+))))))] value:expr] …+))))))]
@chunk[<structure> @chunk[<structure>
@ -236,7 +236,7 @@ one low-level @tc[struct] is generated for them.
(for/list ([s (remove-duplicates (map (λ (s) (sort s symbol<?)) (for/list ([s (remove-duplicates (map (λ (s) (sort s symbol<?))
(get-remembered 'structure)))] (get-remembered 'structure)))]
[i (in-naturals)]) [i (in-naturals)])
`(,(string->symbol (format "struct-~a" i)) . ,s)))] `(,(string->symbol (~a `(structure ,(~a "#|" i "|#") . ,s))) . ,s)))]
We will also need utility functions to sort the fields when querying this We will also need utility functions to sort the fields when querying this
associative list. associative list.
@ -310,6 +310,7 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
(stx-map sort-fields #'((all-field …) …))) (stx-map sort-fields #'((all-field …) …)))
(define/with-syntax ([[sorted-field sorted-pat …] …] …) (define/with-syntax ([[sorted-field sorted-pat …] …] …)
(stx-map (curry stx-map (stx-map (curry stx-map
;; TODO: add (_ _ …) for the not-matched fields.
(λ (x) (multiassoc-syntax x #'([field pat …] …)))) (λ (x) (multiassoc-syntax x #'([field pat …] …))))
#'((sorted-field1 …) …))) #'((sorted-field1 …) …)))
#'(or (name (and sorted-field sorted-pat …) …) …))] #'(or (name (and sorted-field sorted-pat …) …) …))]
@ -317,10 +318,30 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
@chunk[<structure-supertype> @chunk[<structure-supertype>
(define-multi-id structure-supertype (define-multi-id structure-supertype
#:type-expander #:type-expander
(λ/syntax-parse (_ field:id …) (λ/syntax-parse (_ [field:id type:expr] …)
#`(U #,@(map cdr (fields→supertypes #'(field …))))) (define/with-syntax ([(all-field …) . _] …)
(fields→supertypes #'(field …)))
(template
(U (structure
[all-field : (tmpl-cdr-assoc-syntax #:default Any
all-field [field . type] …)]
…)
…)))
#:match-expander <structure-supertype-match-expander>)] #:match-expander <structure-supertype-match-expander>)]
@chunk[<structure-supertype*>
(define-multi-id structure-supertype*
#:type-expander
(λ (stx)
(syntax-parse stx
[(_ T:expr)
#`T]
[(_ T:expr field:id other-fields:id …)
#`(structure-supertype
[field (structure-supertype* T other-fields …)])]))
;#:match-expander <structure-supertype-match-expander> ; TODO
)]
@chunk[<fields→supertypes> @chunk[<fields→supertypes>
(define-for-syntax (fields→supertypes stx-fields) (define-for-syntax (fields→supertypes stx-fields)
(with-syntax ([(field …) stx-fields]) (with-syntax ([(field …) stx-fields])
@ -583,7 +604,8 @@ chances that we could write a definition for that identifier.
structure-get structure-get
λstructure-get λstructure-get
structure structure
structure-supertype) structure-supertype
structure-supertype*)
(begin-for-syntax (begin-for-syntax
(provide structure-args-stx-class)) (provide structure-args-stx-class))
@ -607,6 +629,7 @@ chances that we could write a definition for that identifier.
<syntax-class-for-match> <syntax-class-for-match>
<structure-supertype> <structure-supertype>
<structure-supertype*>
<match-expander> <match-expander>
<type-expander> <type-expander>

20
graph/lib/low/multiassoc-syntax.rkt
View File

@ -8,16 +8,28 @@
cdr-assoc-syntax cdr-assoc-syntax
tmpl-cdr-assoc-syntax) tmpl-cdr-assoc-syntax)
(require "../low.rkt") ;; For the identifier "…"
;; TODO: cdr-stx-assoc is already defined in lib/low.rkt
(define (multiassoc-syntax query alist) (define (multiassoc-syntax query alist)
(map stx-cdr (map stx-cdr
(filter (λ (xy) (free-identifier=? query (stx-car xy))) (filter (λ (xy) (free-identifier=? query (stx-car xy)))
(syntax->list alist)))) (syntax->list alist))))
(define (cdr-assoc-syntax query alist) (define (cdr-assoc-syntax query alist)
(stx-cdr (findf (λ (xy) (free-identifier=? query (stx-car xy))) (stx-cdr (assoc-syntax query alist)))
(syntax->list alist))))
(define (assoc-syntax query alist)
(findf (λ (xy) (free-identifier=? query (stx-car xy)))
(syntax->list alist)))
(define-template-metafunction (tmpl-cdr-assoc-syntax stx) (define-template-metafunction (tmpl-cdr-assoc-syntax stx)
(syntax-parse stx (syntax-parse stx
[(_ query [k . v] …) [(_ (~optional (~seq #:default default)) query [k . v] …)
(cdr-assoc-syntax #'query #'([k . v] …))])) (if (attribute default)
(let ([r (assoc-syntax #'query #'([k . v] …))])
(if r
(stx-cdr r)
#'default))
(cdr-assoc-syntax #'query #'([k . v] …)))]))

158
graph/type-expander/type-expander.lp2.rkt
View File

@ -30,8 +30,8 @@ Match expanders are identified by the @tc[prop:type-expander]
get-prop:type-expander-value) get-prop:type-expander-value)
(make-struct-type-property 'type-expander prop-guard))] (make-struct-type-property 'type-expander prop-guard))]
The prop:type-expander property should either be the index of a field which will The @tc[prop:type-expander] property should either be the index of a field which
contain the expander procedure, or directly an expander procedure. will contain the expander procedure, or directly an expander procedure.
@chunk[<prop-guard> @chunk[<prop-guard>
(define (prop-guard val struct-type-info-list) (define (prop-guard val struct-type-info-list)
@ -101,12 +101,25 @@ else.
(define-syntax-class type-expander (define-syntax-class type-expander
(pattern (~var expander (pattern (~var expander
(static has-prop:type-expander? "a type expander")))) (static has-prop:type-expander? "a type expander"))))
(define-syntax-class type-expander-nested-application
#:attributes (expanded-once)
(pattern (~and expander-call-stx (:type-expander . args))
#:with expanded-once
(apply-type-expander #'expander #'expander-call-stx))
(pattern (nested-application:type-expander-nested-application
. args) ;; TODO: test
#:with expanded-once
#'(nested-application.expanded-once . args)))
(define-syntax-class fa (pattern (~or (~literal ∀) (~literal All)))) (define-syntax-class fa (pattern (~or (~literal ∀) (~literal All))))
(syntax-parse stx (syntax-parse stx
[:type-expander [:type-expander
(expand-type (apply-type-expander #'expander #'expander))] (expand-type (apply-type-expander #'expander #'expander))]
[(~and expander-call-stx (:type-expander . args)) [:type-expander-nested-application
(expand-type (apply-type-expander #'expander #'expander-call-stx))] (expand-type #'expanded-once)]
;; TODO: find a more elegant way to write anonymous type expanders
[(((~literal curry) T Arg1 …) . Args2)
(expand-type #'(T Arg1 … . Args2))]
;; TODO: handle the pattern (∀ (TVar ... ooo) T) ;; TODO: handle the pattern (∀ (TVar ... ooo) T)
[(∀:fa (TVar ...) T) [(∀:fa (TVar ...) T)
#`(∀ (TVar ...) #,(expand-type (bind-type-vars #'(TVar ...) #'T)))] #`(∀ (TVar ...) #,(expand-type (bind-type-vars #'(TVar ...) #'T)))]
@ -117,8 +130,6 @@ else.
[((~literal syntax) T) (expand-quasiquote 'syntax 1 #'T)] [((~literal syntax) T) (expand-quasiquote 'syntax 1 #'T)]
[((~literal quasisyntax) T) (expand-quasiquote 'quasisyntax 1 #'T)] [((~literal quasisyntax) T) (expand-quasiquote 'quasisyntax 1 #'T)]
[((~literal Struct) T) [((~literal Struct) T)
(display #'(Struct T))
(displayln #`(Struct #,(expand-type #'(T))))
#`(Struct #,(expand-type #'T))] #`(Struct #,(expand-type #'T))]
[(T TArg ...) [(T TArg ...)
#`(T #,@(stx-map expand-type #'(TArg ...)))] #`(T #,@(stx-map expand-type #'(TArg ...)))]
@ -161,6 +172,28 @@ identifier.
(test-expander (∀ (A) (→ A (id (double (id A))))) (test-expander (∀ (A) (→ A (id (double (id A)))))
(∀ (A) (→ A (Pairof A A))))] (∀ (A) (→ A (Pairof A A))))]
Curry expander arguments:
@CHUNK[<test-expand-type>
(define-type-expander (CPairof stx)
(syntax-case stx ()
[(_ a) #'(curry Pairof a)]
[(_ a b) #'(Pairof a b)]))
(test-expander (CPairof Number String)
(Pairof Number String))
(test-expander ((CPairof Number) String)
(Pairof Number String))
(check-equal?: (ann (ann '(1 . "b") (CPairof Number String))
(Pairof Number String))
'(1 . "b"))
(check-equal?: (ann (ann '(1 . "c") ((CPairof Number) String))
(Pairof Number String))
'(1 . "c"))]
Shadowing and @tc[∀] variables: Shadowing and @tc[∀] variables:
@CHUNK[<test-expand-type> @CHUNK[<test-expand-type>
@ -449,10 +482,10 @@ them.
: `(2 "abc" #,,(Pairof (U 'x 'y) (U 'y 'z)) #(1 "b" x) d) : `(2 "abc" #,,(Pairof (U 'x 'y) (U 'y 'z)) #(1 "b" x) d)
'(2 "abc" #,(x . z) #(1 "b" x) d)) '(2 "abc" #,(x . z) #(1 "b" x) d))
(check-equal?: (ann d0 (List 2 (check-equal?: (ann d0 (List 2
"abc" "abc"
(List 'unsyntax (Pairof (U 'x 'y) (U 'y 'z))) (List 'unsyntax (Pairof (U 'x 'y) (U 'y 'z)))
(Vector 1 "b" 'x) 'd)) (Vector 1 "b" 'x) 'd))
'(2 "abc" (unsyntax (x . z)) #(1 "b" x) d)) '(2 "abc" (unsyntax (x . z)) #(1 "b" x) d))
(: d1 (→ Number (→ Number Number))) (: d1 (→ Number (→ Number Number)))
(define ((d1 [x : Number]) [y : Number]) : Number (+ x y)) (define ((d1 [x : Number]) [y : Number]) : Number (+ x y))
@ -480,13 +513,13 @@ them.
@CHUNK[<test-lambda> @CHUNK[<test-lambda>
(check-equal?: ((ann (lambda ([x : Number]) : Number (* x 2)) (check-equal?: ((ann (lambda ([x : Number]) : Number (* x 2))
(→ Number Number)) (→ Number Number))
3) 3)
6) 6)
(check-equal?: ((ann (λ ([x : Number]) : Number (* x 2)) (check-equal?: ((ann (λ ([x : Number]) : Number (* x 2))
(→ Number Number)) (→ Number Number))
3) 3)
6) 6)
(check-equal?: ((λ x x) 1 2 3) '(1 2 3)) (check-equal?: ((λ x x) 1 2 3) '(1 2 3))
(check-equal?: ((λ #:∀ (A) [x : A ...*] : (Listof A) x) 1 2 3) '(1 2 3))] (check-equal?: ((λ #:∀ (A) [x : A ...*] : (Listof A) x) 1 2 3) '(1 2 3))]
@ -609,7 +642,7 @@ them.
(check-equal?: (cdr ((se1 123) 'b)) 'b) (check-equal?: (cdr ((se1 123) 'b)) 'b)
(check-not-exn (λ () (ann (car ((se1 123) 'b)) se1))) (check-not-exn (λ () (ann (car ((se1 123) 'b)) se1)))
(check-true (se1? (car ((se1 123) 'b)))) (check-true (se1? (car ((se1 123) 'b))))
(check (λ (a b) (not (equal? a b))) (se2 2 3) (se2 2 3)) (check (λ (a b) (not (equal? a b))) (se2 2 3) (se2 2 3))
(check-equal?: (se2-x (se2 2 3)) 2) (check-equal?: (se2-x (se2 2 3)) 2)
(check-equal?: (se2-y (se2 2 3)) 3) (check-equal?: (se2-y (se2 2 3)) 3)
@ -618,7 +651,7 @@ them.
(check-equal?: (cdr ((se2 2 3) 'c)) 'c) (check-equal?: (cdr ((se2 2 3) 'c)) 'c)
(check-not-exn (λ () (ann (car ((se2 2 3) 'c)) se2))) (check-not-exn (λ () (ann (car ((se2 2 3) 'c)) se2)))
(check-true (se2? (car ((se2 2 3) 'c)))) (check-true (se2? (car ((se2 2 3) 'c))))
(check (λ (a b) (not (equal? a b))) (se3 4 5 "f") (se3 4 5 "f")) (check (λ (a b) (not (equal? a b))) (se3 4 5 "f") (se3 4 5 "f"))
(check-equal?: (se2-x (se3 4 5 "f")) 4) (check-equal?: (se2-x (se3 4 5 "f")) 4)
(check-equal?: (se2-y (se3 4 5 "f")) 5) (check-equal?: (se2-y (se3 4 5 "f")) 5)
@ -626,10 +659,10 @@ them.
(check-equal?: (se2-x (car ((se3 4 5 "f") 'd 'e))) 4) (check-equal?: (se2-x (car ((se3 4 5 "f") 'd 'e))) 4)
(check-equal?: (se2-y (car ((se3 4 5 "f") 'd 'e))) 5) (check-equal?: (se2-y (car ((se3 4 5 "f") 'd 'e))) 5)
(check-equal?: (let ([ret : Any (car ((se3 4 5 "f") 'd 'e))]) (check-equal?: (let ([ret : Any (car ((se3 4 5 "f") 'd 'e))])
(if (se3? ret) (if (se3? ret)
(se3-z ret) (se3-z ret)
"wrong type!")) "wrong type!"))
"f") "f")
(check-equal?: (cadr ((se3 4 5 "f") 'd 'e)) 'd) (check-equal?: (cadr ((se3 4 5 "f") 'd 'e)) 'd)
(check-equal?: (caddr ((se3 4 5 "f") 'd 'e)) 'e) (check-equal?: (caddr ((se3 4 5 "f") 'd 'e)) 'e)
(check-equal?: ((caddr ((se4 4 5 "f") 'd (λ ([x : Number]) (* x 2)))) 12) (check-equal?: ((caddr ((se4 4 5 "f") 'd (λ ([x : Number]) (* x 2)))) 12)
@ -651,9 +684,9 @@ them.
[(_ t n) #`(List #,@(map (λ (x) #'t) [(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))])) (range (syntax->datum #'n))))]))
(check-equal?: (ann (ann '(1 2 3) (check-equal?: (ann (ann '(1 2 3)
(Repeat Number 3)) (Repeat Number 3))
(List Number Number Number)) (List Number Number Number))
'(1 2 3)))] '(1 2 3)))]
@subsection{@racket[inst]} @subsection{@racket[inst]}
@ -676,13 +709,13 @@ them.
(define (f x y) (list (car x) (car y) (cdr x) (cdr y))) (define (f x y) (list (car x) (car y) (cdr x) (cdr y)))
(check-equal?: ((inst f (check-equal?: ((inst f
(Repeat Number 3) (Repeat Number 3)
(Repeat String 2) (Repeat String 2)
(Repeat 'x 1) (Repeat 'x 1)
(Repeat undefined-type 0)) (Repeat undefined-type 0))
'((1 2 3) . ("a" "b")) '((1 2 3) . ("a" "b"))
'((x) . ())) '((x) . ()))
'((1 2 3) (x) ("a" "b") ())))] '((1 2 3) (x) ("a" "b") ())))]
@subsection{@racket[let]} @subsection{@racket[let]}
@ -710,10 +743,10 @@ them.
2) 2)
(check-equal?: (let () 'x) 'x) (check-equal?: (let () 'x) 'x)
(check-equal?: (ann (let #:∀ (T) ([a : T 3] (check-equal?: (ann (let #:∀ (T) ([a : T 3]
[b : (Pairof T T) '(5 . 7)]) [b : (Pairof T T) '(5 . 7)])
(cons a b)) (cons a b))
(Pairof Number (Pairof Number Number))) (Pairof Number (Pairof Number Number)))
'(3 5 . 7))] '(3 5 . 7))]
@subsection{@racket[let*]} @subsection{@racket[let*]}
@ -735,9 +768,9 @@ them.
(range (syntax->datum #'n))))])) (range (syntax->datum #'n))))]))
(check-equal?: (let* ([x* : (Repeat Number 3) '(1 2 3)] (check-equal?: (let* ([x* : (Repeat Number 3) '(1 2 3)]
[y* : (Repeat Number 3) x*]) [y* : (Repeat Number 3) x*])
y*) y*)
'(1 2 3)))] '(1 2 3)))]
@subsection{@racket[let-values]} @subsection{@racket[let-values]}
@ -759,25 +792,25 @@ them.
(range (syntax->datum #'n))))])) (range (syntax->datum #'n))))]))
(check-equal?: (ann (let-values (check-equal?: (ann (let-values
([([x : (Repeat Number 3)]) ([([x : (Repeat Number 3)])
(list 1 2 3)]) (list 1 2 3)])
(cdr x)) (cdr x))
(List Number Number)) (List Number Number))
'(2 3)) '(2 3))
(check-equal?: (ann (let-values (check-equal?: (ann (let-values
([([x : (Repeat Number 3)] [y : Number]) ([([x : (Repeat Number 3)] [y : Number])
(values (list 1 2 3) 4)]) (values (list 1 2 3) 4)])
(cons y x)) (cons y x))
(Pairof Number (List Number Number Number))) (Pairof Number (List Number Number Number)))
'(4 . (1 2 3))) '(4 . (1 2 3)))
(check-equal?: (ann (let-values (check-equal?: (ann (let-values
([(x y) ([(x y)
(values (list 1 2 3) 4)]) (values (list 1 2 3) 4)])
(cons y x)) (cons y x))
(Pairof Number (List Number Number Number))) (Pairof Number (List Number Number Number)))
'(4 . (1 2 3))))] '(4 . (1 2 3))))]
@subsection{@racket[make-predicate]} @subsection{@racket[make-predicate]}
@ -945,17 +978,18 @@ To get around that problem, we define @tc[:] in a separate module, and
Since our @tc[new-:] macro needs to call the @tc[type-expander], and the other Since our @tc[new-:] macro needs to call the @tc[type-expander], and the other
forms too, we can't define @tc[type-expander] in the same module as these forms, forms too, we can't define @tc[type-expander] in the same module as these forms,
it needs to be either in the same module as @tc[new-:], or in a separate module. it needs to be either in the same module as @tc[new-:], or in a separate module.
Additionally, expand-type needs to be required @tc[for-syntax] by the forms, but Additionally, @tc[expand-type] needs to be required @tc[for-syntax] by the
needs to be @tc[provide]d too, so it is much easier if it is defined in a forms, but needs to be @tc[provide]d too, so it is much easier if it is defined
separate module (that should be used only @tc[for-syntax], so it will be written in a separate module (that will be used only by macros, so it will be written in
in @tc[racket], not @tc[typed/racket]). @tc[racket], not @tc[typed/racket]).
@chunk[<module-expander> @chunk[<module-expander>
(module expander racket (module expander racket
(require racket (require racket
syntax/parse syntax/parse
syntax/stx syntax/stx
racket/format) racket/format
"../lib/low-untyped.rkt")
(require (for-template typed/racket)) (require (for-template typed/racket))
@ -1013,7 +1047,7 @@ We can finally define the overloaded forms, as well as the extra
(begin-for-syntax (begin-for-syntax
<template-metafunctions> <template-metafunctions>
<syntax-classes> <syntax-classes>
(provide colon)) (provide colon))
<define-type> <define-type>
@ -1041,7 +1075,7 @@ And, last but not least, we will add a @tc[test] module.
"../lib/low-untyped.rkt")) "../lib/low-untyped.rkt"))
<test-expand-type> <test-expand-type>
#| #|
<test-:> <test-:>
<test-define-type> <test-define-type>
@ -1050,7 +1084,7 @@ And, last but not least, we will add a @tc[test] module.
|# |#
;<test-struct> ;<test-struct>
<test-define-struct/exec> <test-define-struct/exec>
#| #|
<test-ann> <test-ann>
<test-inst> <test-inst>
<test-let> <test-let>