From 4daa2bb86a89b328f482cc9d0d83ac12ef85f415 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Tue, 22 Mar 2016 22:59:20 +0100
Subject: [PATCH] Moved tests to separate files (part 1).
---
graph-lib/graph/adt-test.rkt | 18 ++
graph-lib/graph/get-test.rkt | 23 ++
graph-lib/graph/graph-5-multi-ctors.lp2.rkt | 14 +-
graph-lib/graph/graph-6-rich-returns-test.rkt | 15 +
graph-lib/graph/graph-6-rich-returns.lp2.rkt | 12 +-
graph-lib/graph/graph-aliasing.lp2.rkt | 2 +-
graph-lib/graph/graph.lp2.rkt | 2 +-
graph-lib/graph/map-test.rkt | 263 ++++++++++++++++++
graph-lib/graph/map.rkt | 224 +--------------
graph-lib/graph/map_old.rkt | 1 -
graph-lib/graph/meta-struct-test.rkt | 44 +++
graph-lib/graph/meta-struct.rkt | 43 ---
graph-lib/graph/queue-test.rkt | 41 +++
graph-lib/graph/queue.lp2.rkt | 43 +--
graph-lib/graph/remember.rkt | 2 +
graph-lib/graph/rewrite-type-test.rkt | 127 +++++++++
graph-lib/graph/rewrite-type.lp2.rkt | 133 +--------
graph-lib/graph/structure-test.rkt | 155 +++++++++++
graph-lib/graph/structure.lp2.rkt | 156 +----------
graph-lib/graph/tagged-test.rkt | 19 ++
graph-lib/graph/tagged.lp2.rkt | 26 +-
graph-lib/graph/test-map-get.rkt | 44 ---
graph-lib/graph/uniform-get.lp2.rkt | 8 +-
graph-lib/graph/variant-test.rkt | 24 ++
graph-lib/graph/variant2.lp2.rkt | 30 +-
graph-lib/lib/low/typed-rackunit.rkt | 21 ++
26 files changed, 788 insertions(+), 702 deletions(-)
create mode 100644 graph-lib/graph/adt-test.rkt
create mode 100644 graph-lib/graph/get-test.rkt
create mode 100644 graph-lib/graph/graph-6-rich-returns-test.rkt
create mode 100644 graph-lib/graph/map-test.rkt
create mode 100644 graph-lib/graph/meta-struct-test.rkt
create mode 100644 graph-lib/graph/queue-test.rkt
create mode 100644 graph-lib/graph/rewrite-type-test.rkt
create mode 100644 graph-lib/graph/structure-test.rkt
create mode 100644 graph-lib/graph/tagged-test.rkt
delete mode 100644 graph-lib/graph/test-map-get.rkt
create mode 100644 graph-lib/graph/variant-test.rkt
diff --git a/graph-lib/graph/adt-test.rkt b/graph-lib/graph/adt-test.rkt
new file mode 100644
index 00000000..185bfb60
--- /dev/null
+++ b/graph-lib/graph/adt-test.rkt
@@ -0,0 +1,18 @@
+#lang typed/racket
+
+(module test typed/racket
+ (require (submod "graph.lp2.rkt" test))
+ (require "adt.lp2.rkt")
+ (require "../lib/low.rkt")
+ (require "../type-expander/type-expander.lp2.rkt")
+
+ ((tagged t a b c) 1 'b "c")
+ ((tagged t a [b] c) 1 'b "c")
+ ((tagged t [a] [b] [c]) 1 'b "c")
+ ((tagged t [a : Number] [b : Symbol] [c : String]) 1 'b "c")
+ (tagged t [a : Number 1] [b : Symbol 'b] [c : String "c"])
+ (tagged t [a 1] [b 'b] [c "c"])
+
+ (tagged t [a 1] [b 'b] [c "c"])
+
+ (define-tagged tabc [a 1] [b 'b] [c "c"]))
\ No newline at end of file
diff --git a/graph-lib/graph/get-test.rkt b/graph-lib/graph/get-test.rkt
new file mode 100644
index 00000000..9c26cd9d
--- /dev/null
+++ b/graph-lib/graph/get-test.rkt
@@ -0,0 +1,23 @@
+#lang typed/racket
+
+(module test typed/racket
+ (require (submod "graph.lp2.rkt" test))
+ (require "get.lp2.rkt")
+ (require "adt.lp2.rkt")
+ (require "../lib/low.rkt")
+ (require "../type-expander/type-expander.lp2.rkt")
+
+ (check-equal?: (get '((1 2) (3)) … …)
+ '((1 2) (3)))
+
+ (uniform-get g people)
+ (get g people)
+ (get g streets cadr houses car owner name)
+ ((λget people) g)
+ (check-equal?: ((λget owner name) (get g streets cadr houses car))
+ "Jack")
+ (check-equal?: (get g streets … houses … owner name)
+ '(("Amy" "Anabella") ("Jack")))
+ (check-equal?: ((λget streets … houses … owner name) g)
+ '(("Amy" "Anabella") ("Jack")))
+ (check-true: (procedure? (let ([f (λget streets … houses … owner name)]) f))))
\ No newline at end of file
diff --git a/graph-lib/graph/graph-5-multi-ctors.lp2.rkt b/graph-lib/graph/graph-5-multi-ctors.lp2.rkt
index 07cc9f07..c6202865 100644
--- a/graph-lib/graph/graph-5-multi-ctors.lp2.rkt
+++ b/graph-lib/graph/graph-5-multi-ctors.lp2.rkt
@@ -140,9 +140,6 @@ TODO: At the call site, use a macro and annotate the function (given by its
name) with the right type, so that the user doesn't see all the types in the
(U …).
-@chunk[<test-graph-multi-ctor>
- (check-equal? 42 42)]
-
@section{Conclusion}
@chunk[<module-main>
@@ -168,18 +165,9 @@ name) with the right type, so that the user doesn't see all the types in the
<graph-multi-ctor>)]
-@chunk[<module-test>
- (module* test typed/racket
- (require (submod "..")
- typed/rackunit)
-
- <test-graph-multi-ctor>)]
-
@chunk[<*>
(begin
<module-main>
(require 'main)
- (provide (all-from-out 'main))
-
- <module-test>)]
+ (provide (all-from-out 'main)))]
diff --git a/graph-lib/graph/graph-6-rich-returns-test.rkt b/graph-lib/graph/graph-6-rich-returns-test.rkt
new file mode 100644
index 00000000..3bbcc3ed
--- /dev/null
+++ b/graph-lib/graph/graph-6-rich-returns-test.rkt
@@ -0,0 +1,15 @@
+#lang typed/racket
+
+(module test typed/racket
+ (require (for-syntax (submod "graph-6-rich-returns.lp2.rkt" test-syntax)
+ syntax/strip-context))
+
+ (define-syntax (insert-tests stx)
+ (replace-context stx tests))
+
+ (require "graph-6-rich-returns.lp2.rkt"
+ "../type-expander/type-expander.lp2.rkt"
+ typed/rackunit)
+
+ ;(insert-tests);; TODO: FIXME
+ )
\ No newline at end of file
diff --git a/graph-lib/graph/graph-6-rich-returns.lp2.rkt b/graph-lib/graph/graph-6-rich-returns.lp2.rkt
index cdbd84fe..89723d4f 100644
--- a/graph-lib/graph/graph-6-rich-returns.lp2.rkt
+++ b/graph-lib/graph/graph-6-rich-returns.lp2.rkt
@@ -571,12 +571,12 @@ encapsulating the result types of mappings.
<graph-rich-return>)]
@chunk[<module-test>
- (module* test typed/racket
- (require (submod "..")
- typed/rackunit)
-
- ;;<test-graph-rich-return>
- )]
+ (module test-syntax racket
+ (provide tests)
+ (define tests
+ (quote-syntax
+ (begin
+ <test-graph-rich-return>))))]
@chunk[<*>
(begin
diff --git a/graph-lib/graph/graph-aliasing.lp2.rkt b/graph-lib/graph/graph-aliasing.lp2.rkt
index 88bcc115..576b1ab0 100644
--- a/graph-lib/graph/graph-aliasing.lp2.rkt
+++ b/graph-lib/graph/graph-aliasing.lp2.rkt
@@ -11,7 +11,7 @@
When declaring a graph, the names of its nodes and mappings
as well as those of the graph it is based on may collide. We
-try here to provide reasonnable defaults indicating which
+try here to provide reasonable defaults indicating which
name should refer to what at each point.
@chunk[<example>
diff --git a/graph-lib/graph/graph.lp2.rkt b/graph-lib/graph/graph.lp2.rkt
index a96255fc..3de7a3f3 100644
--- a/graph-lib/graph/graph.lp2.rkt
+++ b/graph-lib/graph/graph.lp2.rkt
@@ -821,7 +821,7 @@ not match the one from @tc[typed/racket]
(only-in "adt.lp2.rkt" uniform-get)
"../type-expander/type-expander.lp2.rkt")
- (provide g)
+ (provide g gr gr-simple)
<use-example>
<type-example>
diff --git a/graph-lib/graph/map-test.rkt b/graph-lib/graph/map-test.rkt
new file mode 100644
index 00000000..dc1c9f8b
--- /dev/null
+++ b/graph-lib/graph/map-test.rkt
@@ -0,0 +1,263 @@
+#lang typed/racket
+
+(module test typed/racket
+ (require "map.rkt"
+ (submod "map.rkt" private-tests))
+ (require (submod "graph.lp2.rkt" test)
+ "get.lp2.rkt"
+ "map.rkt"
+ "../lib/low.rkt"
+ "../type-expander/type-expander.lp2.rkt")
+
+ (begin
+ (check-equal?: ((λdeep-map {A B} A B 3) add1 '([{1} {2 3}] [{4}]))
+ : (Listof (Listof (Listof Number)))
+ '([{2} {3 4}] [{5}])))
+
+ ;; deep-map
+ (begin
+ (check-equal?: (deep-map {A B} A B 3 add1 '([{1} {2 3}] [{4}]))
+ : (Listof (Listof (Listof Number)))
+ '([{2} {3 4}] [{5}]))
+
+
+ (check-equal?: (deep-map {A B} A B 0 add1 '7)
+ : Number
+ 8))
+
+ ;; deep-map-auto
+ (begin
+ (check-equal?: (deep-map-auto 2 length '([{1} {2 3}] [{4}]))
+ : (Listof (Listof Index))
+ '([1 2] [1]))
+
+ (check-equal?: (deep-map-auto 2 car '([{1} {2 3}] [{4}]))
+ : (Listof (Listof Number))
+ '([1 2] [4]))
+
+ (check-equal?: (deep-map-auto 2 list '([1 2] [3]))
+ : (Listof (Listof (Listof Number)))
+ '([{1} {2}] [{3}]))
+
+ #;(check-equal?: (deep-map-auto 3 add1 (deep-map-auto 2 list '([1 2] [3])))
+ : (Listof (Listof (Listof Number)))
+ '([{1} {2}] [{3}]))
+
+ (check-equal?: (deep-map-auto 1 length
+ (deep-map-auto 2 car
+ (deep-map-auto 2 list
+ '([1 2] [3]))))
+ : (Listof Index)
+ '(2 1)))
+
+ ;; compose-maps
+ (begin
+ (check-equal?: (compose-maps [(2 car!) (3 add1) (3 add1) (2 list)]
+ ['([1 2] [3])])
+ : (Listof (Listof Number))
+ '([3 4] [5])))
+
+ ;; map:
+ (begin
+ (check-equal?: (map: car '((1 a) (2 b) (3 c)))
+ : (Listof Number)
+ '(1 2 3))
+
+ (check-equal?: (map: (∘ (∘ add1)
+ length
+ (curry map car)
+ (curry map list)
+ (curry map (∘)))
+ '([1 2] [3]))
+ : (Listof Number)
+ '(3 2)))
+
+ ;; map:
+ (begin
+ (check-equal?: (map: add1 '(1 2 3))
+ : (Listof Number)
+ '(2 3 4))
+ (check-equal?: (map: (compose add1) '(1 2 3))
+ : (Listof Number)
+ '(2 3 4))
+ (check-equal?: (map: (∘ identity add1) '(1 2 3))
+ : (Listof Number)
+ '(2 3 4))
+ (check-equal?: (map: (∘ add1 identity) '(1 2 3))
+ : (Listof Number)
+ '(2 3 4))
+ (check-equal?: (map: (∘ number->string add1) '(1 2 9))
+ : (Listof String)
+ '("2" "3" "10"))
+ (check-equal?: (map: (∘ string-length number->string add1) '(1 2 9))
+ : (Listof Number)
+ '(1 1 2))
+ (check-equal?: (map: car '((1 2) (2) (9 10 11)))
+ : (Listof Number)
+ '(1 2 9))
+ (check-equal?: (map: (∘ add1 car) '((1 2) (2) (9 10 11)))
+ : (Listof Number)
+ '(2 3 10))
+ (check-equal?: (map: (∘ string-length number->string add1 car cdr)
+ '((1 2) (2 3) (8 9 10)))
+ : (Listof Number)
+ '(1 1 2))
+ (check-equal?: (map: identity '(1 2 3))
+ : (Listof Number)
+ '(1 2 3))
+ (check-equal?: (map: values '(1 2 3))
+ : (Listof Number)
+ '(1 2 3))
+ (check-equal?: (map: (compose) '(1 2 3))
+ : (Listof Number)
+ '(1 2 3))
+ (check-equal?: (map: (compose identity) '(1 2 3))
+ : (Listof Number)
+ '(1 2 3))
+ (check-equal?: (map: (∘ identity values identity values) '(1 2 3))
+ : (Listof Number)
+ '(1 2 3))
+ (check-equal?: (map: (∘ length (curry map add1)) '((1 2) (3)))
+ : (Listof Number)
+ '(2 1))
+ (check-equal?: (map: (curry map add1) '((1 2) (3)))
+ : (Listof (Listof Number))
+ '((2 3) (4)))
+
+ (define (numlist [x : Number]) (list x))
+ (check-equal?: (map: (∘ (curry map add1) numlist) '(1 2 3))
+ : (Listof (Listof Number))
+ '((2) (3) (4)))
+
+ (check-equal?: (map: (∘ (curry map add1) (λ ([x : Number]) (list x)))
+ '(1 2 3))
+ : (Listof (Listof Number))
+ '((2) (3) (4)))
+
+ (begin
+ ;; Some of the tests below use (curry map: …) instead of (curry map …).
+ ;; The colon `map:` version does not work, because typed/racket wraps the
+ ;; `map:` identifier with a contract, so the identifier seen outside the
+ ;; module is not the same as the one used in the syntax-parse ~literal
+ ;; clause.
+
+ (check-equal?: (map: (curry map add1) '((1 2 3) (4 5)))
+ : (Listof (Listof Number))
+ '((2 3 4) (5 6)))
+ #;(check-equal?: (map: (curry map: add1) '((1 2 3) (4 5)))
+ : (Listof (Listof Number))
+ '((2 3 4) (5 6)))
+
+ (check-equal?: (map: (curry map (compose number->string add1))
+ '((1 2 3) (4 5)))
+ : (Listof (Listof String))
+ '(("2" "3" "4") ("5" "6")))
+ #;(check-equal?: (map: (curry map: (compose number->string add1))
+ '((1 2 3) (4 5)))
+ : (Listof (Listof String))
+ '(("2" "3" "4") ("5" "6")))
+
+ (check-equal?: (map: add1 '(1 2 3))
+ : (Listof Number)
+ '(2 3 4))
+
+ (check-equal?: (map: car '((1 a) (2 b) (3 c)))
+ : (Listof Number)
+ '(1 2 3))
+
+ (check-equal?: (map: (curry map car) '([{1 a} {2 b}] [{3 c}]))
+ : (Listof (Listof Number))
+ '([1 2] [3]))
+ #;(check-equal?: (map: (curry map: car) '([{1 a} {2 b}] [{3 c}]))
+ : (Listof (Listof Number))
+ '([1 2] [3]))
+
+ (check-equal?: (map: (curry map (curry map car))
+ '([((1 a) (2 b)) ((3 c))] [((4))]))
+ : (Listof (Listof (Listof Number)))
+ '([(1 2) (3)] [(4)]))
+ #;(check-equal?: (map: (curry map (curry map: car))
+ '([((1 a) (2 b)) ((3 c))] [((4))]))
+ : (Listof (Listof (Listof Number)))
+ '([(1 2) (3)] [(4)]))
+ #;(check-equal?: (map: (curry map: (curry map car))
+ '([((1 a) (2 b)) ((3 c))] [((4))]))
+ : (Listof (Listof (Listof Number)))
+ '([(1 2) (3)] [(4)]))
+ #;(check-equal?: (map: (curry map: (curry map: car))
+ '([((1 a) (2 b)) ((3 c))] [((4))]))
+ : (Listof (Listof (Listof Number)))
+ '([(1 2) (3)] [(4)])))
+
+ (check-equal?: (map: car '((1 b x) (2 c) (3 d)))
+ : (Listof Number)
+ '(1 2 3))
+ (check-equal?: (map: cdr '((1 b x) (2 c) (3 d)))
+ : (Listof (Listof Symbol))
+ '((b x) (c) (d)))
+ (check-equal?: (map: car (map: cdr '((1 b x) (2 c) (3 d))))
+ : (Listof Symbol)
+ '(b c d))
+ (check-equal?: (map: (compose) '((1 b x) (2 c) (3 d)))
+ : (Listof (Listof (U Number Symbol)))
+ '((1 b x) (2 c) (3 d)))
+ (check-equal?: (map: (compose car) '((1 b x) (2 c) (3 d)))
+ : (Listof Number)
+ '(1 2 3))
+ (check-equal?: (map: (compose cdr) '((1 b x) (2 c) (3 d)))
+ : (Listof (Listof Symbol))
+ '((b x) (c) (d)))
+ (check-equal?: (map: (compose car cdr) '((1 b x) (2 c) (3 d)))
+ : (Listof Symbol)
+ '(b c d))
+ (check-equal?: (map: (compose add1 car) '((1 b x) (2 c) (3 d)))
+ : (Listof Number)
+ '(2 3 4))
+ #|
+ (check-equal?: (map: + '(1 2 3) '(4 5 6))
+ : (Listof Number)
+ '(5 7 9))|#)
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (check-equal?:
+ (map: (curry map (gr #:? House))
+ (map: (λget houses) (get g streets)))
+ '((#t #t) (#t)))
+
+ (check-equal?:
+ (map: (λget houses … owner name) (get g streets))
+ '(("Amy" "Anabella") ("Jack")))
+
+ (check-equal?:
+ (map: (∘ (curry map (∘ (λget name) (λget owner)))
+ (λget houses))
+ (get g streets))
+ '(("Amy" "Anabella") ("Jack")))
+
+ (check-equal?:
+ (map: (∘ (curry map (∘ string-length (λget name) (λget owner)))
+ (λget houses))
+ (get g streets))
+ '((3 8) (4)))
+
+ (check-equal?:
+ (map: (curry map (gr #:? House))
+ (map: (compose (curry map identity)
+ (λget houses …))
+ (get g streets)))
+ '((#t #t) (#t)))
+
+ ;; Can be allowed by changing (→ (→ A B) A B) in a couple of places in map: to
+ ;; a case→, but it's more heavy on the typechecker, and it's an uncommon case.
+ ;(map: (compose (λget houses …) (λ #:∀ (A) ([x : A]) x)) (get g streets))
+ (check-equal?:
+ (map: (curry map (gr #:? Person))
+ (map: (compose (curry map (λget owner))
+ (λget houses …))
+ (get g streets)))
+ '((#t #t) (#t)))
+
+ (check-equal?:
+ (map: (λget houses … owner name) (get g streets))
+ '(("Amy" "Anabella") ("Jack"))))
\ No newline at end of file
diff --git a/graph-lib/graph/map.rkt b/graph-lib/graph/map.rkt
index addb6547..4f4aec68 100644
--- a/graph-lib/graph/map.rkt
+++ b/graph-lib/graph/map.rkt
@@ -8,6 +8,16 @@
"get.lp2.rkt"
"../type-expander/type-expander.lp2.rkt")
+(provide car!
+ cdr!
+ map:
+ compose-maps)
+
+(module+ private-tests
+ (provide λdeep-map
+ deep-map
+ deep-map-auto))
+
(module m typed/racket
(provide car! cdr!)
@@ -21,9 +31,6 @@
(define (cdr! x) (cdr x)))
(require 'm)
-(provide (all-from-out 'm))
-
-(provide map: compose-maps)
(define-syntax (dbg stx)
(syntax-parse stx
@@ -74,26 +81,11 @@
(local-map f (cdr l)))))
local-map))]))
-(module+ test
- (check-equal?: ((λdeep-map {A B} A B 3) add1 '([{1} {2 3}] [{4}]))
- : (Listof (Listof (Listof Number)))
- '([{2} {3 4}] [{5}])))
-
(define-syntax (deep-map stx)
(syntax-parse stx
[(_ {∀-type:id …} A:expr B:expr d:≥0 f:expr l:expr)
(syntax/loc #'f ((λdeep-map {∀-type …} A B d) f l))]))
-(module+ test
- (check-equal?: (deep-map {A B} A B 3 add1 '([{1} {2 3}] [{4}]))
- : (Listof (Listof (Listof Number)))
- '([{2} {3 4}] [{5}])))
-
-(module+ test
- (check-equal?: (deep-map {A B} A B 0 add1 '7)
- : Number
- 8))
-
;; We provide hints for the types of some common functions
(define-type-expander (ArgOf stx)
@@ -127,34 +119,6 @@
(define-syntax/parse (deep-map-auto d:≥0 f l)
#'(deep-map {A B} (ArgOf f A B) (ResultOf f A B) d (substitute-function f) l))
-(module+ test
- (check-equal?: (deep-map-auto 2 length '([{1} {2 3}] [{4}]))
- : (Listof (Listof Index))
- '([1 2] [1])))
-
-(module+ test
- (check-equal?: (deep-map-auto 2 car '([{1} {2 3}] [{4}]))
- : (Listof (Listof Number))
- '([1 2] [4])))
-
-(module+ test
- (check-equal?: (deep-map-auto 2 list '([1 2] [3]))
- : (Listof (Listof (Listof Number)))
- '([{1} {2}] [{3}])))
-
-#;(module+ test
- (check-equal?: (deep-map-auto 3 add1 (deep-map-auto 2 list '([1 2] [3])))
- : (Listof (Listof (Listof Number)))
- '([{1} {2}] [{3}])))
-
-(module+ test
- (check-equal?: (deep-map-auto 1 length
- (deep-map-auto 2 car
- (deep-map-auto 2 list
- '([1 2] [3]))))
- : (Listof Index)
- '(2 1)))
-
;; Now we turn all map: calls into the form
;; (compose-maps [(d f) …] [l …])
@@ -167,12 +131,6 @@
[(_ [(d:≥0 f:expr) (d-rest:≥0 f-rest:expr) …] [l:expr …])
#'(deep-map-auto d f (compose-maps [(d-rest f-rest) …] [l …]))]))
-(module+ test
- (check-equal?: (compose-maps [(2 car!) (3 add1) (3 add1) (2 list)]
- ['([1 2] [3])])
- : (Listof (Listof Number))
- '([3 4] [5])))
-
(define-for-syntax (transform-map: depth stx)
(syntax-parse stx
[((~literal curry) (~literal map) f:expr)
@@ -189,165 +147,3 @@
(define-syntax (map: stx)
(syntax-parse stx
[(_ f l) #`(compose-maps #,(transform-map: 1 #'f) [l])]))
-
-(module+ test
- (check-equal?: (map: car '((1 a) (2 b) (3 c)))
- : (Listof Number)
- '(1 2 3)))
-
-(module+ test
- (check-equal?: (map: (∘ (∘ add1)
- length
- (curry map car)
- (curry map list)
- (curry map (∘)))
- '([1 2] [3]))
- : (Listof Number)
- '(3 2)))
-
-(module+ test
- ;(require (submod "..")
- ; "../lib/low.rkt")
-
- (check-equal?: (map: add1 '(1 2 3))
- : (Listof Number)
- '(2 3 4))
- (check-equal?: (map: (compose add1) '(1 2 3))
- : (Listof Number)
- '(2 3 4))
- (check-equal?: (map: (∘ identity add1) '(1 2 3))
- : (Listof Number)
- '(2 3 4))
- (check-equal?: (map: (∘ add1 identity) '(1 2 3))
- : (Listof Number)
- '(2 3 4))
- (check-equal?: (map: (∘ number->string add1) '(1 2 9))
- : (Listof String)
- '("2" "3" "10"))
- (check-equal?: (map: (∘ string-length number->string add1) '(1 2 9))
- : (Listof Number)
- '(1 1 2))
- (check-equal?: (map: car '((1 2) (2) (9 10 11)))
- : (Listof Number)
- '(1 2 9))
- (check-equal?: (map: (∘ add1 car) '((1 2) (2) (9 10 11)))
- : (Listof Number)
- '(2 3 10))
- (check-equal?: (map: (∘ string-length number->string add1 car cdr)
- '((1 2) (2 3) (8 9 10)))
- : (Listof Number)
- '(1 1 2))
- (check-equal?: (map: identity '(1 2 3))
- : (Listof Number)
- '(1 2 3))
- (check-equal?: (map: values '(1 2 3))
- : (Listof Number)
- '(1 2 3))
- (check-equal?: (map: (compose) '(1 2 3))
- : (Listof Number)
- '(1 2 3))
- (check-equal?: (map: (compose identity) '(1 2 3))
- : (Listof Number)
- '(1 2 3))
- (check-equal?: (map: (∘ identity values identity values) '(1 2 3))
- : (Listof Number)
- '(1 2 3))
- (check-equal?: (map: (∘ length (curry map add1)) '((1 2) (3)))
- : (Listof Number)
- '(2 1))
- (check-equal?: (map: (curry map add1) '((1 2) (3)))
- : (Listof (Listof Number))
- '((2 3) (4)))
-
- (define (numlist [x : Number]) (list x))
- (check-equal?: (map: (∘ (curry map add1) numlist) '(1 2 3))
- : (Listof (Listof Number))
- '((2) (3) (4)))
-
- (check-equal?: (map: (∘ (curry map add1) (λ ([x : Number]) (list x)))
- '(1 2 3))
- : (Listof (Listof Number))
- '((2) (3) (4)))
-
- (begin
- ;; Some of the tests below use (curry map: …), and don't work, because
- ;; typed/racket wraps the map: identifier with a contract, so the identifier
- ;; seen outside the module is not the same as the one used in the
- ;; syntax-parse ~literal clause.
-
- (check-equal?: (map: (curry map add1) '((1 2 3) (4 5)))
- : (Listof (Listof Number))
- '((2 3 4) (5 6)))
- #;(check-equal?: (map: (curry map: add1) '((1 2 3) (4 5)))
- : (Listof (Listof Number))
- '((2 3 4) (5 6)))
-
- (check-equal?: (map: (curry map (compose number->string add1))
- '((1 2 3) (4 5)))
- : (Listof (Listof String))
- '(("2" "3" "4") ("5" "6")))
- #;(check-equal?: (map: (curry map: (compose number->string add1))
- '((1 2 3) (4 5)))
- : (Listof (Listof String))
- '(("2" "3" "4") ("5" "6")))
-
- (check-equal?: (map: add1 '(1 2 3))
- : (Listof Number)
- '(2 3 4))
-
- (check-equal?: (map: car '((1 a) (2 b) (3 c)))
- : (Listof Number)
- '(1 2 3))
-
- (check-equal?: (map: (curry map car) '([{1 a} {2 b}] [{3 c}]))
- : (Listof (Listof Number))
- '([1 2] [3]))
- #;(check-equal?: (map: (curry map: car) '([{1 a} {2 b}] [{3 c}]))
- : (Listof (Listof Number))
- '([1 2] [3]))
-
- (check-equal?: (map: (curry map (curry map car))
- '([((1 a) (2 b)) ((3 c))] [((4))]))
- : (Listof (Listof (Listof Number)))
- '([(1 2) (3)] [(4)]))
- #;(check-equal?: (map: (curry map (curry map: car))
- '([((1 a) (2 b)) ((3 c))] [((4))]))
- : (Listof (Listof (Listof Number)))
- '([(1 2) (3)] [(4)]))
- #;(check-equal?: (map: (curry map: (curry map car))
- '([((1 a) (2 b)) ((3 c))] [((4))]))
- : (Listof (Listof (Listof Number)))
- '([(1 2) (3)] [(4)]))
- #;(check-equal?: (map: (curry map: (curry map: car))
- '([((1 a) (2 b)) ((3 c))] [((4))]))
- : (Listof (Listof (Listof Number)))
- '([(1 2) (3)] [(4)])))
-
- (check-equal?: (map: car '((1 b x) (2 c) (3 d)))
- : (Listof Number)
- '(1 2 3))
- (check-equal?: (map: cdr '((1 b x) (2 c) (3 d)))
- : (Listof (Listof Symbol))
- '((b x) (c) (d)))
- (check-equal?: (map: car (map: cdr '((1 b x) (2 c) (3 d))))
- : (Listof Symbol)
- '(b c d))
- (check-equal?: (map: (compose) '((1 b x) (2 c) (3 d)))
- : (Listof (Listof (U Number Symbol)))
- '((1 b x) (2 c) (3 d)))
- (check-equal?: (map: (compose car) '((1 b x) (2 c) (3 d)))
- : (Listof Number)
- '(1 2 3))
- (check-equal?: (map: (compose cdr) '((1 b x) (2 c) (3 d)))
- : (Listof (Listof Symbol))
- '((b x) (c) (d)))
- (check-equal?: (map: (compose car cdr) '((1 b x) (2 c) (3 d)))
- : (Listof Symbol)
- '(b c d))
- (check-equal?: (map: (compose add1 car) '((1 b x) (2 c) (3 d)))
- : (Listof Number)
- '(2 3 4))
- #|
- (check-equal?: (map: + '(1 2 3) '(4 5 6))
- : (Listof Number)
- '(5 7 9))|#)
\ No newline at end of file
diff --git a/graph-lib/graph/map_old.rkt b/graph-lib/graph/map_old.rkt
index 9771bb54..cc4167ed 100644
--- a/graph-lib/graph/map_old.rkt
+++ b/graph-lib/graph/map_old.rkt
@@ -8,7 +8,6 @@
racket/base
racket/syntax)
"../lib/low.rkt"
- "map1.rkt"
"get.lp2.rkt"
"../type-expander/type-expander.lp2.rkt")
diff --git a/graph-lib/graph/meta-struct-test.rkt b/graph-lib/graph/meta-struct-test.rkt
new file mode 100644
index 00000000..a8085b29
--- /dev/null
+++ b/graph-lib/graph/meta-struct-test.rkt
@@ -0,0 +1,44 @@
+#lang typed/racket
+
+(module test racket
+ (require (for-syntax "meta-struct.rkt")
+ rackunit)
+
+ (define-syntax (test-subtype? stx)
+ (syntax-case stx ()
+ [(_ sub super)
+ #`#,(if (meta-struct-subtype? #'sub #'super)
+ #t
+ #f)]))
+
+ (module m1 racket
+ (struct sa ())
+ (provide (struct-out sa)))
+ (module m2 racket
+ (require (submod ".." m1))
+ (struct sb sa ())
+ (provide (rename-out [sa sa2]))
+ (provide (struct-out sb)))
+ (require 'm1)
+ (require 'm2)
+ (struct sc sb ())
+
+ (check-true (test-subtype? sa sa))
+ (check-true (test-subtype? sa2 sa))
+ (check-true (test-subtype? sb sa))
+ (check-true (test-subtype? sc sa))
+
+ (check-true (test-subtype? sa sa2))
+ (check-true (test-subtype? sa2 sa2))
+ (check-true (test-subtype? sb sa2))
+ (check-true (test-subtype? sc sa2))
+
+ (check-false (test-subtype? sa sb))
+ (check-false (test-subtype? sa2 sb))
+ (check-true (test-subtype? sb sb))
+ (check-true (test-subtype? sc sb))
+
+ (check-false (test-subtype? sa sc))
+ (check-false (test-subtype? sa2 sc))
+ (check-false (test-subtype? sb sc))
+ (check-true (test-subtype? sc sc)))
\ No newline at end of file
diff --git a/graph-lib/graph/meta-struct.rkt b/graph-lib/graph/meta-struct.rkt
index d281191d..3afe0f08 100644
--- a/graph-lib/graph/meta-struct.rkt
+++ b/graph-lib/graph/meta-struct.rkt
@@ -86,46 +86,3 @@
(let ((up (meta-struct-super-type sub)))
(and (meta-struct? up)
(meta-struct-subtype? up super)))))
-
-(module* test racket
- (require (for-syntax (submod ".."))
- rackunit)
-
- (define-syntax (test-subtype? stx)
- (syntax-case stx ()
- [(_ sub super)
- #`#,(if (meta-struct-subtype? #'sub #'super)
- #t
- #f)]))
-
- (module m1 racket
- (struct sa ())
- (provide (struct-out sa)))
- (module m2 racket
- (require (submod ".." m1))
- (struct sb sa ())
- (provide (rename-out [sa sa2]))
- (provide (struct-out sb)))
- (require 'm1)
- (require 'm2)
- (struct sc sb ())
-
- (check-true (test-subtype? sa sa))
- (check-true (test-subtype? sa2 sa))
- (check-true (test-subtype? sb sa))
- (check-true (test-subtype? sc sa))
-
- (check-true (test-subtype? sa sa2))
- (check-true (test-subtype? sa2 sa2))
- (check-true (test-subtype? sb sa2))
- (check-true (test-subtype? sc sa2))
-
- (check-false (test-subtype? sa sb))
- (check-false (test-subtype? sa2 sb))
- (check-true (test-subtype? sb sb))
- (check-true (test-subtype? sc sb))
-
- (check-false (test-subtype? sa sc))
- (check-false (test-subtype? sa2 sc))
- (check-false (test-subtype? sb sc))
- (check-true (test-subtype? sc sc)))
\ No newline at end of file
diff --git a/graph-lib/graph/queue-test.rkt b/graph-lib/graph/queue-test.rkt
new file mode 100644
index 00000000..609ae302
--- /dev/null
+++ b/graph-lib/graph/queue-test.rkt
@@ -0,0 +1,41 @@
+#lang typed/racket
+
+(module test typed/racket
+ (require "queue.lp2.rkt"
+ typed/rackunit)
+
+ (let-values
+ ([(h t _)
+ ((inst fold-queue-sets-immutable-tags
+ Integer
+ Void
+ String
+ (List 'a Integer String))
+ (set 6 7)
+ (void)
+ (λ (e acc) (values (format "{~a}" e) acc))
+ (λ (e acc x get-tag)
+ (let*-values ([(t1 acc1 x1) (get-tag (if (even? e)
+ (floor (/ e 2))
+ (+ (* 3 e) 1))
+ acc
+ x)]
+ [(t2 acc2 x2) (get-tag 85 acc1 x1)])
+ (values (list 'a e t1) acc2 x2))))])
+ (check-equal? (sort (hash-keys h) <)
+ (sort '(7 22 11 34 17 52 26 13 40 20 10 5 16 8 4 2 1
+ 6 3
+ 85 256 128 64 32)
+ <))
+ (check-true (set=? (set-remove
+ (set-remove
+ (set-remove(list->set (hash-keys h)) 7)
+ 6)
+ 85)
+ (list->set
+ (map (λ ([x : (List 'a Integer String)])
+ (let ([s (caddr x)])
+ (string->number
+ (substring s 1 (- (string-length s)
+ 1)))))
+ (hash-values h)))))))
\ No newline at end of file
diff --git a/graph-lib/graph/queue.lp2.rkt b/graph-lib/graph/queue.lp2.rkt
index bdf593d7..9a027fe9 100644
--- a/graph-lib/graph/queue.lp2.rkt
+++ b/graph-lib/graph/queue.lp2.rkt
@@ -394,46 +394,5 @@ was a tag requested.
<fold-queue-sets-tags>
<fold-queue-sets-immutable-tags>)
- (require typed/racket)
(require 'main)
- (provide (all-from-out 'main))
-
- (module* test typed/racket
- (require (submod "..")
- typed/rackunit)
-
- (let-values
- ([(h t _)
- ((inst fold-queue-sets-immutable-tags
- Integer
- Void
- String
- (List 'a Integer String))
- (set 6 7)
- (void)
- (λ (e acc) (values (format "{~a}" e) acc))
- (λ (e acc x get-tag)
- (let*-values ([(t1 acc1 x1) (get-tag (if (even? e)
- (floor (/ e 2))
- (+ (* 3 e) 1))
- acc
- x)]
- [(t2 acc2 x2) (get-tag 85 acc1 x1)])
- (values (list 'a e t1) acc2 x2))))])
- (check-equal? (sort (hash-keys h) <)
- (sort '(7 22 11 34 17 52 26 13 40 20 10 5 16 8 4 2 1
- 6 3
- 85 256 128 64 32)
- <))
- (check-true (set=? (set-remove
- (set-remove
- (set-remove(list->set (hash-keys h)) 7)
- 6)
- 85)
- (list->set
- (map (λ ([x : (List 'a Integer String)])
- (let ([s (caddr x)])
- (string->number
- (substring s 1 (- (string-length s)
- 1)))))
- (hash-values h))))))))]
+ (provide (all-from-out 'main)))]
diff --git a/graph-lib/graph/remember.rkt b/graph-lib/graph/remember.rkt
index 51aca616..948f18ff 100644
--- a/graph-lib/graph/remember.rkt
+++ b/graph-lib/graph/remember.rkt
@@ -28,6 +28,8 @@
(group-by (inst car Symbol Any) all-remembered-list)))
(define-list-values all-remembered-list : (Listof (Pairof Symbol Any)))
+;; All the items below are quoted and aggregated into all-remembered-list.
+;; The lines below are automatically added by remember-lib.
(structure a b c)
(structure a b c d)
(structure a b c y)
diff --git a/graph-lib/graph/rewrite-type-test.rkt b/graph-lib/graph/rewrite-type-test.rkt
new file mode 100644
index 00000000..93e9c8ff
--- /dev/null
+++ b/graph-lib/graph/rewrite-type-test.rkt
@@ -0,0 +1,127 @@
+#lang typed/racket
+
+(module test typed/racket
+ (require (for-syntax (submod "rewrite-type.lp2.rkt" test-syntax)
+ syntax/strip-context))
+
+ (define-syntax (insert-tests stx)
+ (replace-context stx tests))
+
+ (require (for-syntax "rewrite-type.lp2.rkt")
+ typed/rackunit
+ "../type-expander/multi-id.lp2.rkt"
+ "../type-expander/type-expander.lp2.rkt")
+
+ (insert-tests)
+
+ ;; make-fold
+ (define-syntax (make-fold stx)
+ (syntax-case stx ()
+ [(_ name type acc-type [from to pred? fun] ...)
+ #`(begin
+ (: name (→ type
+ acc-type
+ (Pairof #,(replace-in-type #'type #'([from to] ...))
+ acc-type)))
+ (define (name [val : type] [acc : acc-type])
+ (let-values ([([res : #,(replace-in-type #'type
+ #'([from to] ...))]
+ [res-acc : acc-type])
+ (#,(fold-instance #'type
+ #'acc-type
+ #'([from to pred? fun] ...))
+ val
+ acc)])
+ (cons res res-acc))))]))
+
+ ;; fold-instance
+ (begin
+ (make-fold test-fold-1
+ (List String Number (List String String Symbol String))
+ Number
+ [String Number string? (λ ([x : String] [acc : Number])
+ (values (string-length x)
+ (+ acc (string-length x))))])
+
+ (check-equal? (test-fold-1 '("a" 7 ("bb" "cccc" x "dddddddd")) 0)
+ '((1 7 (2 4 x 8)) . 15)))
+
+ (begin
+ (make-fold test-fold-list
+ (List String Number (Pairof String String) Symbol)
+ Number
+ [String Number string? (λ ([x : String] [acc : Number])
+ (values (string-length x)
+ (+ acc (string-length x))))])
+
+ (check-equal? (test-fold-list '("a" 9 ("bb" . "cccc") x) 0)
+ '((1 9 (2 . 4) x) . 7)))
+
+ (begin
+ (make-fold test-fold-pairof
+ (Pairof String (Pairof Number String))
+ Number
+ [String Number string? (λ ([x : String] [acc : Number])
+ (values (string-length x)
+ (+ acc (string-length x))))])
+
+ (check-equal? (test-fold-pairof '("a" 7 . "bb") 0)
+ '((1 7 . 2) . 3)))
+
+ (begin
+ (make-fold test-fold-listof
+ (List String Number (Listof String) Symbol String)
+ Number
+ [String Number string? (λ ([x : String] [acc : Number])
+ (values (string-length x)
+ (+ acc (string-length x))))])
+
+ (check-equal? (test-fold-listof
+ '("a" 7 ("bb" "cccc" "dddddddd") x "eeeeeeeeeeeeeeee")
+ 0)
+ '((1 7 (2 4 8) x 16) . 31)))
+
+ (begin
+ (make-fold test-fold-vector
+ (Vector String Number (Vectorof String) Symbol String)
+ Number
+ [String Number string? (λ ([x : String] [acc : Number])
+ (values (string-length x)
+ (+ acc (string-length x))))])
+
+ (check-equal? (test-fold-vector
+ '#("a" 7 #("bb" "cccc" "dddddddd") x "eeeeeeeeeeeeeeee")
+ 0)
+ '(#(1 7 #(2 4 8) x 16) . 31)))
+
+ (begin
+ (make-fold test-fold-vectorof
+ (Vectorof (U (List 'tag1 String String) (List 'tag2 Number)))
+ Number
+ [String Number string? (λ ([x : String] [acc : Number])
+ (values (string-length x)
+ (+ acc (string-length x))))])
+
+ (check-equal? (test-fold-vectorof
+ '#((tag1 "a" "bb") (tag2 7) (tag1 "cccc" "dddddddd"))
+ 0)
+ '(#((tag1 1 2) (tag2 7) (tag1 4 8)) . 15)))
+
+
+ (begin
+ (make-fold test-fold-big
+ (List (Pairof (U (List 'tag1 (List (Vector Symbol)
+ Number
+ (Listof String)))
+ (List 'tag2 (List (Vector Symbol)
+ Number
+ (Listof String))))
+ String))
+ Number
+ [String Number string? (λ ([x : String] [acc : Number])
+ (values (string-length x)
+ (+ acc (string-length x))))])
+
+ (check-equal?
+ (test-fold-big '(((tag2 (#(sym) 7 ("a" "bb" "cccc"))) . "dddddddd")) 0)
+ '((((tag2 (#(sym) 7 (1 2 4))) . 8)) . 15))))
\ No newline at end of file
diff --git a/graph-lib/graph/rewrite-type.lp2.rkt b/graph-lib/graph/rewrite-type.lp2.rkt
index 2edfddc3..a53afc45 100644
--- a/graph-lib/graph/rewrite-type.lp2.rkt
+++ b/graph-lib/graph/rewrite-type.lp2.rkt
@@ -285,119 +285,6 @@ have each substitution have a different accumulator by using @tc[list] or
The order in which the elements of the structure are passed to the substitution
functions is undefined.
-@subsection{Tests}
-
-@CHUNK[<test-fold-instance>
- (make-fold test-fold-1
- (List String Number (List String String Symbol String))
- Number
- [String Number string? (λ ([x : String] [acc : Number])
- (values (string-length x)
- (+ acc (string-length x))))])
-
- (check-equal? (test-fold-1 '("a" 7 ("bb" "cccc" x "dddddddd")) 0)
- '((1 7 (2 4 x 8)) . 15))]
-
-@CHUNK[<test-fold-instance>
- (make-fold test-fold-list
- (List String Number (Pairof String String) Symbol)
- Number
- [String Number string? (λ ([x : String] [acc : Number])
- (values (string-length x)
- (+ acc (string-length x))))])
-
- (check-equal? (test-fold-list '("a" 9 ("bb" . "cccc") x) 0)
- '((1 9 (2 . 4) x) . 7))]
-
-@CHUNK[<test-fold-instance>
- (make-fold test-fold-pairof
- (Pairof String (Pairof Number String))
- Number
- [String Number string? (λ ([x : String] [acc : Number])
- (values (string-length x)
- (+ acc (string-length x))))])
-
- (check-equal? (test-fold-pairof '("a" 7 . "bb") 0)
- '((1 7 . 2) . 3))]
-
-@CHUNK[<test-fold-instance>
- (make-fold test-fold-listof
- (List String Number (Listof String) Symbol String)
- Number
- [String Number string? (λ ([x : String] [acc : Number])
- (values (string-length x)
- (+ acc (string-length x))))])
-
- (check-equal? (test-fold-listof
- '("a" 7 ("bb" "cccc" "dddddddd") x "eeeeeeeeeeeeeeee")
- 0)
- '((1 7 (2 4 8) x 16) . 31))]
-
-@CHUNK[<test-fold-instance>
- (make-fold test-fold-vector
- (Vector String Number (Vectorof String) Symbol String)
- Number
- [String Number string? (λ ([x : String] [acc : Number])
- (values (string-length x)
- (+ acc (string-length x))))])
-
- (check-equal? (test-fold-vector
- '#("a" 7 #("bb" "cccc" "dddddddd") x "eeeeeeeeeeeeeeee")
- 0)
- '(#(1 7 #(2 4 8) x 16) . 31))]
-
-@CHUNK[<test-fold-instance>
- (make-fold test-fold-vectorof
- (Vectorof (U (List 'tag1 String String) (List 'tag2 Number)))
- Number
- [String Number string? (λ ([x : String] [acc : Number])
- (values (string-length x)
- (+ acc (string-length x))))])
-
- (check-equal? (test-fold-vectorof
- '#((tag1 "a" "bb") (tag2 7) (tag1 "cccc" "dddddddd"))
- 0)
- '(#((tag1 1 2) (tag2 7) (tag1 4 8)) . 15))]
-
-
-@CHUNK[<test-fold-instance>
- (make-fold test-fold-big
- (List (Pairof (U (List 'tag1 (List (Vector Symbol)
- Number
- (Listof String)))
- (List 'tag2 (List (Vector Symbol)
- Number
- (Listof String))))
- String))
- Number
- [String Number string? (λ ([x : String] [acc : Number])
- (values (string-length x)
- (+ acc (string-length x))))])
-
- (check-equal?
- (test-fold-big '(((tag2 (#(sym) 7 ("a" "bb" "cccc"))) . "dddddddd")) 0)
- '((((tag2 (#(sym) 7 (1 2 4))) . 8)) . 15))]
-
-@CHUNK[<test-make-fold>
- (define-syntax (make-fold stx)
- (syntax-case stx ()
- [(_ name type acc-type [from to pred? fun] ...)
- #`(begin
- (: name (→ type
- acc-type
- (Pairof #,(replace-in-type #'type #'([from to] ...))
- acc-type)))
- (define (name [val : type] [acc : acc-type])
- (let-values ([([res : #,(replace-in-type #'type
- #'([from to] ...))]
- [res-acc : acc-type])
- (#,(fold-instance #'type
- #'acc-type
- #'([from to pred? fun] ...))
- val
- acc)])
- (cons res res-acc))))]))]
-
@subsection{The code}
@CHUNK[<fold-instance>
@@ -700,15 +587,11 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and
(require 'main)
(provide (all-from-out 'main))
- (module* test typed/racket
- (require (for-syntax (submod ".."))
- typed/rackunit
- "../type-expander/multi-id.lp2.rkt"
- "../type-expander/type-expander.lp2.rkt")
-
- <test-make-replace>
- <test-example>
- <test-big>
-
- <test-make-fold>
- <test-fold-instance>))]
+ (module test-syntax racket
+ (provide tests)
+ (define tests
+ (quote-syntax
+ (begin
+ <test-make-replace>
+ <test-example>
+ <test-big>)))))]
diff --git a/graph-lib/graph/structure-test.rkt b/graph-lib/graph/structure-test.rkt
new file mode 100644
index 00000000..c2617406
--- /dev/null
+++ b/graph-lib/graph/structure-test.rkt
@@ -0,0 +1,155 @@
+#lang typed/racket
+
+(module test typed/racket
+ (require (for-syntax (submod "structure.lp2.rkt" test-syntax)
+ syntax/strip-context))
+
+ (define-syntax (insert-tests stx)
+ (replace-context stx tests))
+
+ (require "structure.lp2.rkt"
+ "../lib/low.rkt"
+ "../type-expander/type-expander.lp2.rkt"
+ typed/rackunit)
+
+ (insert-tests)
+
+ ;; structure-get field
+ (begin
+ (check-equal?:
+ (structure-get ((make-structure-constructor a b c d) 1 "b" 'val-c 4) c)
+ : 'val-c
+ 'val-c))
+
+ ;; match-expander
+ (begin
+ (let ([test-match
+ (λ ([val : Any])
+ (match val
+ [(structure a b c y) (list a b c y)]
+ [(structure d
+ [a (? number?)]
+ [c (? symbol?) 'value-c]
+ [b bb (? string?)])
+ (list a bb c d)]
+ [else 'other]))])
+ (check-equal?: (test-match
+ ((make-structure-constructor a b c d) 1
+ "b"
+ 'value-c
+ 4))
+ '(1 "b" value-c 4))
+ (check-equal?: (test-match
+ ((make-structure-constructor a b c y) 1 2 3 4))
+ '(1 2 3 4))
+ (check-equal?: (test-match 'bad) 'other)))
+
+ ;; type-expander
+ (begin
+ (check-equal?
+ (structure-get (ann ((make-structure-constructor a b c) 1 "b" #t)
+ (structure [a Number] [c Boolean] [b String]))
+ b)
+ "b"))
+
+ ;; structure
+ (begin
+ (let ()
+ (define-structure empty-st)
+ (define-structure stA [a Number])
+ ;; BUG 137 (check-equal?: (empty-st) ((structure #:make-instance)))
+ (check-not-equal?: (empty-st) (structure [a 1]))
+ (check-not-equal?: (structure #:make-instance) (structure [a 1]))
+ (check-not-equal?: (empty-st) (stA 1))
+ (check-not-equal?: (structure #:make-instance) (stA 1))
+ (void))
+
+ ;; TODO: uncomment these tests:
+ #;(let ()
+ (define-structure st [a Number] [b String])
+ (define-structure stA [a Number])
+ (define-structure stABC [a Number] [b String] [c Number])
+ (define st1 (st 1 "b"))
+ (define st2 (st 2 "b"))
+ (define sta (stA 1))
+ (define st3 (stABC 1 "b" 3))
+
+ (check-equal?-classes:
+ [#:name st1
+ st1
+ (structure [a 1] [b "b"])
+ (structure [a : Number 1] [b : String "b"])
+ ((structure [a : Number] [b : String]) 1 "b")
+ (structure [a : Any 1] [b : Any "b"])
+ ((structure [a : Any] [b : Any]) 1 "b")
+ ((structure [a] [b]) 1 "b")
+ ((structure a b) 1 "b")
+ ((structure [a] b) 1 "b")]
+ [(structure [a "1"] [b 'b])
+ (structure [a : String "1"] [b : Symbol 'b])
+ (structure [a : Any "1"] [b : Any 'b])]
+ [st2]
+ [sta]
+ [st3])))
+
+ ;; define-structure
+ (begin
+ (define-structure empty-st)
+ (define-structure st [a Number] [b String])
+ (define-structure st2 [b String] [a Number] #:? custom-is-st2?)
+ (define-structure st3 [c String] [a Number] #:? custom-is-st3?))
+
+ ;; Constructor:
+ ;; BUG 137 (check-equal?: (empty-st) : empty-st (empty-st))
+ (begin
+ (check-equal?: (structure-get (st 1 "b") b) : String "b")
+ (check-equal?: (structure-get (st2 "a" 2) b) : String "a"))
+
+ ;; Constructor, as id:
+ (begin
+ (check-equal?: (structure-get (cadr (map st '(1 2 3) '("x" "y" "z"))) b)
+ : String
+ "y")
+ (check-equal?: (structure-get (cadr (map st2 '("d" "e" "f") '(1 2 3))) b)
+ : String
+ "e"))
+
+ ;; type-expander
+ (begin
+ (check-equal?: (structure-get (ann (st2 "g" 123) st2) b) "g"))
+
+ ;; match-expander
+ (begin
+ (check-equal?: (match (st2 "h" 7) [(st x y) (cons x y)])
+ : (Pairof Number String)
+ '(7 . "h")))
+
+ ;; Equality
+ (begin
+ ;; BUG 137 (check-equal?: (ann (st 1 "i") st) (st 1 "i"))
+ ;; BUG 137 (check-equal?: (ann (st2 "j" 2) st2) (st2 "j" 2))
+ ;; BUG 137 (check-equal?: (ann (st 1 "k") st) (st2 "k" 1))
+ )
+
+ ;; Predicate
+ (begin
+ (check-equal?: (st? (ann (st 1 "i") (U st st2))) #t)
+ (check-equal?: (custom-is-st2? (ann (st 1 "i") (U st st2))) #t)
+ (check-equal?: (custom-is-st3? (ann (st 1 "i") (U st st2))) #f)
+ (check-equal?: (st? (ann (st 1 "i") (U Number st st2))) #t)
+ (check-equal?: (st? (ann 1 (U Number st st2))) #f)
+ ;; Occurrence typing won't work well, if only because fields could be of
+ ;; a type for which TR doesn't know how to make-predicate.
+ #|(define (check-occurrence-typing [x : (U Number st st3)])
+ (if (st? x)
+ (match (ann x st) [(st the-a the-b) (cons the-b the-a)])
+ 'other))
+ (check-equal?
+ (check-occurrence-typing (ann (st 1 "i") (U Number st st3)))
+ '("i" . 1))
+ (check-equal?
+ (check-occurrence-typing (ann (st2 "j" 2) (U Number st st3)))
+ 'other)
+ (check-equal?
+ (check-occurrence-typing (ann 9 (U Number st st3)))
+ 'other)|#))
\ No newline at end of file
diff --git a/graph-lib/graph/structure.lp2.rkt b/graph-lib/graph/structure.lp2.rkt
index 050a32d3..64428769 100644
--- a/graph-lib/graph/structure.lp2.rkt
+++ b/graph-lib/graph/structure.lp2.rkt
@@ -64,42 +64,6 @@ handle the empty structure as a special case.
'disappeared-use (stx-map syntax-local-introduce
(template ((?? (?@ (C …)))))))])))]
-@chunk[<test-structure>
- (let ()
- (define-structure empty-st)
- (define-structure stA [a Number])
- ;; BUG 137 (check-equal?: (empty-st) ((structure #:make-instance)))
- (check-not-equal?: (empty-st) (structure [a 1]))
- (check-not-equal?: (structure #:make-instance) (structure [a 1]))
- (check-not-equal?: (empty-st) (stA 1))
- (check-not-equal?: (structure #:make-instance) (stA 1)))
- #;(let ()
- (define-structure st [a Number] [b String])
- (define-structure stA [a Number])
- (define-structure stABC [a Number] [b String] [c Number])
- (define st1 (st 1 "b"))
- (define st2 (st 2 "b"))
- (define sta (stA 1))
- (define st3 (stABC 1 "b" 3))
-
- (check-equal?-classes:
- [#:name st1
- st1
- (structure [a 1] [b "b"])
- (structure [a : Number 1] [b : String "b"])
- ((structure [a : Number] [b : String]) 1 "b")
- (structure [a : Any 1] [b : Any "b"])
- ((structure [a : Any] [b : Any]) 1 "b")
- ((structure [a] [b]) 1 "b")
- ((structure a b) 1 "b")
- ((structure [a] b) 1 "b")]
- [(structure [a "1"] [b 'b])
- (structure [a : String "1"] [b : Symbol 'b])
- (structure [a : Any "1"] [b : Any 'b])]
- [st2]
- [sta]
- [st3]))]
-
@chunk[<define-structure>
(define-syntax (define-structure stx)
(syntax-parse stx
@@ -127,74 +91,6 @@ handle the empty structure as a special case.
[(structure [field _] …) #t]
[_ #f]))))]))]
-
-@chunk[<test-define-structure>
- (define-structure empty-st)
- (define-structure st [a Number] [b String])
- (define-structure st2 [b String] [a Number] #:? custom-is-st2?)
- (define-structure st3 [c String] [a Number] #:? custom-is-st3?)]
-
-Test constructor:
-
-@chunk[<test-define-structure>
- ;; BUG 137 (check-equal?: (empty-st) : empty-st (empty-st))
- (check-equal?: (structure-get (st 1 "b") b) : String "b")
- (check-equal?: (structure-get (st2 "a" 2) b) : String "a")]
-
-Test constructor, as id:
-
-@chunk[<test-define-structure>
- (check-equal?: (structure-get (cadr (map st '(1 2 3) '("x" "y" "z"))) b)
- : String
- "y")
- (check-equal?: (structure-get (cadr (map st2 '("d" "e" "f") '(1 2 3))) b)
- : String
- "e")]
-
-Test the type-expander:
-
-@chunk[<test-define-structure>
- (check-equal?: (structure-get (ann (st2 "g" 123) st2) b) "g")]
-
-Test the match-expander:
-
-@chunk[<test-define-structure>
- (check-equal?: (match (st2 "h" 7) [(st x y) (cons x y)])
- : (Pairof Number String)
- '(7 . "h"))]
-
-Test equality:
-
-@chunk[<test-define-structure>
- ;; BUG 137 (check-equal?: (ann (st 1 "i") st) (st 1 "i"))
- ;; BUG 137 (check-equal?: (ann (st2 "j" 2) st2) (st2 "j" 2))
- ;; BUG 137 (check-equal?: (ann (st 1 "k") st) (st2 "k" 1))
- ]
-
-Test predicate:
-
-@chunk[<test-define-structure>
- (check-equal?: (st? (ann (st 1 "i") (U st st2))) #t)
- (check-equal?: (custom-is-st2? (ann (st 1 "i") (U st st2))) #t)
- (check-equal?: (custom-is-st3? (ann (st 1 "i") (U st st2))) #f)
- (check-equal?: (st? (ann (st 1 "i") (U Number st st2))) #t)
- (check-equal?: (st? (ann 1 (U Number st st2))) #f)
- ;; Occurrence typing won't work well, if only because fields could be of
- ;; a type for which TR doesn't know how to make-predicate.
- #|(define (check-occurrence-typing [x : (U Number st st3)])
- (if (st? x)
- (match (ann x st) [(st the-a the-b) (cons the-b the-a)])
- 'other))
- (check-equal?
- (check-occurrence-typing (ann (st 1 "i") (U Number st st3)))
- '("i" . 1))
- (check-equal?
- (check-occurrence-typing (ann (st2 "j" 2) (U Number st st3)))
- 'other)
- (check-equal?
- (check-occurrence-typing (ann 9 (U Number st st3)))
- 'other)|#]
-
@section{Pre-declaring structs}
We wish to pre-declare all @tc[struct] types for various reasons:
@@ -430,12 +326,6 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
(list-ref (meta-struct-accessors (cdr s) #:srcloc stx)
(indexof (syntax->datum #'field) (reverse (car s))))]
-@chunk[<test-get-field>
- (check-equal?:
- (structure-get ((make-structure-constructor a b c d) 1 "b" 'val-c 4) c)
- : 'val-c
- 'val-c)]
-
@subsection{Predicate}
@chunk[<structure?>
@@ -481,28 +371,6 @@ instead of needing an extra recompilation.
#`(app #,(remember-all-errors #'list stx #'(field ...))
(and pat ...) ...)]
-@chunk[<test-match-expander>
- (let ([test-match
- (λ ([val : Any])
- (match val
- [(structure a b c y) (list a b c y)]
- [(structure d
- [a (? number?)]
- [c (? symbol?) 'value-c]
- [b bb (? string?)])
- (list a bb c d)]
- [else 'other]))])
- (check-equal?: (test-match
- ((make-structure-constructor a b c d) 1
- "b"
- 'value-c
- 4))
- '(1 "b" value-c 4))
- (check-equal?: (test-match
- ((make-structure-constructor a b c y) 1 2 3 4))
- '(1 2 3 4))
- (check-equal?: (test-match 'bad) 'other))]
-
@subsection{Anonymous type}
@subsection{Type-expander}
@@ -527,13 +395,6 @@ instead of needing an extra recompilation.
#`(#,(fields→stx-name #'(field ...)) sorted-type ...)))
(remember-all-errors #'U stx #'(field ...)))]))]
-@chunk[<test-type-expander>
- (check-equal?
- (structure-get (ann ((make-structure-constructor a b c) 1 "b" #t)
- (structure [a Number] [c Boolean] [b String]))
- b)
- "b")]
-
@section[#:tag "structure|remember"]{Closed-world assumption and global
compilation}
@@ -606,18 +467,11 @@ its arguments across compilations, and adds them to the file
(require 'main)
(provide (all-from-out 'main))
- (module* test typed/racket
- (require (submod "..")
- "../lib/low.rkt"
- "../type-expander/type-expander.lp2.rkt"
- typed/rackunit)
-
- <test-make-structure-constructor>
- <test-get-field>
- <test-match-expander>
- <test-type-expander>
- <test-structure>
- <test-define-structure>))]
+ (module test-syntax racket
+ (provide tests)
+ (define tests
+ #'(begin
+ <test-make-structure-constructor>))))]
@section{Optimizing access to fields}
diff --git a/graph-lib/graph/tagged-test.rkt b/graph-lib/graph/tagged-test.rkt
new file mode 100644
index 00000000..565c62cd
--- /dev/null
+++ b/graph-lib/graph/tagged-test.rkt
@@ -0,0 +1,19 @@
+#lang typed/racket
+
+(module test typed/racket
+ (require "tagged.lp2.rkt"
+ "../lib/low.rkt"
+ "../type-expander/type-expander.lp2.rkt")
+
+ (check-equal?: (match (ann (tagged t1 [x 1] [y "b"])
+ (tagged t1 [x : Number] [y : String]))
+ [(tagged t1 [x a] [y b]) (list 'ok b a)]
+ [_ #f])
+ '(ok "b" 1))
+ (check-equal?: (match (ann (tagged foo [x "o"] [y 3] [z 'z])
+ (tagged foo
+ [x String]
+ [z 'z]
+ [y Fixnum]))
+ [(tagged foo z x y) (list z y x)])
+ '(z 3 "o")))
\ No newline at end of file
diff --git a/graph-lib/graph/tagged.lp2.rkt b/graph-lib/graph/tagged.lp2.rkt
index 0045fa8f..d327ae2c 100644
--- a/graph-lib/graph/tagged.lp2.rkt
+++ b/graph-lib/graph/tagged.lp2.rkt
@@ -114,24 +114,6 @@ for a structure.
((structure? field …)
(force (constructor-values v)))))))]
-@section{Tests}
-
-@chunk[<test-tagged>
- (check-equal?: (match (ann (tagged t1 [x 1] [y "b"])
- (tagged t1 [x : Number] [y : String]))
- [(tagged t1 [x a] [y b]) (list 'ok b a)]
- [_ #f])
- '(ok "b" 1))]
-
-@chunk[<test-tagged>
- (check-equal?: (match (ann (tagged foo [x "o"] [y 3] [z 'z])
- (tagged foo
- [x String]
- [z 'z]
- [y Fixnum]))
- [(tagged foo z x y) (list z y x)])
- '(z 3 "o"))]
-
@section{Conclusion}
@chunk[<*>
@@ -159,10 +141,4 @@ for a structure.
<tagged?>)
(require 'main)
- (provide (all-from-out 'main))
-
- (module* test typed/racket
- (require (submod "..")
- "../lib/low.rkt"
- "../type-expander/type-expander.lp2.rkt")
- <test-tagged>))]
\ No newline at end of file
+ (provide (all-from-out 'main)))]
\ No newline at end of file
diff --git a/graph-lib/graph/test-map-get.rkt b/graph-lib/graph/test-map-get.rkt
deleted file mode 100644
index fccb6d96..00000000
--- a/graph-lib/graph/test-map-get.rkt
+++ /dev/null
@@ -1,44 +0,0 @@
-#lang typed/racket
-
-(module test typed/racket
- (require (submod "graph.lp2.rkt" test))
- (require "get.lp2.rkt")
- (require "map.rkt")
- (require "adt.lp2.rkt")
- (require "../lib/low.rkt")
- (require "../type-expander/type-expander.lp2.rkt")
-
- ((tagged t a b c) 1 'b "c")
- ((tagged t a [b] c) 1 'b "c")
- ((tagged t [a] [b] [c]) 1 'b "c")
- ((tagged t [a : Number] [b : Symbol] [c : String]) 1 'b "c")
- (tagged t [a : Number 1] [b : Symbol 'b] [c : String "c"])
- (tagged t [a 1] [b 'b] [c "c"])
-
- (tagged t [a 1] [b 'b] [c "c"])
-
- (define-tagged tabc [a 1] [b 'b] [c "c"])
-
- (map: (λget houses) (get g streets))
- (map: (λget houses … owner name) (get g streets))
- (map: (∘ (curry map (∘ (λget name) (λget owner))) (λget houses))
- (get g streets))
- (map: (∘ (curry map (∘ string-length (λget name) (λget owner))) (λget houses))
- (get g streets))
-
- (map: (compose (curry map identity) (λget houses …)) (get g streets))
- ;; Can be allowed by changing (→ (→ A B) A B) in a couple of places in map: to
- ;; a case→, but it's more heavy on the typechecker, and it's an uncommon case.
- ;(map: (compose (λget houses …) (λ #:∀ (A) ([x : A]) x)) (get g streets))
- (map: (compose (curry map (λget owner)) (λget houses …)) (get g streets))
-
- (get '((1 2) (3)) … …)
- (uniform-get g people)
- (get g people)
- (get g streets cadr houses car owner name)
- ((λget people) g)
- ((λget owner name) (get g streets cadr houses car))
- (get g streets … houses … owner name)
- ((λget streets … houses … owner name) g)
- (let ([f (λget streets … houses … owner name)]) f)
- (map: (λget houses … owner name) (get g streets)))
\ No newline at end of file
diff --git a/graph-lib/graph/uniform-get.lp2.rkt b/graph-lib/graph/uniform-get.lp2.rkt
index 78b51fde..464372a3 100644
--- a/graph-lib/graph/uniform-get.lp2.rkt
+++ b/graph-lib/graph/uniform-get.lp2.rkt
@@ -69,10 +69,4 @@ retrieves the desired field from the structure.
<uniform-get>)
(require 'main)
- (provide (all-from-out 'main))
-
- (module* test typed/racket
- (require (submod "..")
- "../lib/low.rkt"
- "../type-expander/type-expander.lp2.rkt")
- ))]
\ No newline at end of file
+ (provide (all-from-out 'main)))]
\ No newline at end of file
diff --git a/graph-lib/graph/variant-test.rkt b/graph-lib/graph/variant-test.rkt
new file mode 100644
index 00000000..793e6200
--- /dev/null
+++ b/graph-lib/graph/variant-test.rkt
@@ -0,0 +1,24 @@
+#lang typed/racket
+
+(module test typed/racket
+ (require "variant2.lp2.rkt"
+ "constructor.lp2.rkt"
+ "../lib/low.rkt"
+ "../type-expander/type-expander.lp2.rkt")
+
+ (define-variant v1 [x Number String] [y String Number] [z Number String])
+ (check-equal?: (ann (constructor x 1 "a")
+ (U [constructor w Number String]
+ [constructor x Number String]
+ [constructor y String Number]))
+ (constructor x 1 "a"))
+ (check-equal?: (constructor x 1 "a")
+ (constructor x 1 "a"))
+ (check-equal?: (ann (constructor x 1 "a") v1)
+ (constructor x 1 "a"))
+ (check-equal?: (ann (constructor x 1 "a") v1)
+ (ann (constructor x 1 "a") v1))
+ (check-not-equal?: (ann (constructor x 2 "b") v1)
+ (ann (constructor y "b" 2) v1))
+ (check-not-equal?: (ann (constructor x 3 "c") v1)
+ (ann (constructor z 3 "c") v1)))
\ No newline at end of file
diff --git a/graph-lib/graph/variant2.lp2.rkt b/graph-lib/graph/variant2.lp2.rkt
index 15f509b1..4b56f790 100644
--- a/graph-lib/graph/variant2.lp2.rkt
+++ b/graph-lib/graph/variant2.lp2.rkt
@@ -101,26 +101,6 @@ function.
t))
#'(tag …)))|#)]
-@section{Tests}
-
-@chunk[<test-define-variant>
- (define-variant v1 [x Number String] [y String Number] [z Number String])
- (check-equal?: (ann (constructor x 1 "a")
- (U [constructor w Number String]
- [constructor x Number String]
- [constructor y String Number]))
- (constructor x 1 "a"))
- (check-equal?: (constructor x 1 "a")
- (constructor x 1 "a"))
- (check-equal?: (ann (constructor x 1 "a") v1)
- (constructor x 1 "a"))
- (check-equal?: (ann (constructor x 1 "a") v1)
- (ann (constructor x 1 "a") v1))
- (check-not-equal?: (ann (constructor x 2 "b") v1)
- (ann (constructor y "b" 2) v1))
- (check-not-equal?: (ann (constructor x 3 "c") v1)
- (ann (constructor z 3 "c") v1))]
-
@section{Conclusion}
@chunk[<*>
@@ -147,12 +127,4 @@ function.
<define-variant>)
(require 'main)
- (provide (all-from-out 'main))
-
- (module* test typed/racket
- (require (submod "..")
- "constructor.lp2.rkt"
- "../lib/low.rkt"
- "../type-expander/type-expander.lp2.rkt")
-
- <test-define-variant>))]
+ (provide (all-from-out 'main)))]
diff --git a/graph-lib/lib/low/typed-rackunit.rkt b/graph-lib/lib/low/typed-rackunit.rkt
index a6a9007b..93516bb2 100644
--- a/graph-lib/lib/low/typed-rackunit.rkt
+++ b/graph-lib/lib/low/typed-rackunit.rkt
@@ -3,6 +3,7 @@
(define-typed/untyped-modules #:no-test
;; TODO: these won't expand types in the ann.
(provide check-equal?:
+ check-true:
check-not-equal?:
check-ann)
@@ -52,6 +53,26 @@
(untyped:check-true
(equal? (?? (ann actual type) actual)
expected))))))
+
+ (define-syntax/parse
+ (check-true: actual
+ (~optional message:expr))
+ (quasitemplate
+ (with-check-info* (list (make-check-actual (format "~s" actual))
+ (make-check-expected (format "~s" #t))
+ (make-check-name 'check-equal?:)
+ (make-check-params
+ (format "~s" `(,actual)))
+ (make-check-location '(#,(syntax-source stx)
+ #,(syntax-line stx)
+ #,(syntax-column stx)
+ #,(syntax-position stx)
+ #,(syntax-span stx)))
+ (make-check-expression '#,(syntax->datum stx)))
+ (λ ()
+ (untyped:check-true
+ ;; TODO: do we really need the (not (not …)) here?
+ (not (not actual)))))))
(define-syntax/parse
(check-not-equal?: actual