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[ - (check-equal? 42 42)] - @section{Conclusion} @chunk[ @@ -168,18 +165,9 @@ name) with the right type, so that the user doesn't see all the types in the )] -@chunk[ - (module* test typed/racket - (require (submod "..") - typed/rackunit) - - )] - @chunk[<*> (begin (require 'main) - (provide (all-from-out 'main)) - - )] + (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. )] @chunk[ - (module* test typed/racket - (require (submod "..") - typed/rackunit) - - ;; - )] + (module test-syntax racket + (provide tests) + (define tests + (quote-syntax + (begin + ))))] @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[ 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) 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. ) - (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[ - (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[ - (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[ - (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[ - (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[ - (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[ - (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[ - (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[ - (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[ @@ -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") - - - - - - - ))] + (module test-syntax racket + (provide tests) + (define tests + (quote-syntax + (begin + + + )))))] 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[ - (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-syntax (define-structure stx) (syntax-parse stx @@ -127,74 +91,6 @@ handle the empty structure as a special case. [(structure [field _] …) #t] [_ #f]))))]))] - -@chunk[ - (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[ - ;; 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[ - (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[ - (check-equal?: (structure-get (ann (st2 "g" 123) st2) b) "g")] - -Test the match-expander: - -@chunk[ - (check-equal?: (match (st2 "h" 7) [(st x y) (cons x y)]) - : (Pairof Number String) - '(7 . "h"))] - -Test equality: - -@chunk[ - ;; 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[ - (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[ - (check-equal?: - (structure-get ((make-structure-constructor a b c d) 1 "b" 'val-c 4) c) - : 'val-c - 'val-c)] - @subsection{Predicate} @chunk[ @@ -481,28 +371,6 @@ instead of needing an extra recompilation. #`(app #,(remember-all-errors #'list stx #'(field ...)) (and pat ...) ...)] -@chunk[ - (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[ - (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) - - - - - - - ))] + (module test-syntax racket + (provide tests) + (define tests + #'(begin + ))))] @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[ - (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[ - (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. ) (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/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. ) (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[ - (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. ) (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") - - ))] + (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