From 8daf54f964a7fe57ff500c2339c40ab636904131 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 21 Jan 2016 11:40:56 +0100 Subject: [PATCH] Support for `identity` in map:, cleaned up a bit the tests. --- graph-lib/graph/__DEBUG_graph__.rkt | 92 --------------- graph-lib/graph/__DEBUG_require.rkt | 19 ---- graph-lib/graph/map.rkt | 12 +- graph-lib/graph/map4.rkt | 171 ++++++++++++++++++++++++++-- graph-lib/graph/test-map4-get.rkt | 46 ++++++++ graph-lib/main.rkt | 3 +- 6 files changed, 218 insertions(+), 125 deletions(-) delete mode 100644 graph-lib/graph/__DEBUG_graph__.rkt delete mode 100644 graph-lib/graph/__DEBUG_require.rkt create mode 100644 graph-lib/graph/test-map4-get.rkt diff --git a/graph-lib/graph/__DEBUG_graph__.rkt b/graph-lib/graph/__DEBUG_graph__.rkt deleted file mode 100644 index 3c5ca90..0000000 --- a/graph-lib/graph/__DEBUG_graph__.rkt +++ /dev/null @@ -1,92 +0,0 @@ -#lang typed/racket - -#| -(require "structure.lp2.rkt") -(require "variant.lp2.rkt") -(require "../type-expander/type-expander.lp2.rkt") -(require "../lib/low.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 t [a 1] [b 'b] [c "c"]) -|# - -(require "__DEBUG_require.rkt") - -(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)) -;; (map: (compose (λget houses …) (λ #:∀ (A) ([x : A]) x)) (get g streets)) -;; (map: (compose (λget houses …) (curry map (λget owner))) (get g streets)) -;; => TODO: Crashes ../type-expander/type-expander.lp2.rkt:90:7: -;; syntax-local-bind-syntaxes: contract violation -; expected: (listof identifier?) -; given: (#) -; argument position: 1st -; other arguments...: - -#| -(get '((1 2) (3)) … …) -(structure-get (cadr (force 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)) -|# - - -#| -(define #:∀ (A) (map-force [l : (Listof (Promise A))]) - (map (inst force A) l)) - -(map-force (get g people)) -(map-force (get g streets)) -|# - -#| -(let () - (map-force (second g)) - (cars (map-force (second g))) - (map-force (third g)) - (map-force (append* (cars (cdrs (cdrs (map-force (second g))))))) - (void)) - -#| -#R(map-force (second g)) -#R(map-force (third g)) - -(newline) - -#R(force (car (second g))) -#R(force (cadr (force (car (caddr (force (car (second g)))))))) - -(newline) -;|# - -(define (forceall [fuel : Integer] [x : Any]) : Any - (if (> fuel 0) - (cond [(list? x) (map (curry forceall fuel) x)] - [(promise? x) (forceall (sub1 fuel) (force x))] - [else x]) - x)) - -(forceall 5 g) - -|# diff --git a/graph-lib/graph/__DEBUG_require.rkt b/graph-lib/graph/__DEBUG_require.rkt deleted file mode 100644 index 5e25650..0000000 --- a/graph-lib/graph/__DEBUG_require.rkt +++ /dev/null @@ -1,19 +0,0 @@ -#lang typed/racket - -(require (submod "graph3.lp2.rkt" test)) -(require "graph3.lp2.rkt") -(require "graph4.lp2.rkt") -(require "map4.rkt") -(require "structure.lp2.rkt") -(require "variant.lp2.rkt") -(require "../lib/low.rkt") -(require "../type-expander/type-expander.lp2.rkt") - -(provide (all-from-out (submod "graph3.lp2.rkt" test) - "graph3.lp2.rkt" - "graph4.lp2.rkt" - "map4.rkt" - "structure.lp2.rkt" - "variant.lp2.rkt" - "../lib/low.rkt" - "../type-expander/type-expander.lp2.rkt")) \ No newline at end of file diff --git a/graph-lib/graph/map.rkt b/graph-lib/graph/map.rkt index d0bb59c..98ecc51 100644 --- a/graph-lib/graph/map.rkt +++ b/graph-lib/graph/map.rkt @@ -291,12 +291,12 @@ : (Listof Number) '(1 2 3)) - (check-equal?: (map: (curry map car) '([(1 a) (2 b)] [(3 c)])) - : (Listof Number) - '((1 a) (3 c))) - #;(check-equal?: (map: (curry map: car) '([(1 a) (2 b)] [(3 c)])) - : (Listof Number) - '((1 a) (3 c))) + (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))])) diff --git a/graph-lib/graph/map4.rkt b/graph-lib/graph/map4.rkt index 3203088..a92c48f 100644 --- a/graph-lib/graph/map4.rkt +++ b/graph-lib/graph/map4.rkt @@ -4,7 +4,6 @@ racket/function syntax/stx syntax/parse - syntax/parse/experimental/template "../lib/low-untyped.rkt") "../lib/low.rkt" "graph4.lp2.rkt" @@ -51,14 +50,23 @@ (syntax-parse stx [(_ {∀-type:id …} A:expr B:expr 0) #'(ann (λ (f x) (f x)) - (∀ (∀-type …) (→ (→ A B) A B)))] + (∀ (∀-type …) + (→ (→ A B) A B) + ;; Use the type below to allow identity functions, but it's more + ;; heavy on the typechecker + #;(case→ (→ (→ A B) A B) + (→ (→ A A) A A))))] [(_ (~and norun #:norun) … {∀-type:id …} A:expr B:expr d:≥0) (define/with-syntax local-map (generate-temporary #'map)) #`(dbg norun … (let () - (: local-map (∀ (∀-type …) (→ (→ A B) - (Deep-Listof d A) - (Deep-Listof d B)))) + (: local-map + (∀ (∀-type …) + (→ (→ A B) (Deep-Listof d A) (Deep-Listof d B)) + ;; Use the type below to allow identity functions, but it's + ;; more heavy on the typechecker + #;(case→ (→ (→ A B) (Deep-Listof d A) (Deep-Listof d B)) + (→ (→ A A) (Deep-Listof d A) (Deep-Listof d A))))) (define (local-map f l) (if (null? l) '() @@ -170,10 +178,12 @@ (syntax-parse stx [((~literal curry) (~literal map) f:expr) (transform-map: (add1 depth) #'f)] - [((~literal ∘) f:expr …) + [((~literal compose) f:expr …) (define/syntax-parse (([dd ff] …) …) (stx-map (curry transform-map: depth) #'(f …))) #`[(dd ff) … …]] + [(~literal identity) #'[]] + [(~literal values) #'[]] [f:expr #`[(#,depth f)]])) @@ -194,4 +204,151 @@ (curry map (∘))) '([1 2] [3])) : (Listof Number) - '(3 2))) \ No newline at end of file + '(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/test-map4-get.rkt b/graph-lib/graph/test-map4-get.rkt new file mode 100644 index 0000000..1baaf15 --- /dev/null +++ b/graph-lib/graph/test-map4-get.rkt @@ -0,0 +1,46 @@ +#lang typed/racket + +(module test typed/racket + (require (submod "graph3.lp2.rkt" test)) + (require "graph3.lp2.rkt") + (require "graph4.lp2.rkt") + (require "map4.rkt") + (require "structure.lp2.rkt") + (require "variant.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)) … …) + (structure-get (cadr (force 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/main.rkt b/graph-lib/main.rkt index 15aa9a8..a48fa80 100644 --- a/graph-lib/main.rkt +++ b/graph-lib/main.rkt @@ -1,10 +1,11 @@ #lang typed/racket +(require (submod "graph/test-map4-get.rkt" test)) + (require "type-expander/type-expander.lp2.rkt") (require "type-expander/multi-id.lp2.rkt") (require "graph/variant.lp2.rkt") - (define-type from (List (Pairof Number Boolean) (Listof (U Number (Pairof Number String))))) (define-type to (List (Pairof String Boolean)