diff --git a/unstable/lens/main.rkt b/unstable/lens/main.rkt index 4393467..80a7828 100644 --- a/unstable/lens/main.rkt +++ b/unstable/lens/main.rkt @@ -14,3 +14,4 @@ "sublist.rkt" "syntax.rkt" "view-set.rkt" +"zoom.rkt" diff --git a/unstable/lens/main.scrbl b/unstable/lens/main.scrbl index 10d51a5..933da27 100644 --- a/unstable/lens/main.scrbl +++ b/unstable/lens/main.scrbl @@ -27,5 +27,6 @@ this library being backwards-compatible. "sublist.scrbl" "syntax.scrbl" "view-set.scrbl" + "zoom.scrbl" ) diff --git a/unstable/lens/zoom.rkt b/unstable/lens/zoom.rkt new file mode 100644 index 0000000..eb21f17 --- /dev/null +++ b/unstable/lens/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 + "isomorphism/base.rkt" +module+ test + require lens/private/list/main + rackunit + "isomorphism/data.rkt" + "mapper.rkt" + +;; 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) + (mapper-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) + (mapper-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/zoom.scrbl b/unstable/lens/zoom.scrbl new file mode 100644 index 0000000..881007e --- /dev/null +++ b/unstable/lens/zoom.scrbl @@ -0,0 +1,41 @@ +#lang scribble/manual + +@(require lens/private/doc-util/main) + +@title{Lenses that transform subpieces} + +@defmodule[unstable/lens/zoom] + +@defproc[(lens-zoom [zoom-lens lens?] [transform-lens lens?]) lens?]{ +Creates a lens that transforms the subpiece of the target that @racket[zoom-lens] +views with @racket[transform-lens]. + +@racketblock[(lens-view (lens-zoom zoom-lens transform-lens) target)] +is equivalent to: +@racketblock[(lens-transform zoom-lens target (λ (v) (lens-view transform-lens v)))] + +@lens-unstable-examples[ + (define first-sym->str + (lens-zoom first-lens symbol->string-lens)) + (lens-view first-sym->str '(a b c)) + (lens-set first-sym->str '(a b c) '("a" b c)) + (lens-set first-sym->str '(a b c) '("z" b c)) + (lens-set first-sym->str '(a b c) '("z" bee sea)) + (lens-view first-sym->str (lens-set first-sym->str '(a b c) '("z" bee sea))) +]} + +@defproc[(lens-zoom* [zoom-lens lens?] [transform-lens lens?] ... ...) lens?]{ +A multi-arg version of @racket[lens-zoom], analogous to +@racket[lens-transform/list]. It is equivalent to +@racket[(lens-thrush (lens-zoom zoom-lens transform-lens) ...)]. +@lens-unstable-examples[ + (define first-sym->str/second-num->str + (lens-zoom* first-lens symbol->string-lens second-lens number->string-lens)) + (lens-view first-sym->str/second-num->str '(a 2 c)) + (lens-set first-sym->str/second-num->str '(a 2 c) '("a" "2" c)) + (lens-set first-sym->str/second-num->str '(a 2 c) '("z" "3" c)) + (lens-set first-sym->str/second-num->str '(a 2 c) '("z" "3" sea)) + (lens-view first-sym->str/second-num->str + (lens-set first-sym->str/second-num->str '(a 2 c) '("z" "3" sea))) +]} +