Moved tests to separate files (part 1).
This commit is contained in:
Georges Dupéron
parent
069109b76f
commit
4daa2bb86a
18
graph-lib/graph/adt-test.rkt
Normal file
18
graph-lib/graph/adt-test.rkt
Normal file
|
|
@ -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"]))
|
||||
23
graph-lib/graph/get-test.rkt
Normal file
23
graph-lib/graph/get-test.rkt
Normal file
|
|
@ -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))))
|
||||
|
|
@ -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)))]
|
||||
|
|
|
|||
15
graph-lib/graph/graph-6-rich-returns-test.rkt
Normal file
15
graph-lib/graph/graph-6-rich-returns-test.rkt
Normal file
|
|
@ -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
|
||||
)
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
||||
|
|
|
|||
263
graph-lib/graph/map-test.rkt
Normal file
263
graph-lib/graph/map-test.rkt
Normal file
|
|
@ -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"))))
|
||||
|
|
@ -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))|#)
|
||||
|
|
@ -8,7 +8,6 @@
|
|||
racket/base
|
||||
racket/syntax)
|
||||
"../lib/low.rkt"
|
||||
"map1.rkt"
|
||||
"get.lp2.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt")
|
||||
|
||||
|
|
|
|||
44
graph-lib/graph/meta-struct-test.rkt
Normal file
44
graph-lib/graph/meta-struct-test.rkt
Normal file
|
|
@ -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)))
|
||||
|
|
@ -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)))
|
||||
41
graph-lib/graph/queue-test.rkt
Normal file
41
graph-lib/graph/queue-test.rkt
Normal file
|
|
@ -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)))))))
|
||||
|
|
@ -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)))]
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
127
graph-lib/graph/rewrite-type-test.rkt
Normal file
127
graph-lib/graph/rewrite-type-test.rkt
Normal file
|
|
@ -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))))
|
||||
|
|
@ -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>)))))]
|
||||
|
|
|
|||
155
graph-lib/graph/structure-test.rkt
Normal file
155
graph-lib/graph/structure-test.rkt
Normal file
|
|
@ -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)|#))
|
||||
|
|
@ -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}
|
||||
|
||||
|
|
|
|||
19
graph-lib/graph/tagged-test.rkt
Normal file
19
graph-lib/graph/tagged-test.rkt
Normal file
|
|
@ -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")))
|
||||
|
|
@ -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>))]
|
||||
(provide (all-from-out 'main)))]
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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")
|
||||
))]
|
||||
(provide (all-from-out 'main)))]
|
||||
24
graph-lib/graph/variant-test.rkt
Normal file
24
graph-lib/graph/variant-test.rkt
Normal file
|
|
@ -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)))
|
||||
|
|
@ -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)))]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user