diff --git a/info.rkt b/info.rkt index f25b998..2eca171 100644 --- a/info.rkt +++ b/info.rkt @@ -14,6 +14,7 @@ "fancy-app" "alexis-util" "sweet-exp" + "kw-make-struct" "scribble-lib")) diff --git a/lens/private/test-util/test-multi.rkt b/lens/private/test-util/test-multi.rkt new file mode 100644 index 0000000..ba5c662 --- /dev/null +++ b/lens/private/test-util/test-multi.rkt @@ -0,0 +1,21 @@ +#lang sweet-exp racket/base + +provide test-multi* + +require racket/match + racket/string + racket/format + syntax/parse/define + rackunit + for-syntax racket/base + syntax/parse + +(define-simple-macro + (test-multi* ([test-id:id #:in [test-variant:expr ...]] ...) + body ...) + #:with [pair-id ...] (generate-temporaries #'[test-id ...]) + #:with [which-test ...] (generate-temporaries #'[test-id ...]) + (for* ([pair-id (in-list (list (cons 'test-variant test-variant) ...))] ...) + (match-define (cons which-test test-id) pair-id) ... + (test-case (string-join (list (format "~a = ~a" 'test-id which-test) ...) ", ") + body ...))) diff --git a/unstable/lens/struct-join.rkt b/unstable/lens/struct-join.rkt new file mode 100644 index 0000000..d0a387f --- /dev/null +++ b/unstable/lens/struct-join.rkt @@ -0,0 +1,76 @@ +#lang sweet-exp racket/base + +provide lens-join/struct + +require racket/local + racket/match + lens/private/base/main + kw-make-struct + for-syntax racket/base + syntax/parse +module+ test + require rackunit lens/private/hash/main lens/private/test-util/test-multi + +(begin-for-syntax + (define-splicing-syntax-class field-lenses + #:attributes ([lens-expr 1] [lens-id 1] [vw-id 1] [norm 1]) + [pattern (~seq lens-expr:expr ...) + #:with [lens-id ...] (generate-temporaries #'[lens-expr ...]) + #:with [vw-id ...] (generate-temporaries #'[lens-expr ...]) + #:with [norm ...] #'[vw-id ...]] + [pattern (~seq fst-lens:expr ...+ rst:field-lenses) + #:with [fst-lens-id ...] (generate-temporaries #'[fst-lens ...]) + #:with [fst-vw-id ...] (generate-temporaries #'[fst-lens ...]) + #:with [lens-expr ...] #'[fst-lens ... rst.lens-expr ...] + #:with [lens-id ...] #'[fst-lens-id ... rst.lens-id ...] + #:with [vw-id ...] #'[fst-vw-id ... rst.vw-id ...] + #:with [norm ...] #'[fst-vw-id ... rst.norm ...]] + [pattern (~seq (~seq kw:keyword fst-lens:expr) ...+ rst:field-lenses) + #:with [fst-lens-id ...] (generate-temporaries #'[fst-lens ...]) + #:with [fst-vw-id ...] (generate-temporaries #'[fst-lens ...]) + #:with [lens-expr ...] #'[fst-lens ... rst.lens-expr ...] + #:with [lens-id ...] #'[fst-lens-id ... rst.lens-id ...] + #:with [vw-id ...] #'[fst-vw-id ... rst.vw-id ...] + #:with [[fst-kw/vw-id ...] ...] #'[[kw fst-vw-id] ...] + #:with [norm ...] #'[fst-kw/vw-id ... ... rst.norm ...]] + )) + +(define-syntax lens-join/struct + (lambda (stx) + (syntax-parse stx + [(lens-join/struct s:id flds:field-lenses) + #:with make/kw-form (syntax/loc stx (make/kw s flds.norm ...)) + #:with [[lens-id/vw-id ...] ...] #'[[flds.lens-id flds.vw-id] ...] + #`(local [(define flds.lens-id flds.lens-expr) ...] + (make-lens + (λ (tgt) + (define flds.vw-id (lens-view flds.lens-id tgt)) + ... + make/kw-form) + (λ (tgt nvw) + (match-define make/kw-form nvw) + (lens-set/list tgt lens-id/vw-id ... ...))))]))) + +(module+ test + (struct foo (a b c) #:transparent) + (define foo-hash-lens1 + (lens-join/struct foo + (hash-ref-lens 'a) + (hash-ref-lens 'b) + (hash-ref-lens 'c))) + (define foo-hash-lens2 + (lens-join/struct foo + #:a (hash-ref-lens 'a) + #:b (hash-ref-lens 'b) + #:c (hash-ref-lens 'c))) + (define foo-hash-lens3 + (lens-join/struct foo + #:c (hash-ref-lens 'c) + #:a (hash-ref-lens 'a) + #:b (hash-ref-lens 'b))) + (test-multi* ([foo-hash-lens #:in [foo-hash-lens1 foo-hash-lens2 foo-hash-lens3]]) + (check-equal? (lens-view foo-hash-lens (hash 'a 1 'b 2 'c 3)) + (foo 1 2 3)) + (check-equal? (lens-set foo-hash-lens (hash 'a 1 'b 2 'c 3) (foo 10 20 30)) + (hash 'a 10 'b 20 'c 30)) + ))