diff --git a/lens/private/base/rename.rkt b/lens/private/base/rename.rkt new file mode 100644 index 0000000..8415d6e --- /dev/null +++ b/lens/private/base/rename.rkt @@ -0,0 +1,43 @@ +#lang sweet-exp racket/base + +require racket/contract/base +provide + contract-out + lens-rename (-> lens? any/c lens?) + +require racket/generic + racket/match + "gen-lens.rkt" +module+ test + require rackunit racket/list racket/function "make-lens.rkt" + +(struct renamed-lens (lens name) + #:methods gen:lens + [(define/generic view lens-view) + (define/generic set lens-set) + (define/generic focus focus-lens) + (define (lens-view this target) + (view (renamed-lens-lens this) target)) + (define (lens-set this target x) + (set (renamed-lens-lens this) target x)) + (define (focus-lens this target) + (focus (renamed-lens-lens this) target))] + #:methods gen:custom-write + [(define (write-proc this out mode) + (fprintf out "#" (renamed-lens-name this)))]) + +(define (lens-rename lens name) + (match lens + [(renamed-lens lens _) + (renamed-lens lens name)] + [lens + (renamed-lens lens name)])) + +module+ test + (define (set-first l v) + (list* v (rest l))) + (define first-lens (lens-rename (make-lens first set-first) 'first-lens)) + (let-lens (view-first setter-first) first-lens '(1 2 3 4 5) + (check-eqv? view-first 1) + (check-equal? (setter-first 'a) '(a 2 3 4 5))) + (check-equal? (format "~v" first-lens) "#") diff --git a/lens/private/compound/compose.rkt b/lens/private/compound/compose.rkt index 6324e5d..31e5abf 100644 --- a/lens/private/compound/compose.rkt +++ b/lens/private/compound/compose.rkt @@ -5,6 +5,7 @@ require racket/contract racket/match fancy-app "../base/main.rkt" + "../base/rename.rkt" "../util/rest-contract.rkt" "identity.rkt" @@ -25,7 +26,7 @@ provide (define sub-view (lens-view super-lens target)) (define new-sub-view (lens-set sub-lens sub-view new-view)) (lens-set super-lens target new-sub-view)) - (make-lens get set)) + (lens-rename (make-lens get set) 'composed)) (define (lens-compose . args) diff --git a/lens/private/compound/join-hash.rkt b/lens/private/compound/join-hash.rkt index 095ed55..0f545a3 100644 --- a/lens/private/compound/join-hash.rkt +++ b/lens/private/compound/join-hash.rkt @@ -5,6 +5,7 @@ unstable/sequence fancy-app "../base/main.rkt" + "../base/rename.rkt" "../util/alternating-list.rkt" "../util/immutable.rkt" "../util/list-pair-contract.rkt" @@ -30,7 +31,7 @@ (keys+values->hash keys (lens-view list-lens target))) (define (set target new-view-hash) (lens-set list-lens target (map (hash-ref new-view-hash _) keys))) - (make-lens get set)) + (lens-rename (make-lens get set) `(lens-join/hash ...))) (module+ test (define a-b-lens (lens-join/hash 'b third-lens diff --git a/lens/private/compound/join-list.rkt b/lens/private/compound/join-list.rkt index 816acce..9c73a12 100644 --- a/lens/private/compound/join-list.rkt +++ b/lens/private/compound/join-list.rkt @@ -3,6 +3,7 @@ require racket/list racket/contract "../base/main.rkt" + "../base/rename.rkt" "../util/alternating-list.rkt" "../util/rest-contract.rkt" @@ -21,7 +22,7 @@ provide (apply lens-view/list target lenses)) (define (set target new-views) (apply lens-set/list target (keys+values->alternating-list lenses new-views))) - (make-lens get set)) + (lens-rename (make-lens get set) `(lens-join/list ...))) (module+ test diff --git a/lens/private/compound/join-string.rkt b/lens/private/compound/join-string.rkt index a57ed67..bb41b01 100644 --- a/lens/private/compound/join-string.rkt +++ b/lens/private/compound/join-string.rkt @@ -3,6 +3,7 @@ require racket/contract unstable/lens/isomorphism/base "../base/main.rkt" + "../base/rename.rkt" "../util/immutable.rkt" "../util/rest-contract.rkt" "compose.rkt" @@ -19,7 +20,8 @@ provide (define (lens-join/string . lenses) - (lens-compose list->string-lens (apply lens-join/list lenses))) + (lens-rename (lens-compose list->string-lens (apply lens-join/list lenses)) + `(lens-join/string ...))) (define list->string-lens (make-isomorphism-lens list->immutable-string string->list)) diff --git a/lens/private/compound/join-vector.rkt b/lens/private/compound/join-vector.rkt index ccb0742..f92f025 100644 --- a/lens/private/compound/join-vector.rkt +++ b/lens/private/compound/join-vector.rkt @@ -3,6 +3,7 @@ require racket/contract unstable/lens/isomorphism/base "../base/main.rkt" + "../base/rename.rkt" "../util/immutable.rkt" "../util/rest-contract.rkt" "compose.rkt" @@ -19,7 +20,8 @@ provide (define (lens-join/vector . lenses) - (lens-compose list->vector-lens (apply lens-join/list lenses))) + (lens-rename (lens-compose list->vector-lens (apply lens-join/list lenses)) + `(lens-join/vector ...))) (define list->vector-lens (make-isomorphism-lens list->immutable-vector vector->list)) diff --git a/lens/private/hash/ref.rkt b/lens/private/hash/ref.rkt index 1beeee7..d56d2c0 100644 --- a/lens/private/hash/ref.rkt +++ b/lens/private/hash/ref.rkt @@ -3,6 +3,7 @@ (require racket/contract fancy-app "../base/main.rkt" + "../base/rename.rkt" "../util/immutable.rkt") (module+ test @@ -14,8 +15,10 @@ (define (hash-ref-lens key) - (make-lens (hash-ref _ key) - (hash-set _ key _))) + (lens-rename + (make-lens (hash-ref _ key) + (hash-set _ key _)) + `(hash-ref-lens ,(format "~v" key)))) (module+ test (define a (hash-ref-lens 'a)) diff --git a/lens/private/list/assoc.rkt b/lens/private/list/assoc.rkt index 4020e8c..02c66c1 100644 --- a/lens/private/list/assoc.rkt +++ b/lens/private/list/assoc.rkt @@ -12,7 +12,8 @@ )) (require fancy-app - "../base/main.rkt") + "../base/main.rkt" + "../base/rename.rkt") (module+ test (require rackunit "../test-util/test-lens.rkt") @@ -38,10 +39,14 @@ (check-equal? (assoc-set assoc-list 'b 200) '((a . 1) (b . 200) (c . 3)))) -(define (assoc-lens key #:is-equal? [equal? equal?]) - (define get (assoc-get _ key #:is-equal? equal?)) - (define set (assoc-set _ key _ #:is-equal? equal?)) - (make-lens get set)) +(define (assoc-lens key #:is-equal? [equal-proc equal?]) + (define get (assoc-get _ key #:is-equal? equal-proc)) + (define set (assoc-set _ key _ #:is-equal? equal-proc)) + (lens-rename (make-lens get set) + (cond [(eq? equal-proc equal?) `(assoc-lens ,(format "~v" key))] + [(eq? equal-proc eqv?) `(assv-lens ,(format "~v" key))] + [(eq? equal-proc eq?) `(assq-lens ,(format "~v" key))] + [else `(assoc-lens ,(format "~v" key) ...)]))) (module+ test (define assoc-b-lens (assoc-lens 'b)) diff --git a/lens/private/list/cadr-etc.rkt b/lens/private/list/cadr-etc.rkt index 04a8d44..77914b3 100644 --- a/lens/private/list/cadr-etc.rkt +++ b/lens/private/list/cadr-etc.rkt @@ -3,6 +3,7 @@ (require racket/contract syntax/parse/define "../base/main.rkt" + "../base/rename.rkt" "../compound/main.rkt" "car-cdr.rkt" (for-syntax racket/base @@ -45,7 +46,7 @@ (define-simple-macro (define-c_r-lens id:id) #:with c_r-lens (c_r-lens-id #'id) - (define c_r-lens (c_r->lens 'id))) + (define c_r-lens (lens-rename (c_r->lens 'id) 'c_r-lens))) (define-simple-macro (define-c_r-lenses id:id ...) (begin (define-c_r-lens id) ...)) diff --git a/lens/private/list/car-cdr.rkt b/lens/private/list/car-cdr.rkt index 5d6c92d..195cc3e 100644 --- a/lens/private/list/car-cdr.rkt +++ b/lens/private/list/car-cdr.rkt @@ -5,7 +5,7 @@ (contract-out [car-lens (lens/c pair? any/c)] [cdr-lens (lens/c pair? any/c)])) -(require "../base/main.rkt") +(require "../base/main.rkt" "../base/rename.rkt") (module+ test (require rackunit @@ -18,8 +18,8 @@ (define (set-cdr pair v) (cons (car pair) v)) -(define car-lens (make-lens car set-car)) -(define cdr-lens (make-lens cdr set-cdr)) +(define car-lens (lens-rename (make-lens car set-car) 'car-lens)) +(define cdr-lens (lens-rename (make-lens cdr set-cdr) 'cdr-lens)) (module+ test (check-lens-view car-lens '(1 . 2) 1) diff --git a/lens/private/list/list-ref-take-drop.rkt b/lens/private/list/list-ref-take-drop.rkt index 6e25dee..69364fd 100644 --- a/lens/private/list/list-ref-take-drop.rkt +++ b/lens/private/list/list-ref-take-drop.rkt @@ -27,6 +27,7 @@ fancy-app "../util/improper-list-length.rkt" "../base/main.rkt" + "../base/rename.rkt" "../compound/compose.rkt" "car-cdr.rkt") @@ -49,7 +50,9 @@ (define (take-lens n) - (make-lens (take _ n) (set-take n _ _))) + (lens-rename + (make-lens (take _ n) (set-take n _ _)) + `(take-lens ,n))) (module+ test (define take2-lens (take-lens 2)) @@ -58,7 +61,9 @@ (define (drop-lens n) - (make-lens (drop _ n) (set-drop n _ _))) + (lens-rename + (make-lens (drop _ n) (set-drop n _ _)) + `(drop-lens ,n))) (module+ test (define drop2-lens (drop-lens 2)) @@ -67,18 +72,20 @@ (define (list-ref-lens i) - (lens-compose car-lens (drop-lens i))) - -(define first-lens (list-ref-lens 0)) -(define second-lens (list-ref-lens 1)) -(define third-lens (list-ref-lens 2)) -(define fourth-lens (list-ref-lens 3)) -(define fifth-lens (list-ref-lens 4)) -(define sixth-lens (list-ref-lens 5)) -(define seventh-lens (list-ref-lens 6)) -(define eighth-lens (list-ref-lens 7)) -(define ninth-lens (list-ref-lens 8)) -(define tenth-lens (list-ref-lens 9)) + (lens-rename + (lens-compose car-lens (drop-lens i)) + `(list-ref-lens ,i))) + +(define first-lens (lens-rename (list-ref-lens 0) 'first-lens)) +(define second-lens (lens-rename (list-ref-lens 1) 'second-lens)) +(define third-lens (lens-rename (list-ref-lens 2) 'third-lens)) +(define fourth-lens (lens-rename (list-ref-lens 3) 'fourth-lens)) +(define fifth-lens (lens-rename (list-ref-lens 4) 'fifth-lens)) +(define sixth-lens (lens-rename (list-ref-lens 5) 'sixth-lens)) +(define seventh-lens (lens-rename (list-ref-lens 6) 'seventh-lens)) +(define eighth-lens (lens-rename (list-ref-lens 7) 'eigth-lens)) +(define ninth-lens (lens-rename (list-ref-lens 8) 'ninth-lens)) +(define tenth-lens (lens-rename (list-ref-lens 9) 'tenth-lens)) (module+ test diff --git a/lens/private/stream.rkt b/lens/private/stream.rkt index e282ff9..e263c56 100644 --- a/lens/private/stream.rkt +++ b/lens/private/stream.rkt @@ -11,6 +11,7 @@ provide require racket/stream fancy-app "base/main.rkt" + "base/rename.rkt" "compound/main.rkt" module+ test @@ -36,14 +37,18 @@ module+ test (stream-cons (stream-first s) rst)) (define stream-first-lens - (make-lens - stream-first - stream-set-first)) + (lens-rename + (make-lens + stream-first + stream-set-first) + 'stream-first-lens)) (define stream-rest-lens - (make-lens - stream-rest - stream-set-rest)) + (lens-rename + (make-lens + stream-rest + stream-set-rest) + 'stream-rest-lens)) (define (stream-tail-lens i) (make-lens diff --git a/lens/private/struct/field.rkt b/lens/private/struct/field.rkt index ec4285f..ec0d0a4 100644 --- a/lens/private/struct/field.rkt +++ b/lens/private/struct/field.rkt @@ -4,6 +4,7 @@ syntax/parse/define alexis/util/struct "../base/main.rkt" + "../base/rename.rkt" (for-syntax racket/base syntax/parse racket/syntax)) @@ -17,8 +18,9 @@ (define-simple-macro (struct-lens s:id fld:id) #:with s-fld (format-id #'s "~a-~a" #'s #'fld #:source #'fld) #:with s-fld-set (format-id #'s "~a-~a-set" #'s #'fld #:source #'fld) + #:with s-fld-lens (format-id #'s "~a-~a-lens" #'s #'fld #:source #'fld) (local [(define-struct-updaters s)] - (make-lens s-fld s-fld-set))) + (lens-rename (make-lens s-fld s-fld-set) 's-fld-lens))) (module+ test (struct foo (a b c) #:transparent) diff --git a/lens/private/struct/struct.rkt b/lens/private/struct/struct.rkt index d3fcd61..603673d 100644 --- a/lens/private/struct/struct.rkt +++ b/lens/private/struct/struct.rkt @@ -3,6 +3,7 @@ (require syntax/parse/define alexis/util/struct "../base/main.rkt" + "../base/rename.rkt" (submod alexis/util/struct get-struct-accessors) (for-syntax racket/base syntax/parse @@ -46,7 +47,7 @@ (s-fld-lens ...)] (struct-get-set-lens-ids #'s) #'(begin (define-struct-updaters s) - (define s-fld-lens (make-lens s-fld s-fld-set)) + (define s-fld-lens (lens-rename (make-lens s-fld s-fld-set) 's-fld-lens)) ...)]))