diff --git a/lens/private/compound/join-hash.rkt b/lens/private/compound/join-hash.rkt index a393e69..c4d1050 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" + "../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)) diff --git a/lens/private/compound/join-list.rkt b/lens/private/compound/join-list.rkt index 08f9ebc..14a0ba7 100644 --- a/lens/private/compound/join-list.rkt +++ b/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)) diff --git a/lens/private/util/alternating-list.rkt b/lens/private/util/alternating-list.rkt new file mode 100644 index 0000000..b57d5b4 --- /dev/null +++ b/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))) diff --git a/unstable/lens/isomorphism/data.rkt b/unstable/lens/isomorphism/data.rkt index e7ea405..1187443 100644 --- a/unstable/lens/isomorphism/data.rkt +++ b/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 diff --git a/unstable/lens/join-assoc.rkt b/unstable/lens/join-assoc.rkt new file mode 100644 index 0000000..32e76ae --- /dev/null +++ b/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)) diff --git a/unstable/lens/join-assoc.scrbl b/unstable/lens/join-assoc.scrbl new file mode 100644 index 0000000..3b69d1e --- /dev/null +++ b/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))) +]} diff --git a/unstable/lens/main.rkt b/unstable/lens/main.rkt index faa51dd..4393467 100644 --- a/unstable/lens/main.rkt +++ b/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" diff --git a/unstable/lens/main.scrbl b/unstable/lens/main.scrbl index dd30ab7..10d51a5 100644 --- a/unstable/lens/main.scrbl +++ b/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"