diff --git a/lens/private/compound/lazy.rkt b/lens/private/compound/lazy.rkt new file mode 100644 index 0000000..887e0c7 --- /dev/null +++ b/lens/private/compound/lazy.rkt @@ -0,0 +1,32 @@ +#lang sweet-exp racket/base + +provide lazy-lens + rec-lens + +require fancy-app lens/private/base/main racket/promise +module+ test + require rackunit + lens/private/compound/if + lens/private/isomorphism/data + lens/private/list/map + +(define-syntax-rule (lazy-lens expr) + (let ([p (delay expr)]) + (make-lens (lens-view (force p) _) (lens-set (force p) _ _)))) + +(define-syntax-rule (rec-lens name expr) + (letrec ([name (lazy-lens expr)]) + name)) + +module+ test + (define (tree-map-lens item-lens) + (rec-lens the-tree-lens + (lens-cond [list? (map-lens the-tree-lens)] + [else item-lens]))) + (check-equal? (lens-view (tree-map-lens symbol->string-lens) '(a (b (() c)) (d))) + '("a" ("b" (() "c")) ("d"))) + (check-equal? (lens-set (tree-map-lens symbol->string-lens) + '(a (b (() c)) (d)) + '("hay" ("bee" (() "sea")) ("deep"))) + '(hay (bee (() sea)) (deep))) + diff --git a/lens/private/compound/zoom.rkt b/lens/private/compound/zoom.rkt new file mode 100644 index 0000000..faff3fe --- /dev/null +++ b/lens/private/compound/zoom.rkt @@ -0,0 +1,104 @@ +#lang sweet-exp racket/base + +require racket/contract/base +provide + contract-out + lens-zoom (-> lens? lens? lens?) + lens-zoom* (->* [] #:rest (listof2 lens? lens?) lens?) + +require fancy-app + lens/private/base/main + lens/private/compound/thrush + lens/private/util/list-pair-contract + racket/match + unstable/sequence + lens/private/isomorphism/base +module+ test + require lens/private/list/main + rackunit + lens/private/isomorphism/data + lens/private/list/map + +;; lens-zoom : (Lens (Outer Inner) Inner) (Lens A B) -> (Lens (Outer A) (Outer B)) +(define (lens-zoom zoom-lens transformer-lens) + (match transformer-lens + [(make-isomorphism-lens transformer inverse) + ;; transformer : A -> B + ;; inverse : B -> A + (make-isomorphism-lens + (lens-transform zoom-lens _ transformer) ; (Outer A) -> (Outer B) + (lens-transform zoom-lens _ inverse))] ; (Outer B) -> (Outer A) + [transformer-lens + ;; get : (Outer A) -> (Outer B) + (define (get tgt) + ;; transformer : A -> B + (define (transformer a) + (lens-view transformer-lens a)) + (lens-transform zoom-lens tgt transformer)) + ;; set : (Outer A) (Outer B) -> (Outer A) + (define (set tgt nvw) + ;; a : A + (define a (lens-view zoom-lens tgt)) + ;; transformer : B -> A + (define (transformer b) + (lens-set transformer-lens a b)) + (lens-transform zoom-lens nvw transformer)) + (make-lens get set)])) + +(define (lens-zoom* . lenses/transformers) + (apply lens-thrush + (for/list ([args (in-slice 2 lenses/transformers)]) + (apply lens-zoom args)))) + +module+ test + (define first-sym->str + (lens-zoom first-lens symbol->string-lens)) + (check-equal? (lens-view first-sym->str '(a b c)) + '("a" b c)) + (check-equal? (lens-set first-sym->str '(a b c) '("a" b c)) + '(a b c)) + (check-equal? (lens-set first-sym->str '(a b c) '("z" b c)) + '(z b c)) + (check-equal? (lens-set first-sym->str '(a b c) '("z" bee sea)) + '(z bee sea)) + (check-equal? (lens-view first-sym->str (lens-set first-sym->str '(a b c) '("z" bee sea))) + '("z" bee sea)) + (define trans-second-first/third-second + (lens-zoom* second-lens first-lens third-lens second-lens)) + (check-equal? (lens-view trans-second-first/third-second '(1 (2 3) (4 5))) + '(1 2 5)) + (check-equal? (lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(1 2 5)) + '(1 (2 3) (4 5))) + (check-equal? (lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(1 b 5)) + '(1 (b 3) (4 5))) + (check-equal? (lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(a b c)) + '(a (b 3) (4 c))) + (check-equal? (lens-view trans-second-first/third-second + (lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(a b c))) + '(a b c)) + (define (rekey-alist-lens key->new-key-lens) + (map-lens (lens-zoom car-lens key->new-key-lens))) + (check-equal? (lens-view (rekey-alist-lens symbol->string-lens) '((a . 1) (b . 2) (c . 3))) + '(("a" . 1) ("b" . 2) ("c" . 3))) + (check-equal? (lens-set (rekey-alist-lens symbol->string-lens) + '((a . 1) (b . 2) (c . 3)) + '(("a" . 10) ("b" . 200) ("c" . 3000))) + '((a . 10) (b . 200) (c . 3000))) + (check-equal? (lens-set (rekey-alist-lens symbol->string-lens) + '((a . 1) (b . 2) (c . 3)) + '(("one" . 10) ("two" . 200) ("three" . 3000))) + '((one . 10) (two . 200) (three . 3000))) + (define (rek+v-alist-lens key->new-key-lens value->new-value-lens) + (map-lens (lens-zoom* car-lens key->new-key-lens cdr-lens value->new-value-lens))) + (check-equal? (lens-view (rek+v-alist-lens symbol->string-lens number->string-lens) + '((a . 1) (b . 2) (c . 3))) + '(("a" . "1") ("b" . "2") ("c" . "3"))) + (check-equal? (lens-set (rek+v-alist-lens symbol->string-lens number->string-lens) + '((a . 1) (b . 2) (c . 3)) + '(("a" . "10") ("b" . "200") ("c" . "3000"))) + '((a . 10) (b . 200) (c . 3000))) + (check-equal? (lens-set (rek+v-alist-lens symbol->string-lens number->string-lens) + '((a . 1) (b . 2) (c . 3)) + '(("one" . "10") ("two" . "200") ("three" . "3000"))) + '((one . 10) (two . 200) (three . 3000))) + diff --git a/unstable/lens/lazy.rkt b/unstable/lens/lazy.rkt index 887e0c7..f18000b 100644 --- a/unstable/lens/lazy.rkt +++ b/unstable/lens/lazy.rkt @@ -1,32 +1,2 @@ -#lang sweet-exp racket/base - -provide lazy-lens - rec-lens - -require fancy-app lens/private/base/main racket/promise -module+ test - require rackunit - lens/private/compound/if - lens/private/isomorphism/data - lens/private/list/map - -(define-syntax-rule (lazy-lens expr) - (let ([p (delay expr)]) - (make-lens (lens-view (force p) _) (lens-set (force p) _ _)))) - -(define-syntax-rule (rec-lens name expr) - (letrec ([name (lazy-lens expr)]) - name)) - -module+ test - (define (tree-map-lens item-lens) - (rec-lens the-tree-lens - (lens-cond [list? (map-lens the-tree-lens)] - [else item-lens]))) - (check-equal? (lens-view (tree-map-lens symbol->string-lens) '(a (b (() c)) (d))) - '("a" ("b" (() "c")) ("d"))) - (check-equal? (lens-set (tree-map-lens symbol->string-lens) - '(a (b (() c)) (d)) - '("hay" ("bee" (() "sea")) ("deep"))) - '(hay (bee (() sea)) (deep))) - +#lang reprovide +lens/private/compound/lazy diff --git a/unstable/lens/zoom.rkt b/unstable/lens/zoom.rkt index faff3fe..c3abc49 100644 --- a/unstable/lens/zoom.rkt +++ b/unstable/lens/zoom.rkt @@ -1,104 +1,2 @@ -#lang sweet-exp racket/base - -require racket/contract/base -provide - contract-out - lens-zoom (-> lens? lens? lens?) - lens-zoom* (->* [] #:rest (listof2 lens? lens?) lens?) - -require fancy-app - lens/private/base/main - lens/private/compound/thrush - lens/private/util/list-pair-contract - racket/match - unstable/sequence - lens/private/isomorphism/base -module+ test - require lens/private/list/main - rackunit - lens/private/isomorphism/data - lens/private/list/map - -;; lens-zoom : (Lens (Outer Inner) Inner) (Lens A B) -> (Lens (Outer A) (Outer B)) -(define (lens-zoom zoom-lens transformer-lens) - (match transformer-lens - [(make-isomorphism-lens transformer inverse) - ;; transformer : A -> B - ;; inverse : B -> A - (make-isomorphism-lens - (lens-transform zoom-lens _ transformer) ; (Outer A) -> (Outer B) - (lens-transform zoom-lens _ inverse))] ; (Outer B) -> (Outer A) - [transformer-lens - ;; get : (Outer A) -> (Outer B) - (define (get tgt) - ;; transformer : A -> B - (define (transformer a) - (lens-view transformer-lens a)) - (lens-transform zoom-lens tgt transformer)) - ;; set : (Outer A) (Outer B) -> (Outer A) - (define (set tgt nvw) - ;; a : A - (define a (lens-view zoom-lens tgt)) - ;; transformer : B -> A - (define (transformer b) - (lens-set transformer-lens a b)) - (lens-transform zoom-lens nvw transformer)) - (make-lens get set)])) - -(define (lens-zoom* . lenses/transformers) - (apply lens-thrush - (for/list ([args (in-slice 2 lenses/transformers)]) - (apply lens-zoom args)))) - -module+ test - (define first-sym->str - (lens-zoom first-lens symbol->string-lens)) - (check-equal? (lens-view first-sym->str '(a b c)) - '("a" b c)) - (check-equal? (lens-set first-sym->str '(a b c) '("a" b c)) - '(a b c)) - (check-equal? (lens-set first-sym->str '(a b c) '("z" b c)) - '(z b c)) - (check-equal? (lens-set first-sym->str '(a b c) '("z" bee sea)) - '(z bee sea)) - (check-equal? (lens-view first-sym->str (lens-set first-sym->str '(a b c) '("z" bee sea))) - '("z" bee sea)) - (define trans-second-first/third-second - (lens-zoom* second-lens first-lens third-lens second-lens)) - (check-equal? (lens-view trans-second-first/third-second '(1 (2 3) (4 5))) - '(1 2 5)) - (check-equal? (lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(1 2 5)) - '(1 (2 3) (4 5))) - (check-equal? (lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(1 b 5)) - '(1 (b 3) (4 5))) - (check-equal? (lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(a b c)) - '(a (b 3) (4 c))) - (check-equal? (lens-view trans-second-first/third-second - (lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(a b c))) - '(a b c)) - (define (rekey-alist-lens key->new-key-lens) - (map-lens (lens-zoom car-lens key->new-key-lens))) - (check-equal? (lens-view (rekey-alist-lens symbol->string-lens) '((a . 1) (b . 2) (c . 3))) - '(("a" . 1) ("b" . 2) ("c" . 3))) - (check-equal? (lens-set (rekey-alist-lens symbol->string-lens) - '((a . 1) (b . 2) (c . 3)) - '(("a" . 10) ("b" . 200) ("c" . 3000))) - '((a . 10) (b . 200) (c . 3000))) - (check-equal? (lens-set (rekey-alist-lens symbol->string-lens) - '((a . 1) (b . 2) (c . 3)) - '(("one" . 10) ("two" . 200) ("three" . 3000))) - '((one . 10) (two . 200) (three . 3000))) - (define (rek+v-alist-lens key->new-key-lens value->new-value-lens) - (map-lens (lens-zoom* car-lens key->new-key-lens cdr-lens value->new-value-lens))) - (check-equal? (lens-view (rek+v-alist-lens symbol->string-lens number->string-lens) - '((a . 1) (b . 2) (c . 3))) - '(("a" . "1") ("b" . "2") ("c" . "3"))) - (check-equal? (lens-set (rek+v-alist-lens symbol->string-lens number->string-lens) - '((a . 1) (b . 2) (c . 3)) - '(("a" . "10") ("b" . "200") ("c" . "3000"))) - '((a . 10) (b . 200) (c . 3000))) - (check-equal? (lens-set (rek+v-alist-lens symbol->string-lens number->string-lens) - '((a . 1) (b . 2) (c . 3)) - '(("one" . "10") ("two" . "200") ("three" . "3000"))) - '((one . 10) (two . 200) (three . 3000))) - +#lang reprovide +lens/private/compound/zoom