move lazy.rkt and zoom.rkt to lens/private/compound
This commit is contained in:
AlexKnauth
parent
b9a42a35a9
commit
fe35b41062
32
lens/private/compound/lazy.rkt
Normal file
32
lens/private/compound/lazy.rkt
Normal file
|
|
@ -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)))
|
||||
|
||||
104
lens/private/compound/zoom.rkt
Normal file
104
lens/private/compound/zoom.rkt
Normal file
|
|
@ -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)))
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user