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/main.rkt b/unstable/lens/main.rkt index b809e76..a7c0673 100644 --- a/unstable/lens/main.rkt +++ b/unstable/lens/main.rkt @@ -10,6 +10,7 @@ "string-split.rkt" "match.rkt" "set-filterer.rkt" + "struct-join.rkt" ) (provide (all-from-out "syntax.rkt" @@ -22,4 +23,5 @@ "string-split.rkt" "match.rkt" "set-filterer.rkt" + "struct-join.rkt" )) diff --git a/unstable/lens/main.scrbl b/unstable/lens/main.scrbl index e5840ac..894eabb 100644 --- a/unstable/lens/main.scrbl +++ b/unstable/lens/main.scrbl @@ -19,3 +19,4 @@ this library being backwards-compatible. @include-section["string-split.scrbl"] @include-section["match.scrbl"] @include-section["set-filterer.scrbl"] +@include-section["struct-join.scrbl"] diff --git a/unstable/lens/struct-join.rkt b/unstable/lens/struct-join.rkt new file mode 100644 index 0000000..1dd0c18 --- /dev/null +++ b/unstable/lens/struct-join.rkt @@ -0,0 +1,81 @@ +#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 #`(make/kw/derived #,stx 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))) + (define foo-hash-lens4 + (lens-join/struct foo + (hash-ref-lens 'a) + #:c (hash-ref-lens 'c) + #:b (hash-ref-lens 'b))) + (test-multi* ([foo-hash-lens #:in [foo-hash-lens1 foo-hash-lens2 foo-hash-lens3 foo-hash-lens4]]) + (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)) + )) diff --git a/unstable/lens/struct-join.scrbl b/unstable/lens/struct-join.scrbl new file mode 100644 index 0000000..ecdbb44 --- /dev/null +++ b/unstable/lens/struct-join.scrbl @@ -0,0 +1,30 @@ +#lang scribble/manual + +@(require lens/private/doc-util/main) + +@title{Joining lenses with structs} + +@defmodule[unstable/lens/struct-join] + +@defform[(lens-join/struct struct-id field-lens ...) + #:grammar ([field-lens (code:line lens-expr) + (code:line field-keyword lens-expr)])]{ +Like @racket[lens-join/list], except that the views of the given +lenses are put in an instance of the @racket[struct-id] struct instead +of in a list. +@lenses-unstable-examples[ + (struct foo (a b) #:transparent) + (define lens (lens-join/struct foo first-lens third-lens)) + (lens-view lens '(1 2 3)) + (lens-set lens '(1 2 3) (foo 'a 'b)) +] +Struct fields in a @racket[lens-join/struct] form can also be +specified by keywords, in any order, and even with some fields specied +by position and some by keywords: +@lenses-unstable-examples[ + (struct foo (a b) #:transparent) + (lens-view (lens-join/struct foo first-lens third-lens) '(1 2 3)) + (lens-view (lens-join/struct foo #:a first-lens #:b third-lens) '(1 2 3)) + (lens-view (lens-join/struct foo #:b third-lens #:a first-lens) '(1 2 3)) + (lens-view (lens-join/struct foo first-lens #:b third-lens) '(1 2 3)) +]}