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

Fixed tests, cleanup, fixed missing (provide (for-syntax racket/base)) in #lang lib.rkt

Browse Source
This commit is contained in:
Georges Dupéron 2016-04-04 20:15:19 +02:00
parent 30a78bdaa3
commit b011a804c6
14 changed files with 540 additions and 597 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
graph-lib/graph/__DEBUG_graph6.rkt
View File

@ -3,7 +3,6 @@
(module test-~>-bound typed/racket
(require "graph-6-rich-returns.lp2.rkt"
"../lib/low.rkt"
;"graph.lp2.rkt"
"get.lp2.rkt"
"../type-expander/type-expander.lp2.rkt")
@ -46,8 +45,10 @@
(module test-~>-unbound typed/racket
(require "graph-6-rich-returns.lp2.rkt"
(only-in "../lib/low.rkt"
check-equal?:
…)
"get.lp2.rkt"
typed/rackunit
"../type-expander/type-expander.lp2.rkt")
(define-type blob String)
@ -66,10 +67,10 @@
: (Listof Street)
(map Street snames)])
(check-equal? (let ([l (grr3 '(("a" "b" "c") ("d")))])
(list (get (car l) streets … sname)
(get (cadr l) streets … sname)))
'(("a" "b" "c") ("d")))
(check-equal?: (let ([l (grr3 '(("a" "b" "c") ("d")))])
(list (get (car l) streets … sname)
(get (cadr l) streets … sname)))
'(("a" "b" "c") ("d")))
;; Check that there are no collisions:
;; Same as above with just the graph name changed
@ -88,4 +89,4 @@
(module test typed/racket
(require (submod ".." test-~>-bound))
(require (submod ".." test-~>-unbound)))
(require (submod ".." test-~>-unbound)))

2
graph-lib/graph/adt-test.rkt
View File

@ -5,6 +5,8 @@
(require "adt.lp2.rkt")
(require "../lib/low.rkt")
(require "../type-expander/type-expander.lp2.rkt")
(define-tagged st2 [b String] [a Number])
((tagged t a b c) 1 'b "c")
((tagged t a [b] c) 1 'b "c")

58
graph-lib/graph/graph-fallback-types.rkt Normal file
View File

@ -0,0 +1,58 @@
#lang s-exp "../lib.rkt"
;; Tests with incomplete / outer-incomplete type-expander.
(define-type-expander (outer-incomplete stx)
(syntax-case stx ()
[(_ n)
#;(raise-syntax-error
'incomplete
(format "Type doesn't have an incomplete counterpart: ~a"
(syntax->datum #'n))
#'n)
;; Just for testing:
#''test]))
(define-type C Boolean)
(define-type C/incomplete (Pairof 'C Boolean))
(define-type-expander (incomplete stx)
(syntax-case stx ()
[(_ n)
(cond [(free-identifier=? #'n #'C) #'C/incomplete]
[else #'(outer-incomplete n)])]))
(let ()
(define-type-expander (outer-incomplete stx)
(syntax-case stx () [(_ n) #'(incomplete n)]))
(let ()
(define-type A Number)
(define-type B String)
(define-type A/incomplete (Pairof 'A Number))
(define-type B/incomplete (Pairof 'B String))
(define-type-expander (incomplete stx)
(syntax-case stx ()
[(_ n)
(cond [(free-identifier=? #'n #'A) #'A/incomplete]
[(free-identifier=? #'n #'B) #'B/incomplete]
[else
#'(outer-incomplete n)])]))
(define-type TA A)
(define-type TAI (incomplete A))
(ann '(A . 1) TAI)
(define-type TC C)
(define-type TCI (incomplete C))
(ann #t TC)
(ann '(C . #t) TCI)
(let ()
(define-type A Boolean)
(define-type TA A)
(define-type TAI (incomplete A))
(ann 'test TAI)
(void))))

4
graph-lib/graph/graph.lp2.rkt
View File

@ -843,9 +843,7 @@ We will be able to use this type expander in function types, for example:
;(begin-for-syntax
;<multiassoc-syntax>)
(provide define-graph
define-graph-second-step ; DEBUG
)
(provide define-graph)
<first-step>
<second-step>)]

8
graph-lib/graph/remember.rkt
View File

@ -183,3 +183,11 @@
(structure sym)
(structure ctr water)
(structure ctr water)
(constructor . ma)
(constructor . mb)
(constructor . st2)
(structure f1a f2a)
(structure f1b)
(structure f1a f2a)
(structure f1b)
(structure f1a f2a)

5
graph-lib/graph/tagged-test.rkt
View File

@ -16,4 +16,7 @@
[z 'z]
[y Fixnum]))
[(tagged foo z x y) (list z y x)])
'(z 3 "o")))
'(z 3 "o"))
(define-type ma (tagged ma (fav String) (faa ma) (fab mb)))
(define-type mb (tagged mb (fbv String) (fba ma))))

6
graph-lib/lib.rkt
View File

@ -11,7 +11,8 @@
"type-expander/multi-id.lp2.rkt"
"type-expander/type-expander.lp2.rkt"
"graph/adt.lp2.rkt"
"graph/graph.lp2.rkt"
;"graph/graph.lp2.rkt"
"graph/graph-6-rich-returns.lp2.rkt"
"graph/get.lp2.rkt"
"graph/map.rkt"
#|"graph/rewrite-type.lp2.rkt"|#)
@ -20,3 +21,6 @@
"type-expander/type-expander.lp2.rkt"))
(provide (all-from-out "graph/dotlang.rkt"))
(require (for-syntax racket/base))
(provide (for-syntax (all-from-out racket/base)))

2
graph-lib/lib/low/syntax-parse.rkt
View File

@ -9,7 +9,7 @@
(define-syntax-parameter stx
(lambda (call-stx)
(raise-syntax-error
(syntax-e call-stx)
'stx
"Can only be used in define-syntax/parse or λ/syntax-parse"
call-stx))))

168
graph-lib/main.rkt
View File

@ -1,168 +1,4 @@
#lang s-exp "lib.rkt"
#|
(require (submod "graph/test-map-get.rkt" test))
(require (submod "graph/dotlang.rkt" test))
(require "type-expander/type-expander.lp2.rkt")
(require "type-expander/multi-id.lp2.rkt")
(require "graph/adt.lp2.rkt")
|#
#|
(define-type from (List (Pairof Number Boolean) (Listof Number)))
(define-type to (List (Pairof String Boolean) (Listof String)))
(: convert (case→ (→ from to)
(→ (Pairof (Listof Number) Null)
(Pairof (Listof String) Null))
(→ (Pairof Number Boolean) (Pairof String Boolean))
(→ (Listof Number) (Listof String))
(→ Number String)
(→ Boolean Boolean)))
(define (convert v)
(cond
[(pair? v) (cons (convert (car v)) (convert (cdr v)))]
[(null? v) v]
[(number? v) (format "~a" v)]
[(boolean? v) v]))
|#
;; Tests with incomplete / outer-incomplete type-expander.
(define-type-expander (outer-incomplete stx)
(syntax-case stx ()
[(_ n)
#;(raise-syntax-error
'incomplete
(format "Type doesn't have an incomplete counterpart: ~a"
(syntax->datum #'n))
#'n)
;; Just for testing:
#''test]))
(define-type C Boolean)
(define-type C/incomplete (Pairof 'C Boolean))
(define-type-expander (incomplete stx)
(syntax-case stx ()
[(_ n)
(cond [(free-identifier=? #'n #'C) #'C/incomplete]
[else #'(outer-incomplete n)])]))
(let ()
(define-type-expander (outer-incomplete stx)
(syntax-case stx () [(_ n) #'(incomplete n)]))
(let ()
(define-type A Number)
(define-type B String)
(define-type A/incomplete (Pairof 'A Number))
(define-type B/incomplete (Pairof 'B String))
(define-type-expander (incomplete stx)
(syntax-case stx ()
[(_ n)
(cond [(free-identifier=? #'n #'A) #'A/incomplete]
[(free-identifier=? #'n #'B) #'B/incomplete]
[else
#'(outer-incomplete n)])]))
(define-type TA A)
(define-type TAI (incomplete A))
(ann '(A . 1) TAI)
(define-type TC C)
(define-type TCI (incomplete C))
(ann #t TC)
(ann '(C . #t) TCI)
(let ()
(define-type A Boolean)
(define-type TA A)
(define-type TAI (incomplete A))
(ann 'test TAI)
(void))))
(require (prefix-in tr: typed/racket))
;(define-type ma (tagged ma (fav String) (faa ma) (fab mb)))
;(define-type mb (tagged mb (fbv String) (fba ma)))
;(define-type ma (List (U ma Number) (U ma Number)) #:omit-define-syntaxes)
;(define-multi-id ma
; #:match-expander (λ (stx) #'(list a b))
; #:call (λ (stx) #'(list 1 (list 2 3))))
;(match (ann (ma) ma)
; [(ma) #t])
#|
(module m typed/racket
(provide ma)
(require "type-expander/type-expander.lp2.rkt")
(require "graph/adt.lp2.rkt")
;(let ()
;(define-tagged ma (fav String))
;(define-tagged ma (fav String) (faa ma) (fab mb))
(define-tagged ma (fav String) (faa ma) (fab Number))
;(define-tagged mb (fbv String) (fba ma))
(define-type ma/incomplete ma)
;(define-type mb/incomplete mb)
(void);)
)
(require 'm)
|#
#|
(require "graph/graph.rkt")
(define ma "boom")
(graph g
[ma (fav String)
(faa ma)
(fab mb)]
[mb (fbv String)
(fba ma)])
(define mb "boom")
|#
#|
(require typed/rackunit)
;(require "graph/structure.lp2.rkt")
;(get ((make-struct-constructor a b c d) 1 "b" 'value-c 4) c)
(require "type-expander/type-expander.lp2.rkt")
(: w0 `(2 "abc" #,,(Pairof (U 'x 'y) (U 'y 'z)) #(1 "b" x) d))
(define w0 '(2 "abc" #,(x . z) #(1 "b" x) d))
(require (for-syntax racket/list))
(define-type-expander (Repeat stx)
(syntax-case stx ()
[(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))]))
(: x (→ (Repeat Number 5)))
(define (x) (list 1 2 3 4 5))
(check-equal? (x) '(1 2 3 4 5))
(require "graph/structure.lp2.rkt")
(define-structure st2 [b String] [a Number])
(module* test typed/racket
(require (submod "..")))
|#
;; Nothing yet.
(void)

19
graph-lib/test/2016-04-04--node-names-are-private.rkt Normal file
View File

@ -0,0 +1,19 @@
#lang s-exp "../lib.rkt"
;; Should not cause name collisions
(define a "boom")
(define m-a "boom")
(define-graph g
([a (f1a : String) (f2a : (~> m-b))]
[b (f1b : String)])
[(m-a [v : String])
: a
(a v (m-b (string-append "b=" v)))]
[(m-b [v : String])
: b
(b v)])
;; Should not cause name collisions
;(define b "boom")
(define m-b "boom")

12
graph-lib/test/assumptions/2016-04-04--define-multi-id-leaves-type-intact.rkt Normal file
View File

@ -0,0 +1,12 @@
#lang s-exp "../../lib.rkt"
(require (for-syntax racket/base))
(define-type ma (List (U ma Number) (U ma Number)) #:omit-define-syntaxes)
(define-multi-id ma
#:match-expander (λ (stx) #'(list a b))
#:call (λ (stx) #'(list 1 (list 2 3))))
(check-equal?:
(match (ann (ma) ma)
[(ma) #t])
#t)

8
graph-lib/test/regression/2016-04-04--require-racket-base-in-lang.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang s-exp "../../lib.rkt"
(module test "../../lib.rkt"
(define-syntax (t stx)
;; `+` and other identifiers from racket/base should be available here.
#`#,(+ 1 2))
(check-equal?: (t) 3))

411
graph-lib/type-expander/type-expander-test.rkt Normal file
View File

@ -0,0 +1,411 @@
#lang typed/racket
(module test typed/racket
(require "type-expander.lp2.rkt"
;(submod "type-expander.lp2.rkt" test)
typed/rackunit
"../lib/low.rkt"
(for-syntax (submod "type-expander.lp2.rkt" expander)
racket/list
(submod "../lib/low.rkt" untyped)))
; Tests for expand-type
(begin
;; Test harness:
(begin
(require (for-syntax typed/rackunit
syntax/parse))
(define-syntax (test-expander stx)
(syntax-parse stx
[(_ type expanded-type)
(check-equal? (syntax->datum (expand-type #'type))
(syntax->datum #'expanded-type))
#'(values)])))
; Simple identity expander test, with a different case when used just as an
; identifier.
(begin
(define-type-expander (id stx)
(syntax-case stx ()
[(_ t) #'t]
[x #'(∀ (A) (→ A A))]))
(test-expander (id Number) Number)
(test-expander id (∀ (A) (→ A A))))
(begin
(define-type-expander (double stx)
(syntax-case stx ()
[(_ t) #'(id (Pairof (id t) t))]))
(test-expander (∀ (A) (→ A (id (double (id A)))))
(∀ (A) (→ A (Pairof A A))))
(test-expander (→ Any Boolean : (double (id A)))
(→ Any Boolean : (Pairof A A))))
;; Curry expander arguments:
(begin
(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 with ∀ variables:
(begin
(test-expander (∀ (id) (→ id))
(∀ (id) (→ id)))
(test-expander (∀ (id2) (→ id))
(∀ (id2) (→ (∀ (A) (→ A A))))))
(begin
(define-type-expander (Repeat stx)
(syntax-case stx ()
[(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))]))
(test-expander (Repeat Number 5)
(List Number Number Number Number Number)))
(begin
(: count-five-more (→ Number (Repeat Number 5)))
(define (count-five-more x)
(list (+ x 1) (+ x 2) (+ x 3) (+ x 4) (+ x 5)))
(check-equal?: (count-five-more 3)
'(4 5 6 7 8))
(check-equal?: (ann (count-five-more 15) (Repeat Number 5))
'(16 17 18 19 20)))
;; Shadowing with Rec variables:
(begin
(: repeat-shadow (→ Number (Rec Repeat (U Null (List Number Repeat)))))
(define (repeat-shadow n)
(if (= n 0)
'()
(list n (repeat-shadow (sub1 n)))))
(check-equal?: (repeat-shadow 5)
'(5 (4 (3 (2 (1 ()))))))
(test-expander (→ Number (Rec Repeat (U Null (List Number Repeat))))
(→ Number (Rec Repeat (U Null (List Number Repeat))))))
;; Shadowing with Let:
(begin
(let ()
(define-type-expander (exp stx)
#'(List 1 2 3))
(define-type e String)
(: x (List e (Let [e exp] e)))
(define x (list "e1" (list 1 2 3)))
(check-equal?: x '("e1" (1 2 3)))
(test-expander (List e (Let [e exp] e))
(List e (List 1 2 3)))
(: y (List e))
(define y (list "e2"))
(check-equal?: y '("e2"))
(test-expander (List e)
(List e))
(void))))
;; Test ":"
(begin
(: c0 `(2 "abc" #,,(Pairof (U 'x 'y) (U 'y 'z)) #(1 "b" x) d))
(define c0 '(2 "abc" #,(x . z) #(1 "b" x) d))
(let ()
(define-type-expander (Repeat stx)
(syntax-case stx ()
[(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))]))
(: x (→ (Repeat Number 5)))
(define (x) (list 1 2 3 4 5))
(check-equal? (x) '(1 2 3 4 5))))
;; Test define-type
(let ()
(define-type-expander (Repeat stx)
(syntax-case stx ()
[(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))]))
(define-type R5 (Repeat Number 5))
(check-equal?: (ann '(1 2 3 4 5) R5) '(1 2 3 4 5)))
;; Test define
(begin
(define d0
: `(2 "abc" #,,(Pairof (U 'x 'y) (U 'y 'z)) #(1 "b" x) d)
'(2 "abc" #,(x . z) #(1 "b" x) d))
(check-equal?: (ann d0 (List 2
"abc"
(List 'unsyntax
(Pairof (U 'x 'y) (U 'y 'z)))
(Vector 1 "b" 'x) 'd))
'(2 "abc" (unsyntax (x . z)) #(1 "b" x) d))
(: d1 (→ Number (→ Number Number)))
(define ((d1 [x : Number]) [y : Number]) : Number (+ x y))
(check-equal?: (ann ((d1 2) 3) Number) 5)
(: d2 (→ Number (→ Number Number)))
(define ((d2 [x : Number]) [y : Number]) (+ x y))
(check-equal?: (ann ((d2 3) 4) Number) 7)
(define #:∀ (T) ((d3 [x : T]) [y : T]) : (Pairof T T) (cons x y))
(check-equal?: (ann ((d3 'x) 'y) (Pairof Symbol Symbol)) '(x . y)))
;; Test lambda
(begin
(check-equal?: ((ann (lambda ([x : Number]) : Number (* x 2))
(→ Number Number))
3)
6)
(check-equal?: ((ann (λ ([x : Number]) : Number (* x 2))
(→ Number Number))
3)
6)
(check-equal?: ((λ x x) 1 2 3) '(1 2 3))
(check-equal?: ((λ #:∀ (A) [x : A ...*] : (Listof A) x) 1 2 3) '(1 2 3)))
;; Test struct
(begin
(struct s0 ())
(struct s1 ([x : Number]))
(struct s2 ([x : Number] [y : Number]))
(struct s3 ([x : Number] [y : Number]) #:transparent)
(struct s4 () #:transparent)
(struct (A B) s5 ([x : A] [y : B]) #:transparent)
(struct (A B) s6 () #:transparent)
(struct s7 s2 ([z : String]) #:transparent)
(struct (A) s8 s3 ([z : A]) #:transparent)
(struct (A B C) s9 s5 ([z : C]) #:transparent)
(struct (A B C) s10 s2 ([z : C]) #:transparent)
(struct (A B C) s11 s5 ([z : C]))
(check (λ (a b) (not (equal? a b))) (s0) (s0))
(check-equal?: (s1-x (s1 123)) 123)
(check-equal?: (s2-x (s2 2 3)) 2)
(check-equal?: (s2-y (s2 2 3)) 3)
(check-equal?: (s3-x (s3 4 5)) 4)
(check-equal?: (s3-y (s3 4 5)) 5)
(check-equal?: (s4) (s4))
(check-equal?: (s5-x (s5 6 7)) 6)
(check-equal?: (s5-y (s5 6 7)) 7)
(check-equal?: (s5 6 7) (s5 6 7))
(check-equal?: ((inst s5 Number String) 6 "g") (s5 6 "g"))
(check-equal?: (s6) (s6))
(check-equal?: ((inst s6 Number String)) (s6))
;(check-equal?: (s7-x (s7 -1 -2 "c") -1))
;(check-equal?: (s7-y (s7 -1 -2 "c") -2))
(check-equal?: (s7-z (s7 -1 -2 "c")) "c")
(check-equal?: (s2-x (s7 -1 -2 "c")) -1)
(check-equal?: (s2-y (s7 -1 -2 "c")) -2)
(check-not-equal?: (s7 -1 -2 "c") (s7 -1 -2 "c"))
(check-not-exn (λ () (ann (s7 -1 -2 "c") s2)))
(check-true (s2? (s7 -1 -2 "c")))
;(check-equal?: (s8-x (s8 -1 -2 "c") -1))
;(check-equal?: (s8-y (s8 -1 -2 "c") -2))
(check-equal?: (s8-z (s8 -1 -2 "c")) "c")
(check-equal?: (s3-x (s8 -1 -2 "c")) -1)
(check-equal?: (s3-y (s8 -1 -2 "c")) -2)
(check-equal?: (s8 -1 -2 "c") (s8 -1 -2 "c"))
(check-equal?: ((inst s8 String) -1 -2 "c") (s8 -1 -2 "c"))
(check-not-exn (λ () (ann ((inst s8 String) -1 -2 "c") s3)))
(check-true (s3? ((inst s8 String) -1 -2 "c")))
;(check-equal?: (s9-x (s9 8 9 10)) 8)
;(check-equal?: (s9-y (s9 8 9 10)) 9)
(check-equal?: (s9-z (s9 8 9 10)) 10)
(check-equal?: (s5-x (s9 8 9 10)) 8)
(check-equal?: (s5-y (s9 8 9 10)) 9)
(check-equal?: (s9 8 9 10) (s9 8 9 10))
;; Bug (to report)
;(check-not-exn (λ () (ann ((inst s9 Number Symbol String) 8 'i "j")
; (Struct s5))))
(check-not-exn (λ () (ann ((inst s9 Number Symbol String) 8 'i "j")
(s5 Number Symbol))))
(check-not-exn (λ () (ann ((inst s9 Number Symbol String) 8 'i "j")
(s5 Any Any))))
(check-true (s5? ((inst s9 Number Symbol String) -1 'i "j")))
(check-not-equal?: (s10 11 12 13) (s10 11 12 13))
(check-not-equal?: (s11 14 15 16) (s11 14 15 16)))
;; Test define-struct/exec
(begin
(define TODO '(bug in version 20160114-9498bdd
racket-6.4.0.1-i386-linux-precise.sh))
#|
(define-struct/exec se0 ()
;[(λ (self v) (cons self v)) : (∀ (A) (→ se0 A (Pairof se0 A)))])
[(λ (self v) (cons self v)) : (→ se0 Any (Pairof se0 Any))])
(define-struct/exec se1 ([x : Number])
;[(λ (self v) (cons self v)) : (∀ (A) (→ se0 A (Pairof se0 A)))])
[(λ (self v) (cons self v)) : (→ se1 Any (Pairof se1 Any))])
(define-struct/exec se2 ([x : Number] [y : Number])
[(λ (self v) (cons self v)) : (→ se2 Any (Pairof se2 Any))])
(define-struct/exec (se3 se2) ([z : String])
[(λ (self v w) (list self v w))
;: (∀ (A B) (→ se3 A B (List se2 A B)))])
: (→ se3 Any Any (List se2 Any Any))])
(define-struct/exec (se4 se2) ([z : String])
[(λ (self v w) (list self v w))
;: (∀ (A B) (→ se4 A B (List se2 A B)))])
: (→ se4 Any (→ Number Number) (List se2 Any (→ Number Number)))])
(check (λ (a b) (not (equal? a b))) (se0) (se0))
(check-equal?: (cdr ((se0) 'a)) 'a)
(check-not-exn (λ () (ann (car ((se0) 'a)) se0)))
(check-true (se0? (car ((se0) 'a))))
(check (λ (a b) (not (equal? a b))) (se1 123) (se1 123))
(check-equal?: (se1-x (se1 123)) 123)
(check-equal?: (se1-x (car ((se1 123) 'b))) 123)
(check-equal?: (cdr ((se1 123) 'b)) 'b)
(check-not-exn (λ () (ann (car ((se1 123) 'b)) se1)))
(check-true (se1? (car ((se1 123) 'b))))
(check (λ (a b) (not (equal? a b))) (se2 2 3) (se2 2 3))
(check-equal?: (se2-x (se2 2 3)) 2)
(check-equal?: (se2-y (se2 2 3)) 3)
(check-equal?: (se2-x (car ((se2 2 3) 'c))) 2)
(check-equal?: (se2-y (car ((se2 2 3) 'c))) 3)
(check-equal?: (cdr ((se2 2 3) 'c)) 'c)
(check-not-exn (λ () (ann (car ((se2 2 3) 'c)) se2)))
(check-true (se2? (car ((se2 2 3) 'c))))
(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-y (se3 4 5 "f")) 5)
(check-equal?: (se3-z (se3 4 5 "f")) "f")
(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?: (let ([ret : Any (car ((se3 4 5 "f") 'd 'e))])
(if (se3? ret)
(se3-z ret)
"wrong type!"))
"f")
(check-equal?: (cadr ((se3 4 5 "f") 'd 'e)) 'd)
(check-equal?: (caddr ((se3 4 5 "f") 'd 'e)) 'e)
(check-equal?: ((caddr ((se4 4 5 "f") 'd (λ ([x : Number]) (* x 2)))) 12)
24)
(check-not-exn (λ () (ann (car ((se3 4 5 "f") 'd 'e)) se2)))
(check-true (se2? (car ((se3 4 5 "f") 'd 'e))))
(check-true (se3? (car ((se3 4 5 "f") 'd 'e))))
|#)
;; Test ann
(let ()
(define-type-expander (Repeat stx)
(syntax-case stx ()
[(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))]))
(check-equal?: (ann (ann '(1 2 3)
(Repeat Number 3))
(List Number Number Number))
'(1 2 3)))
;; Test inst
(let ()
(define-type-expander (Repeat stx)
(syntax-case stx ()
[(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))]))
(: f (∀ (A B C D) (→ (Pairof A B) (Pairof C D) (List A C B D))))
(define (f x y) (list (car x) (car y) (cdr x) (cdr y)))
(check-equal?: ((inst f
(Repeat Number 3)
(Repeat String 2)
(Repeat 'x 1)
(Repeat undefined-type 0))
'((1 2 3) . ("a" "b"))
'((x) . ()))
'((1 2 3) (x) ("a" "b") ())))
;; Test let
(begin
(check-equal?: (let loop-id ([x 1])
(if (equal? x 2)
x
(loop-id 2)))
: Any
2)
(check-equal?: (let () 'x) 'x)
(check-equal?: (ann (let #:∀ (T) ([a : T 3]
[b : (Pairof T T) '(5 . 7)])
(cons a b))
(Pairof Number (Pairof Number Number)))
'(3 5 . 7)))
;; Test let*
(let ()
(define-type-expander (Repeat stx)
(syntax-case stx ()
[(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))]))
(check-equal?: (let* ([x* : (Repeat Number 3) '(1 2 3)]
[y* : (Repeat Number 3) x*])
y*)
'(1 2 3)))
;; Test let-values
(let ()
(define-type-expander (Repeat stx)
(syntax-case stx ()
[(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))]))
(check-equal?: (ann (let-values
([([x : (Repeat Number 3)])
(list 1 2 3)])
(cdr x))
(List Number Number))
'(2 3))
(check-equal?: (ann (let-values
([([x : (Repeat Number 3)] [y : Number])
(values (list 1 2 3) 4)])
(cons y x))
(Pairof Number (List Number Number Number)))
'(4 . (1 2 3)))
(check-equal?: (ann (let-values
([(x y)
(values (list 1 2 3) 4)])
(cons y x))
(Pairof Number (List Number Number Number)))
'(4 . (1 2 3))))
;; Test make-predicate>
(let ()
(define-type-expander (Repeat stx)
(syntax-case stx ()
[(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))]))
(check-equal?: ((make-predicate (Repeat Number 3)) '(1 2 3)) #t)
(check-equal?: ((make-predicate (Repeat Number 3)) '(1 "b" 3)) #f)))

419
graph-lib/type-expander/type-expander.lp2.rkt
View File

@ -190,125 +190,6 @@ else.
#`(define-syntax name
(type-expander #,(syntax/loc stx (λ (arg) . body)))))]
@subsection{Tests for @racket[expand-type]}
@CHUNK[<test-expand-type>
(require (for-syntax typed/rackunit
syntax/parse))
(define-syntax (test-expander stx)
(syntax-parse stx
[(_ type expanded-type)
(check-equal? (syntax->datum (expand-type #'type))
(syntax->datum #'expanded-type))
#'(values)]))]
Simple identity expander test, with a different case when used just as an
identifier.
@CHUNK[<test-expand-type>
(define-type-expander (id stx)
(syntax-case stx ()
[(_ t) #'t]
[x #'(∀ (A) (→ A A))]))
(test-expander (id Number) Number)
(test-expander id (∀ (A) (→ A A)))]
@CHUNK[<test-expand-type>
(define-type-expander (double stx)
(syntax-case stx ()
[(_ t) #'(id (Pairof (id t) t))]))
(test-expander (∀ (A) (→ A (id (double (id A)))))
(∀ (A) (→ A (Pairof A A))))
(test-expander (→ Any Boolean : (double (id A)))
(→ Any Boolean : (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 with @tc[∀] variables:
@CHUNK[<test-expand-type>
(test-expander (∀ (id) (→ id))
(∀ (id) (→ id)))
(test-expander (∀ (id2) (→ id))
(∀ (id2) (→ (∀ (A) (→ A A)))))]
@CHUNK[<test-expand-type>
(define-type-expander (Repeat stx)
(syntax-case stx ()
[(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))]))
(test-expander (Repeat Number 5)
(List Number Number Number Number Number))]
@CHUNK[<test-expand-type>
(: count-five-more (→ Number (Repeat Number 5)))
(define (count-five-more x)
(list (+ x 1) (+ x 2) (+ x 3) (+ x 4) (+ x 5)))
(check-equal?: (count-five-more 3)
'(4 5 6 7 8))
(check-equal?: (ann (count-five-more 15) (Repeat Number 5))
'(16 17 18 19 20))]
Shadowing with @tc[Rec] variables:
@CHUNK[<test-expand-type>
(: repeat-shadow (→ Number (Rec Repeat (U Null (List Number Repeat)))))
(define (repeat-shadow n)
(if (= n 0)
'()
(list n (repeat-shadow (sub1 n)))))
(check-equal?: (repeat-shadow 5)
'(5 (4 (3 (2 (1 ()))))))
(test-expander (→ Number (Rec Repeat (U Null (List Number Repeat))))
(→ Number (Rec Repeat (U Null (List Number Repeat)))))]
Shadowing with @tc[Let]:
@chunk[<test-expand-type>
(let ()
(define-type-expander (exp stx)
#'(List 1 2 3))
(define-type e String)
(: x (List e (Let [e exp] e)))
(define x (list "e1" (list 1 2 3)))
(check-equal?: x '("e1" (1 2 3)))
(test-expander (List e (Let [e exp] e))
(List e (List 1 2 3)))
(: y (List e))
(define y (list "e2"))
(check-equal?: y '("e2"))
(test-expander (List e)
(List e))
(void))]
@section{Example type-expanders: quasiquote and quasisyntax}
@CHUNK[<expand-quasiquote>
@ -410,10 +291,6 @@ after expanding the type argument.
(define-syntax/parse (new-: x:id t:expr)
#`(: x #,(expand-type #'t)))]
@CHUNK[<test-:>
(: c0 `(2 "abc" #,,(Pairof (U 'x 'y) (U 'y 'z)) #(1 "b" x) d))
(define c0 '(2 "abc" #,(x . z) #(1 "b" x) d))]
@subsection[#:tag "type-expander|syntax-classes"]{syntax classes}
The syntax classes from @tc[typed-racket/base-env/annotate-classes] match
@ -542,16 +419,6 @@ them.
(tmpl-expand-type (?? (TVar ...) ()) type)
. rest))]))]
@chunk[<test-define-type>
(let ()
(define-type-expander (Repeat stx)
(syntax-case stx ()
[(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))]))
(define-type R5 (Repeat Number 5))
(check-equal?: (ann '(1 2 3 4 5) R5) '(1 2 3 4 5)))]
@subsection{@racket[define]}
@chunk[<define>
@ -567,28 +434,6 @@ them.
(?? (?@ : (tmpl-expand-type tvars.vars type)))
e ...))]))]
@CHUNK[<test-define>
(define d0
: `(2 "abc" #,,(Pairof (U 'x 'y) (U 'y 'z)) #(1 "b" x) d)
'(2 "abc" #,(x . z) #(1 "b" x) d))
(check-equal?: (ann d0 (List 2
"abc"
(List 'unsyntax
(Pairof (U 'x 'y) (U 'y 'z)))
(Vector 1 "b" 'x) 'd))
'(2 "abc" (unsyntax (x . z)) #(1 "b" x) d))
(: d1 (→ Number (→ Number Number)))
(define ((d1 [x : Number]) [y : Number]) : Number (+ x y))
(check-equal?: (ann ((d1 2) 3) Number) 5)
(: d2 (→ Number (→ Number Number)))
(define ((d2 [x : Number]) [y : Number]) (+ x y))
(check-equal?: (ann ((d2 3) 4) Number) 7)
(define #:∀ (T) ((d3 [x : T]) [y : T]) : (Pairof T T) (cons x y))
(check-equal?: (ann ((d3 'x) 'y) (Pairof Symbol Symbol)) '(x . y))]
@subsection{@racket[lambda]}
@CHUNK[<lambda>
@ -602,18 +447,6 @@ them.
(?? (?@ : (tmpl-expand-type tvars.vars ret-type)))
e ...))]))]
@CHUNK[<test-lambda>
(check-equal?: ((ann (lambda ([x : Number]) : Number (* x 2))
(→ Number Number))
3)
6)
(check-equal?: ((ann (λ ([x : Number]) : Number (* x 2))
(→ Number Number))
3)
6)
(check-equal?: ((λ x x) 1 2 3) '(1 2 3))
(check-equal?: ((λ #:∀ (A) [x : A ...*] : (Listof A) x) 1 2 3) '(1 2 3))]
@subsection{@racket[struct]}
@chunk[<struct>
@ -628,70 +461,6 @@ them.
([field : (tmpl-expand-type tvars.vars type)] ...)
. rest))]))]
@chunk[<test-struct>
(struct s0 ())
(struct s1 ([x : Number]))
(struct s2 ([x : Number] [y : Number]))
(struct s3 ([x : Number] [y : Number]) #:transparent)
(struct s4 () #:transparent)
(struct (A B) s5 ([x : A] [y : B]) #:transparent)
(struct (A B) s6 () #:transparent)
(struct s7 s2 ([z : String]) #:transparent)
(struct (A) s8 s3 ([z : A]) #:transparent)
(struct (A B C) s9 s5 ([z : C]) #:transparent)
(struct (A B C) s10 s2 ([z : C]) #:transparent)
(struct (A B C) s11 s5 ([z : C]))
(check (λ (a b) (not (equal? a b))) (s0) (s0))
(check-equal?: (s1-x (s1 123)) 123)
(check-equal?: (s2-x (s2 2 3)) 2)
(check-equal?: (s2-y (s2 2 3)) 3)
(check-equal?: (s3-x (s3 4 5)) 4)
(check-equal?: (s3-y (s3 4 5)) 5)
(check-equal?: (s4) (s4))
(check-equal?: (s5-x (s5 6 7)) 6)
(check-equal?: (s5-y (s5 6 7)) 7)
(check-equal?: (s5 6 7) (s5 6 7))
(check-equal?: ((inst s5 Number String) 6 "g") (s5 6 "g"))
(check-equal?: (s6) (s6))
(check-equal?: ((inst s6 Number String)) (s6))
;(check-equal?: (s7-x (s7 -1 -2 "c") -1))
;(check-equal?: (s7-y (s7 -1 -2 "c") -2))
(check-equal?: (s7-z (s7 -1 -2 "c")) "c")
(check-equal?: (s2-x (s7 -1 -2 "c")) -1)
(check-equal?: (s2-y (s7 -1 -2 "c")) -2)
(check-not-equal?: (s7 -1 -2 "c") (s7 -1 -2 "c"))
(check-not-exn (λ () (ann (s7 -1 -2 "c") s2)))
(check-true (s2? (s7 -1 -2 "c")))
;(check-equal?: (s8-x (s8 -1 -2 "c") -1))
;(check-equal?: (s8-y (s8 -1 -2 "c") -2))
(check-equal?: (s8-z (s8 -1 -2 "c")) "c")
(check-equal?: (s3-x (s8 -1 -2 "c")) -1)
(check-equal?: (s3-y (s8 -1 -2 "c")) -2)
(check-equal?: (s8 -1 -2 "c") (s8 -1 -2 "c"))
(check-equal?: ((inst s8 String) -1 -2 "c") (s8 -1 -2 "c"))
(check-not-exn (λ () (ann ((inst s8 String) -1 -2 "c") s3)))
(check-true (s3? ((inst s8 String) -1 -2 "c")))
;(check-equal?: (s9-x (s9 8 9 10)) 8)
;(check-equal?: (s9-y (s9 8 9 10)) 9)
(check-equal?: (s9-z (s9 8 9 10)) 10)
(check-equal?: (s5-x (s9 8 9 10)) 8)
(check-equal?: (s5-y (s9 8 9 10)) 9)
(check-equal?: (s9 8 9 10) (s9 8 9 10))
;; Bug (to report)
;(check-not-exn (λ () (ann ((inst s9 Number Symbol String) 8 'i "j")
; (Struct s5))))
(check-not-exn (λ () (ann ((inst s9 Number Symbol String) 8 'i "j")
(s5 Number Symbol))))
(check-not-exn (λ () (ann ((inst s9 Number Symbol String) 8 'i "j")
(s5 Any Any))))
(check-true (s5? ((inst s9 Number Symbol String) -1 'i "j")))
(check-not-equal?: (s10 11 12 13) (s10 11 12 13))
(check-not-equal?: (s11 14 15 16) (s11 14 15 16))]
@subsection{@racket[define-struct/exec]}
@chunk[<define-struct/exec>
@ -704,85 +473,12 @@ them.
([field (?? (?@ : (tmpl-expand-type () type)))] ...)
[proc : (tmpl-expand-type () proc-type)]))]))]
@chunk[<test-define-struct/exec>
(define TODO '(bug in version 20160114-9498bdd
racket-6.4.0.1-i386-linux-precise.sh))
#|
(define-struct/exec se0 ()
;[(λ (self v) (cons self v)) : (∀ (A) (→ se0 A (Pairof se0 A)))])
[(λ (self v) (cons self v)) : (→ se0 Any (Pairof se0 Any))])
(define-struct/exec se1 ([x : Number])
;[(λ (self v) (cons self v)) : (∀ (A) (→ se0 A (Pairof se0 A)))])
[(λ (self v) (cons self v)) : (→ se1 Any (Pairof se1 Any))])
(define-struct/exec se2 ([x : Number] [y : Number])
[(λ (self v) (cons self v)) : (→ se2 Any (Pairof se2 Any))])
(define-struct/exec (se3 se2) ([z : String])
[(λ (self v w) (list self v w))
;: (∀ (A B) (→ se3 A B (List se2 A B)))])
: (→ se3 Any Any (List se2 Any Any))])
(define-struct/exec (se4 se2) ([z : String])
[(λ (self v w) (list self v w))
;: (∀ (A B) (→ se4 A B (List se2 A B)))])
: (→ se4 Any (→ Number Number) (List se2 Any (→ Number Number)))])
(check (λ (a b) (not (equal? a b))) (se0) (se0))
(check-equal?: (cdr ((se0) 'a)) 'a)
(check-not-exn (λ () (ann (car ((se0) 'a)) se0)))
(check-true (se0? (car ((se0) 'a))))
(check (λ (a b) (not (equal? a b))) (se1 123) (se1 123))
(check-equal?: (se1-x (se1 123)) 123)
(check-equal?: (se1-x (car ((se1 123) 'b))) 123)
(check-equal?: (cdr ((se1 123) 'b)) 'b)
(check-not-exn (λ () (ann (car ((se1 123) 'b)) se1)))
(check-true (se1? (car ((se1 123) 'b))))
(check (λ (a b) (not (equal? a b))) (se2 2 3) (se2 2 3))
(check-equal?: (se2-x (se2 2 3)) 2)
(check-equal?: (se2-y (se2 2 3)) 3)
(check-equal?: (se2-x (car ((se2 2 3) 'c))) 2)
(check-equal?: (se2-y (car ((se2 2 3) 'c))) 3)
(check-equal?: (cdr ((se2 2 3) 'c)) 'c)
(check-not-exn (λ () (ann (car ((se2 2 3) 'c)) se2)))
(check-true (se2? (car ((se2 2 3) 'c))))
(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-y (se3 4 5 "f")) 5)
(check-equal?: (se3-z (se3 4 5 "f")) "f")
(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?: (let ([ret : Any (car ((se3 4 5 "f") 'd 'e))])
(if (se3? ret)
(se3-z ret)
"wrong type!"))
"f")
(check-equal?: (cadr ((se3 4 5 "f") 'd 'e)) 'd)
(check-equal?: (caddr ((se3 4 5 "f") 'd 'e)) 'e)
(check-equal?: ((caddr ((se4 4 5 "f") 'd (λ ([x : Number]) (* x 2)))) 12)
24)
(check-not-exn (λ () (ann (car ((se3 4 5 "f") 'd 'e)) se2)))
(check-true (se2? (car ((se3 4 5 "f") 'd 'e))))
(check-true (se3? (car ((se3 4 5 "f") 'd 'e))))
|#]
@subsection{@racket[ann]}
@chunk[<ann>
(define-syntax/parse (new-ann value:expr (~optional :colon) type:expr)
(template (ann value (tmpl-expand-type () type))))]
@chunk[<test-ann>
(let ()
(define-type-expander (Repeat stx)
(syntax-case stx ()
[(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))]))
(check-equal?: (ann (ann '(1 2 3)
(Repeat Number 3))
(List Number Number Number))
'(1 2 3)))]
@subsection{@racket[inst]}
@chunk[<inst>
@ -793,25 +489,6 @@ them.
(?? (?@ (tmpl-expand-type () last)
(... ...) b)))))]
@chunk[<test-inst>
(let ()
(define-type-expander (Repeat stx)
(syntax-case stx ()
[(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))]))
(: f (∀ (A B C D) (→ (Pairof A B) (Pairof C D) (List A C B D))))
(define (f x y) (list (car x) (car y) (cdr x) (cdr y)))
(check-equal?: ((inst f
(Repeat Number 3)
(Repeat String 2)
(Repeat 'x 1)
(Repeat undefined-type 0))
'((1 2 3) . ("a" "b"))
'((x) . ()))
'((1 2 3) (x) ("a" "b") ())))]
@subsection{@racket[let]}
@chunk[<let>
@ -829,20 +506,6 @@ them.
([(?@ . name.expanded) e] ...)
. rest)))]
@chunk[<test-let>
(check-equal?: (let loop-id ([x 1])
(if (equal? x 2)
x
(loop-id 2)))
: Any
2)
(check-equal?: (let () 'x) 'x)
(check-equal?: (ann (let #:∀ (T) ([a : T 3]
[b : (Pairof T T) '(5 . 7)])
(cons a b))
(Pairof Number (Pairof Number Number)))
'(3 5 . 7))]
@subsection{@racket[let*]}
@chunk[<let*>
@ -855,18 +518,6 @@ them.
(let* ([(?@ . name.expanded) e] ...)
. rest)))]
@chunk[<test-let*>
(let ()
(define-type-expander (Repeat stx)
(syntax-case stx ()
[(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))]))
(check-equal?: (let* ([x* : (Repeat Number 3) '(1 2 3)]
[y* : (Repeat Number 3) x*])
y*)
'(1 2 3)))]
@subsection{@racket[let-values]}
@chunk[<let-values>
@ -879,49 +530,12 @@ them.
(let-values ([(name.expanded ...) e] ...)
. rest)))]
@chunk[<test-let-values>
(let ()
(define-type-expander (Repeat stx)
(syntax-case stx ()
[(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))]))
(check-equal?: (ann (let-values
([([x : (Repeat Number 3)])
(list 1 2 3)])
(cdr x))
(List Number Number))
'(2 3))
(check-equal?: (ann (let-values
([([x : (Repeat Number 3)] [y : Number])
(values (list 1 2 3) 4)])
(cons y x))
(Pairof Number (List Number Number Number)))
'(4 . (1 2 3)))
(check-equal?: (ann (let-values
([(x y)
(values (list 1 2 3) 4)])
(cons y x))
(Pairof Number (List Number Number Number)))
'(4 . (1 2 3))))]
@subsection{@racket[make-predicate]}
@chunk[<make-predicate>
(define-syntax/parse (new-make-predicate type:expr)
(template (make-predicate (tmpl-expand-type () type))))]
@chunk[<test-make-predicate>
(let ()
(define-type-expander (Repeat stx)
(syntax-case stx ()
[(_ t n) #`(List #,@(map (λ (x) #'t)
(range (syntax->datum #'n))))]))
(check-equal?: ((make-predicate (Repeat Number 3)) '(1 2 3)) #t)
(check-equal?: ((make-predicate (Repeat Number 3)) '(1 "b" 3)) #f))]
@subsection[#:tag "type-expander|other-forms"]{Other @racket[typed/racket]
forms}
@ -1159,35 +773,6 @@ We can finally define the overloaded forms, as well as the extra
<make-predicate>
<other-forms>)]
And, last but not least, we will add a @tc[test] module.
@chunk[<module-test>
(module* test typed/racket
;; (require (submod ".." main)) must be on its own (or at least in
;; first position), see this bug:
;; https://github.com/racket/typed-racket/issues/292
(require (submod ".." main))
(require typed/rackunit
"../lib/low.rkt"
(for-syntax (submod ".." expander)
racket/list
(submod "../lib/low.rkt" untyped)))
<test-expand-type>
<test-:>
<test-define-type>
<test-define>
<test-lambda>
<test-struct>
<test-define-struct/exec>
<test-ann>
<test-inst>
<test-let>
<test-let*>
<test-let-values>
<test-make-predicate>)]
We can now assemble the modules in this order:
@chunk[<*>
@ -1197,6 +782,4 @@ We can now assemble the modules in this order:
<module-main>
(require 'main)
(provide (all-from-out 'main))
<module-test>)]
(provide (all-from-out 'main)))]