Merge pull request #196 from AlexKnauth/lens-join-assoc

add lens-join/assoc

lens/private/compound/join-hash.rkt

@@ -5,6 +5,7 @@
          unstable/sequence
          fancy-app
          "../base/main.rkt"
+         "../util/alternating-list.rkt"
          "../util/immutable.rkt"
          "../util/list-pair-contract.rkt"
          "join-list.rkt")
@@ -18,27 +19,14 @@
   [lens-join/hash (->* () #:rest (listof2 any/c lens?) (lens/c any/c immutable-hash?))]))
 
 
-(define (value-list->hash keys vs)
-  (make-immutable-hash (map cons keys vs)))
-
-(define (split-slice n vs)
-  (define grouped
-    (for/list ([group (in-slice n vs)])
-      group))
-  (define (get-ith i)
-    (map (list-ref _ i) grouped))
-  (build-list n get-ith))
-
-(module+ test
-  (check-equal? (split-slice 3 '(a 1 FOO b 2 BAR c 3 BAZ))
-                '((a b c) (1 2 3) (FOO BAR BAZ))))
-
+(define (keys+values->hash keys vs)
+  (make-immutable-hash (keys+values->assoc-list keys vs)))
 
 (define (lens-join/hash . keys/lenses)
-  (match-define (list keys lenses) (split-slice 2 keys/lenses))
+  (define-values [keys lenses] (alternating-list->keys+values keys/lenses))
   (define list-lens (apply lens-join/list lenses))
   (define (get target)
-    (value-list->hash keys (lens-view list-lens target)))
+    (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/private/compound/join-list.rkt

@@ -1,26 +1,25 @@
-#lang racket/base
+#lang sweet-exp racket/base
 
-(require racket/list
-         racket/contract
-         "../base/main.rkt")
+require racket/list
+        racket/contract
+        "../base/main.rkt"
+        "../util/alternating-list.rkt"
+        "../util/rest-contract.rkt"
 
-(module+ test
-  (require rackunit
-           "../list/list-ref-take-drop.rkt"))
+module+ test
+  require rackunit
+          "../list/list-ref-take-drop.rkt"
 
-(provide
- (contract-out
-  [lens-join/list (->* () #:rest (listof lens?) (lens/c any/c list?))]))
+provide
+  contract-out
+    lens-join/list (rest-> lens? (lens/c any/c list?))
 
 
-(define (zip xs ys)
-  (append-map list xs ys))
-
 (define (lens-join/list . lenses)
   (define (get target)
     (apply lens-view/list target lenses))
   (define (set target new-views)
-    (apply lens-set/list target (zip lenses new-views)))
+    (apply lens-set/list target (keys+values->alternating-list lenses new-views)))
   (make-lens get set))
 
 

lens/private/util/alternating-list.rkt

@@ -0,0 +1,61 @@
+#lang sweet-exp racket/base
+
+provide alternating->assoc-list
+        assoc->alternating-list
+        keys+values->assoc-list
+        assoc-list->keys+values
+        keys+values->alternating-list
+        alternating-list->keys+values
+
+require racket/list
+        racket/match
+        unstable/sequence
+module+ test
+  require rackunit
+
+(define (alternating->assoc-list alternating-list)
+  (for/list ([lst (in-slice 2 alternating-list)])
+    (match-define (list a b) lst)
+    (cons a b)))
+
+(define (assoc->alternating-list alist)
+  (append*
+   (for/list ([(k v) (in-pairs alist)])
+     (list k v))))
+
+(define (keys+values->assoc-list keys values)
+  (map cons keys values))
+
+(define (assoc-list->keys+values alist)
+  (values (map car alist)
+          (map cdr alist)))
+
+(define (keys+values->alternating-list keys values)
+  (append-map list keys values))
+
+(define (alternating-list->keys+values alternating-list)
+  (for/lists (ks vv) ([lst (in-slice 2 alternating-list)])
+    (match-define (list k v) lst)
+    (values k v)))
+
+module+ test
+  (check-equal? (alternating->assoc-list '(a 1 b 2)) '((a . 1) (b . 2)))
+  (check-equal? (alternating->assoc-list '(b 2 a 1)) '((b . 2) (a . 1)))
+  (check-equal? (assoc->alternating-list '((a . 1) (b . 2))) '(a 1 b 2))
+  (check-equal? (assoc->alternating-list '((b . 2) (a . 1))) '(b 2 a 1))
+  (check-equal? (keys+values->assoc-list '(a b) '(1 2)) '((a . 1) (b . 2)))
+  (check-equal? (keys+values->assoc-list '(b a) '(2 1)) '((b . 2) (a . 1)))
+  (check-equal? (keys+values->alternating-list '(a b) '(1 2)) '(a 1 b 2))
+  (check-equal? (keys+values->alternating-list '(b a) '(2 1)) '(b 2 a 1))
+  (let-values ([(ks vs) (assoc-list->keys+values '((a . 1) (b . 2)))])
+    (check-equal? ks '(a b))
+    (check-equal? vs '(1 2)))
+  (let-values ([(ks vs) (assoc-list->keys+values '((b . 2) (a . 1)))])
+    (check-equal? ks '(b a))
+    (check-equal? vs '(2 1)))
+  (let-values ([(ks vs) (alternating-list->keys+values '(a 1 b 2))])
+    (check-equal? ks '(a b))
+    (check-equal? vs '(1 2)))
+  (let-values ([(ks vs) (alternating-list->keys+values '(b 2 a 1))])
+    (check-equal? ks '(b a))
+    (check-equal? vs '(2 1)))

unstable/lens/isomorphism/data.rkt

@@ -10,6 +10,7 @@ provide string->symbol-lens
         string->list-lens
 
 require lens/private/base/main
+        lens/private/util/alternating-list
         "base.rkt"
 
 module+ test
@@ -24,6 +25,8 @@ module+ test
   (make-isomorphism-lenses list->vector vector->list))
 (define-values [list->string-lens string->list-lens]
   (make-isomorphism-lenses list->string string->list))
+(define-values [alternating->assoc-list-lens assoc->alternating-list-lens]
+  (make-isomorphism-lenses alternating->assoc-list assoc->alternating-list))
 
 
 (module+ test

unstable/lens/join-assoc.rkt

@@ -0,0 +1,35 @@
+#lang sweet-exp racket/base
+
+require racket/contract/base
+provide
+  contract-out
+    lens-join/assoc (->* [] #:rest (listof2 any/c lens?) (lens/c any/c (listof pair?)))
+
+require lens/private/base/main
+        lens/private/compound/join-list
+        lens/private/list/assoc
+        lens/private/util/alternating-list
+        lens/private/util/list-pair-contract
+        racket/match
+        unstable/sequence
+module+ test
+  require rackunit lens/private/list/main
+
+(define (lens-join/assoc . ks/lenses)
+  (define-values [keys lenses]
+    (alternating-list->keys+values ks/lenses))
+  (define key-lenses (map assoc-lens keys))
+  (define list-lens (apply lens-join/list lenses))
+  (make-lens
+   (λ (tgt)
+     (keys+values->assoc-list keys (lens-view list-lens tgt)))
+   (λ (tgt nvw)
+     (lens-set list-lens tgt (apply lens-view/list nvw key-lenses)))))
+
+module+ test
+  (define a-b-lens (lens-join/assoc 'a first-lens
+                                    'b third-lens))
+  (check-equal? (lens-view a-b-lens '(1 2 3))
+                '((a . 1) (b . 3)))
+  (check-equal? (lens-set a-b-lens '(1 2 3) '((a . 100) (b . 200)))
+                '(100 2 200))

unstable/lens/join-assoc.scrbl

@@ -0,0 +1,18 @@
+#lang scribble/manual
+
+@(require lens/private/doc-util/main)
+
+@title{Joining lenses with an association list}
+
+@defmodule[unstable/lens/join-assoc]
+
+@defproc[(lens-join/assoc [key key/c] [lens (lens/c target/c value/c)] ... ...)
+         (lens/c target/c (listof (cons/c key/c value/c)))]{
+Like @racket[lens-join/hash], except joins the keys and values into an
+association list instead of a hash-table.
+@lens-unstable-examples[
+  (define a-b-lens (lens-join/assoc 'a first-lens
+                                    'b third-lens))
+  (lens-view a-b-lens '(1 2 3))
+  (lens-set a-b-lens '(1 2 3) '((a . 100) (b . 200)))
+]}

unstable/lens/main.rkt

@@ -3,6 +3,7 @@
 "dict-nested.rkt"
 "if.rkt"
 "isomorphism.rkt"
+"join-assoc.rkt"
 "mapper.rkt"
 "match.rkt"
 "set-filterer.rkt"

unstable/lens/main.scrbl

@@ -16,6 +16,7 @@ this library being backwards-compatible.
   "dict-nested.scrbl"
   "if.scrbl"
   "isomorphism.scrbl"
+  "join-assoc.scrbl"
   "mapper.scrbl"
   "match.scrbl"
   "set-filterer.scrbl"