add lens-rename

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 "#<lens ~a>" (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) "#<lens first-lens>")

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)

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

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

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))

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))

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))

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))

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) ...))

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)

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

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

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)

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))
          ...)]))