suzanne.soy/lens
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request #179 from AlexKnauth/lens-join-struct

Browse Source 
add lens-join/struct
This commit is contained in:
Jack Firth 2015-08-24 13:28:30 -07:00
commit c2c3b85d37
6 changed files with 136 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
info.rkt
View File

@ -14,6 +14,7 @@
"fancy-app"
"alexis-util"
"sweet-exp"
"kw-make-struct"
"scribble-lib"))

21
lens/private/test-util/test-multi.rkt Normal file
View File

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

2
unstable/lens/main.rkt
View File

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

1
unstable/lens/main.scrbl
View File

@ -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"]

81
unstable/lens/struct-join.rkt Normal file
View File

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

30
unstable/lens/struct-join.scrbl Normal file
View File

@ -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))
]}