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

Merge pull request #270 from AlexKnauth/move-unstable

Browse Source 
start moving unstable code to lens/private
This commit is contained in:
Jack Firth 2016-01-10 20:22:02 -08:00
commit b24d06d4e8
84 changed files with 1064 additions and 1005 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
info.rkt
View File

@ -36,4 +36,5 @@
"lens/private/test-util"
"lens/private/util"
"unstable/lens/struct-provide.rkt"
"unstable/lens/syntax.rkt"))
"unstable/lens/syntax.rkt"
"unstable/lens/zoom.rkt"))

41
lens/private/compound/arrow.rkt Normal file
View File

@ -0,0 +1,41 @@
#lang racket/base
(provide lens-view~>
lens-set~>
lens-transform~>
lens-view/thrush
lens-set/thrush
lens-transform/thrush)
(require lens)
(module+ test
(require rackunit racket/list fancy-app))
(define (lens-view~> target . lenses)
(for/fold ([target target]) ([lens (in-list lenses)])
(lens-view lens target)))
(define (lens-set~> target #:-> new-val . lenses)
(lens-set (apply lens-thrush lenses) target new-val))
(define (lens-transform~> target #:-> transformer . lenses)
(lens-transform (apply lens-thrush lenses) target transformer))
(define lens-view/thrush lens-view~>)
(define lens-set/thrush lens-set~>)
(define lens-transform/thrush lens-transform~>)
(module+ test
(define (set-first l v)
(list* v (rest l)))
(define (set-second l v)
(list* (first l) v (rest (rest l))))
(define first-lens (make-lens first set-first))
(define second-lens (make-lens second set-second))
(check-equal? (lens-view~> '((1 2) 3) first-lens second-lens)
2)
(check-equal? (lens-set~> '((1 2) 3) first-lens second-lens #:-> 'two)
'((1 two) 3))
(check-equal? (lens-transform~> '((1 2) 3) first-lens second-lens #:-> (* 100 _))
'((1 200) 3)))

74
lens/private/compound/define-nested.rkt Normal file
View File

@ -0,0 +1,74 @@
#lang sweet-exp racket/base
provide define-nested-lenses
require lens/private/compound/thrush
for-syntax racket/base
racket/syntax
syntax/parse
syntax/srcloc
"../util/id-append.rkt"
module+ test
require lens/private/base/base
lens/private/list/main
rackunit
begin-for-syntax
(define (with-sub-range-binders stx prop)
(syntax-property stx 'sub-range-binders prop))
(define -- (update-source-location (datum->syntax #f '-)
#:span 1))
(define -lens (update-source-location (datum->syntax #f '-lens)
#:span 5))
;; helper syntax-class for define-nested-lenses
(define-syntax-class (clause base-id base-lens-tmp)
#:attributes (def)
[pattern [suffix-id:id suffix-lens-expr:expr
unchecked-clause ...]
#:with base-lens:id base-lens-tmp
#:do [(define-values [base-suffix-id base-suffix-sub-range]
(id-append #:context base-id
base-id -- #'suffix-id))
(define-values [base-suffix-lens-id base-suffix-lens-sub-range]
(id-append #:context base-id
base-suffix-id -lens))]
#:with base-suffix
base-suffix-id
#:with base-suffix-lens
base-suffix-lens-id
#:with [(~var clause (clause #'base-suffix #'base-suffix-lens)) ...]
#'[unchecked-clause ...]
#:with def
(with-sub-range-binders
#'(begin
(define base-suffix-lens
(lens-thrush base-lens suffix-lens-expr))
clause.def
...)
base-suffix-lens-sub-range)])
(define-syntax define-nested-lenses
(syntax-parser
[(define-nested-lenses [base:id base-lens-expr:expr]
(~parse base-lens:id (generate-temporary #'base))
(~var clause (clause #'base #'base-lens))
...)
#'(begin
(define base-lens base-lens-expr)
clause.def
...)]))
module+ test
(define-nested-lenses [first first-lens]
[first first-lens]
[second second-lens]
[third third-lens
[first first-lens]
[second second-lens]])
(check-equal? (lens-view first-first-lens '((a b c d) e)) 'a)
(check-equal? (lens-view first-second-lens '((a b c d) e)) 'b)
(check-equal? (lens-view first-third-lens '((a b c d) e)) 'c)
(check-equal? (lens-view first-third-first-lens '((a b (c d) e) f)) 'c)
(check-equal? (lens-view first-third-second-lens '((a b (c d) e) f)) 'd)

2
lens/private/compound/identity.rkt
View File

@ -3,7 +3,7 @@
require racket/function
racket/contract/base
"../base/main.rkt"
unstable/lens/isomorphism/base
lens/private/isomorphism/base
module+ test
require rackunit

92
lens/private/compound/if.rkt Normal file
View File

@ -0,0 +1,92 @@
#lang racket/base
(provide lens-if
lens-cond
lens-match
)
(require lens/private/base/main
racket/match
(for-syntax racket/base
syntax/parse
))
(module+ test
(require rackunit lens/private/list/main lens/private/vector/main lens/private/string/main))
(define (lens-if pred lens1 lens2)
(make-lens
(λ (tgt)
(if (pred tgt)
(lens-view lens1 tgt)
(lens-view lens2 tgt)))
(λ (tgt nvw)
(if (pred tgt)
(lens-set lens1 tgt nvw)
(lens-set lens2 tgt nvw)))))
(define (any? x) #t)
(define-syntax lens-cond
(syntax-parser #:literals (else)
[(lens-cond [pred-expr:expr lens-expr:expr] ... [else else-lens-expr:expr])
#'(lens-cond [pred-expr lens-expr] ... [any? else-lens-expr])]
[(lens-cond [pred-expr:expr lens-expr:expr] ...)
#:with [pred ...] (generate-temporaries #'[pred-expr ...])
#:with [lens ...] (generate-temporaries #'[lens-expr ...])
#'(let ([pred pred-expr] ... [lens lens-expr] ...)
(make-lens
(λ (tgt)
(cond [(pred tgt) (lens-view lens tgt)]
...
[else (raise-lens-cond-error tgt 'pred-expr ...)]))
(λ (tgt nvw)
(cond [(pred tgt) (lens-set lens tgt nvw)]
...
[else (raise-lens-cond-error tgt 'pred-expr ...)]))))]))
(define (raise-lens-cond-error tgt . pred-expr-syms)
(raise-arguments-error 'lens-cond "no matching clause for target"
"target" tgt
"expected" `(or/c ,@pred-expr-syms)))
(define-syntax lens-match
(syntax-parser
[(lens-match [pat:expr lens-expr:expr] ...)
#'(make-lens
(λ (tgt)
(match tgt
[pat (lens-view lens-expr tgt)]
...))
(λ (tgt nvw)
(match tgt
[pat (lens-set lens-expr tgt nvw)]
...)))]))
(module+ test
(define if-lens (lens-if list? first-lens (vector-ref-lens 0)))
(check-equal? (lens-view if-lens '(1 2 3)) 1)
(check-equal? (lens-view if-lens '#(1 2 3)) 1)
(check-equal? (lens-set if-lens '(1 2 3) 'a) '(a 2 3))
(check-equal? (lens-set if-lens '#(1 2 3) 'a) '#(a 2 3))
(define cond-lens (lens-cond [list? first-lens]
[vector? (vector-ref-lens 0)]
[string? (string-ref-lens 0)]))
(check-equal? (lens-view cond-lens '(1 2 3)) 1)
(check-equal? (lens-view cond-lens '#(1 2 3)) 1)
(check-equal? (lens-view cond-lens "123") #\1)
(check-equal? (lens-set cond-lens '(1 2 3) 'a) '(a 2 3))
(check-equal? (lens-set cond-lens '#(1 2 3) 'a) '#(a 2 3))
(check-equal? (lens-set cond-lens "123" #\a) "a23")
(define match-lens (lens-match [(list a) first-lens]
[(list a b) second-lens]
[(list a b c) third-lens]
[(list a ... b) (list-ref-lens (length a))]))
(check-equal? (lens-view match-lens '(1)) 1)
(check-equal? (lens-view match-lens '(1 2)) 2)
(check-equal? (lens-view match-lens '(1 2 3)) 3)
(check-equal? (lens-view match-lens '(1 2 3 4 5 6)) 6)
(check-equal? (lens-set match-lens '(1) 'a) '(a))
(check-equal? (lens-set match-lens '(1 2) 'a) '(1 a))
(check-equal? (lens-set match-lens '(1 2 3) 'a) '(1 2 a))
(check-equal? (lens-set match-lens '(1 2 3 4 5 6) 'a) '(1 2 3 4 5 a))
)

32
lens/private/compound/lazy.rkt Normal file
View File

@ -0,0 +1,32 @@
#lang sweet-exp racket/base
provide lazy-lens
rec-lens
require fancy-app lens/private/base/main racket/promise
module+ test
require rackunit
lens/private/compound/if
lens/private/isomorphism/data
lens/private/list/map
(define-syntax-rule (lazy-lens expr)
(let ([p (delay expr)])
(make-lens (lens-view (force p) _) (lens-set (force p) _ _))))
(define-syntax-rule (rec-lens name expr)
(letrec ([name (lazy-lens expr)])
name))
module+ test
(define (tree-map-lens item-lens)
(rec-lens the-tree-lens
(lens-cond [list? (map-lens the-tree-lens)]
[else item-lens])))
(check-equal? (lens-view (tree-map-lens symbol->string-lens) '(a (b (() c)) (d)))
'("a" ("b" (() "c")) ("d")))
(check-equal? (lens-set (tree-map-lens symbol->string-lens)
'(a (b (() c)) (d))
'("hay" ("bee" (() "sea")) ("deep")))
'(hay (bee (() sea)) (deep)))

4
lens/private/compound/main.rkt
View File

@ -1,8 +1,4 @@
#lang reprovide
"compose.rkt"
"identity.rkt"
"join-hash.rkt"
"join-list.rkt"
"join-string.rkt"
"join-vector.rkt"
"thrush.rkt"

4
lens/private/compound/main.scrbl
View File

@ -6,7 +6,3 @@
@scribble-include/no-subsection["compose.scrbl"]
@scribble-include/no-subsection["thrush.scrbl"]
@scribble-include/no-subsection["join-list.scrbl"]
@scribble-include/no-subsection["join-hash.scrbl"]
@scribble-include/no-subsection["join-vector.scrbl"]
@scribble-include/no-subsection["join-string.scrbl"]

104
lens/private/compound/zoom.rkt Normal file
View File

@ -0,0 +1,104 @@
#lang sweet-exp racket/base
require racket/contract/base
provide
contract-out
lens-zoom (-> lens? lens? lens?)
lens-zoom* (->* [] #:rest (listof2 lens? lens?) lens?)
require fancy-app
lens/private/base/main
lens/private/compound/thrush
lens/private/util/list-pair-contract
racket/match
unstable/sequence
lens/private/isomorphism/base
module+ test
require lens/private/list/main
rackunit
lens/private/isomorphism/data
lens/private/list/map
;; lens-zoom : (Lens (Outer Inner) Inner) (Lens A B) -> (Lens (Outer A) (Outer B))
(define (lens-zoom zoom-lens transformer-lens)
(match transformer-lens
[(make-isomorphism-lens transformer inverse)
;; transformer : A -> B
;; inverse : B -> A
(make-isomorphism-lens
(lens-transform zoom-lens _ transformer) ; (Outer A) -> (Outer B)
(lens-transform zoom-lens _ inverse))] ; (Outer B) -> (Outer A)
[transformer-lens
;; get : (Outer A) -> (Outer B)
(define (get tgt)
;; transformer : A -> B
(define (transformer a)
(lens-view transformer-lens a))
(lens-transform zoom-lens tgt transformer))
;; set : (Outer A) (Outer B) -> (Outer A)
(define (set tgt nvw)
;; a : A
(define a (lens-view zoom-lens tgt))
;; transformer : B -> A
(define (transformer b)
(lens-set transformer-lens a b))
(lens-transform zoom-lens nvw transformer))
(make-lens get set)]))
(define (lens-zoom* . lenses/transformers)
(apply lens-thrush
(for/list ([args (in-slice 2 lenses/transformers)])
(apply lens-zoom args))))
module+ test
(define first-sym->str
(lens-zoom first-lens symbol->string-lens))
(check-equal? (lens-view first-sym->str '(a b c))
'("a" b c))
(check-equal? (lens-set first-sym->str '(a b c) '("a" b c))
'(a b c))
(check-equal? (lens-set first-sym->str '(a b c) '("z" b c))
'(z b c))
(check-equal? (lens-set first-sym->str '(a b c) '("z" bee sea))
'(z bee sea))
(check-equal? (lens-view first-sym->str (lens-set first-sym->str '(a b c) '("z" bee sea)))
'("z" bee sea))
(define trans-second-first/third-second
(lens-zoom* second-lens first-lens third-lens second-lens))
(check-equal? (lens-view trans-second-first/third-second '(1 (2 3) (4 5)))
'(1 2 5))
(check-equal? (lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(1 2 5))
'(1 (2 3) (4 5)))
(check-equal? (lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(1 b 5))
'(1 (b 3) (4 5)))
(check-equal? (lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(a b c))
'(a (b 3) (4 c)))
(check-equal? (lens-view trans-second-first/third-second
(lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(a b c)))
'(a b c))
(define (rekey-alist-lens key->new-key-lens)
(map-lens (lens-zoom car-lens key->new-key-lens)))
(check-equal? (lens-view (rekey-alist-lens symbol->string-lens) '((a . 1) (b . 2) (c . 3)))
'(("a" . 1) ("b" . 2) ("c" . 3)))
(check-equal? (lens-set (rekey-alist-lens symbol->string-lens)
'((a . 1) (b . 2) (c . 3))
'(("a" . 10) ("b" . 200) ("c" . 3000)))
'((a . 10) (b . 200) (c . 3000)))
(check-equal? (lens-set (rekey-alist-lens symbol->string-lens)
'((a . 1) (b . 2) (c . 3))
'(("one" . 10) ("two" . 200) ("three" . 3000)))
'((one . 10) (two . 200) (three . 3000)))
(define (rek+v-alist-lens key->new-key-lens value->new-value-lens)
(map-lens (lens-zoom* car-lens key->new-key-lens cdr-lens value->new-value-lens)))
(check-equal? (lens-view (rek+v-alist-lens symbol->string-lens number->string-lens)
'((a . 1) (b . 2) (c . 3)))
'(("a" . "1") ("b" . "2") ("c" . "3")))
(check-equal? (lens-set (rek+v-alist-lens symbol->string-lens number->string-lens)
'((a . 1) (b . 2) (c . 3))
'(("a" . "10") ("b" . "200") ("c" . "3000")))
'((a . 10) (b . 200) (c . 3000)))
(check-equal? (lens-set (rek+v-alist-lens symbol->string-lens number->string-lens)
'((a . 1) (b . 2) (c . 3))
'(("one" . "10") ("two" . "200") ("three" . "3000")))
'((one . 10) (two . 200) (three . 3000)))

24
lens/private/dict/dict-nested.rkt Normal file
View File

@ -0,0 +1,24 @@
#lang sweet-exp racket/base
require racket/contract/base
provide
contract-out
dict-ref-nested-lens (->* [] #:rest (listof any/c) (lens/c functional-dict? any/c))
require lens/private/base/main
lens/private/compound/thrush
lens/private/dict/dict
lens/private/util/functional-dict
module+ test
require rackunit fancy-app
(define (dict-ref-nested-lens . ks)
(apply lens-thrush (map dict-ref-lens ks)))
module+ test
(define a-x (dict-ref-nested-lens 'a 'x))
(let-lens [val ctxt] a-x '([a . ([x . 1] [y . 2])] '[b . ([z . 3])])
(check-equal? val 1)
(check-equal? (ctxt 100) '([a . ([x . 100] [y . 2])] '[b . ([z . 3])])))
(check-equal? (lens-transform/list '([a . ([x . 1] [y . 2])] '[b . ([z . 3])]) a-x (* 10 _))
'([a . ([x . 10] [y . 2])] '[b . ([z . 3])]))

2
lens/private/dict.rkt → lens/private/dict/dict.rkt
View File

@ -6,7 +6,7 @@
(-> any/c (lens/c functional-dict? any/c))]
))
(require lens/private/util/functional-dict racket/dict fancy-app "base/main.rkt")
(require lens/private/util/functional-dict racket/dict fancy-app "../base/main.rkt")
(module+ test
(require rackunit))

2
lens/private/dict.scrbl → lens/private/dict/dict.scrbl
View File

@ -1,6 +1,6 @@
#lang scribble/manual
@(require "doc-util/main.rkt")
@(require "../doc-util/main.rkt")
@title[#:tag "dict-reference"]{Dict lenses}

60
lens/private/hash/hash-filterer.rkt Normal file
View File

@ -0,0 +1,60 @@
#lang sweet-exp racket
;; inspired by https://github.com/jackfirth/racket-auto-fix-deps/blob/master/job/src/filter-hash.rkt
provide
contract-out
hash-filterer-lens (-> (-> any/c any/c boolean?) (lens/c immutable-hash? immutable-hash?))
hash-filterer-lens/key (-> predicate/c (lens/c immutable-hash? immutable-hash?))
hash-filterer-lens/value (-> predicate/c (lens/c immutable-hash? immutable-hash?))
require fancy-app
lens/private/base/main
lens/private/util/immutable
unstable/hash
module+ test
require lens/private/test-util/test-lens
rackunit
(define (hash-filter keep? hsh)
(for/hash ([(k v) (in-hash hsh)] #:when (keep? k v))
(values k v)))
(define (hash-filter-not drop? hsh)
(hash-filter (λ (k v) (not (drop? k v))) hsh))
(define (hash-andmap f hsh)
(for/and ([(k v) (in-hash hsh)])
(f k v)))
(define (hash-filterer-lens keep?)
(make-lens
(hash-filter keep? _)
(λ (tgt nvw)
(unless (hash-andmap keep? nvw)
(raise-argument-error 'hash-filterer-lens-setter
(format "a hash where all key-value pairs pass ~v" keep?)
nvw))
(hash-union (hash-filter-not keep? tgt) nvw))))
(define (hash-filterer-lens/key keep?)
(hash-filterer-lens (λ (k v) (keep? k))))
(define (hash-filterer-lens/value keep?)
(hash-filterer-lens (λ (k v) (keep? v))))
module+ test
(check-lens-view (hash-filterer-lens/key symbol?) (hash 'a 1 "b" 2 'c 3)
(hash 'a 1 'c 3))
(check-lens-set (hash-filterer-lens/key symbol?) (hash 'a 1 "b" 2 'c 3) (hash 'd 4 'e 5)
(hash "b" 2 'd 4 'e 5))
(check-lens-view (hash-filterer-lens/value number?) (hash 'a 1 'b "two" 'c 3)
(hash 'a 1 'c 3))
(check-lens-set (hash-filterer-lens/value number?) (hash 'a 1 'b "two" 'c 3) (hash 'd 4)
(hash 'b "two" 'd 4))
(check-lens-view (hash-filterer-lens =) (hash 1 1.0 2 45 3 3)
(hash 1 1.0 3 3))
(check-lens-set (hash-filterer-lens =) (hash 1 1.0 2 45 3 3) (hash 4 4.0 5.0 5)
(hash 2 45 4 4.0 5.0 5))
(check-exn exn:fail:contract?
(thunk (lens-set (hash-filterer-lens/key symbol?) (hash 'a 1) (hash "d" 4))))

2
lens/private/compound/join-hash.rkt → lens/private/hash/join-hash.rkt
View File

@ -8,7 +8,7 @@
"../util/alternating-list.rkt"
"../util/immutable.rkt"
"../util/list-pair-contract.rkt"
"join-list.rkt")
"../list/join-list.rkt")
(module+ test
(require rackunit

0
lens/private/compound/join-hash.scrbl → lens/private/hash/join-hash.scrbl
View File

1
lens/private/hash/main.rkt
View File

@ -2,3 +2,4 @@
"nested.rkt"
"pick.rkt"
"ref.rkt"
"join-hash.rkt"

1
lens/private/hash/main.scrbl
View File

@ -10,3 +10,4 @@
@scribble-include/no-subsection["ref.scrbl"]
@scribble-include/no-subsection["nested.scrbl"]
@scribble-include/no-subsection["pick.scrbl"]
@scribble-include/no-subsection["join-hash.scrbl"]

2
lens/private/hash/pick.rkt
View File

@ -3,7 +3,7 @@
(require racket/contract
racket/list
"../base/main.rkt"
"../compound/join-hash.rkt"
"../hash/join-hash.rkt"
"../util/immutable.rkt"
"../util/rest-contract.rkt"
"ref.rkt")

1
unstable/lens/isomorphism/base.rkt → lens/private/isomorphism/base.rkt
View File

@ -1,4 +1,3 @@
#lang sweet-exp racket/base
provide isomorphism-lens?

0
unstable/lens/isomorphism/compound.rkt → lens/private/isomorphism/compound.rkt
View File

0
unstable/lens/isomorphism/data.rkt → lens/private/isomorphism/data.rkt
View File

4
lens/private/isomorphism/main.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang reprovide
"base.rkt"
"compound.rkt"
"data.rkt"

35
lens/private/list/join-assoc.rkt Normal file
View File

@ -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/list/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/list-ref-take-drop
(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))

0
lens/private/compound/join-list.rkt → lens/private/list/join-list.rkt
View File

2
lens/private/compound/join-list.scrbl → lens/private/list/join-list.scrbl
View File

@ -2,6 +2,8 @@
@(require "../doc-util/main.rkt")
@title{Joining lenses to view lists}
@defproc[(lens-join/list [lens lens?] ...) lens?]{
Constructs a lens that combines the view of each
@racket[lens] into a list of views. This lens can

1
lens/private/list/main.rkt
View File

@ -3,4 +3,5 @@
"list-ref-take-drop.rkt"
"cadr-etc.rkt"
"multi.rkt"
"join-list.rkt"
"assoc.rkt"

1
lens/private/list/main.scrbl
View File

@ -8,4 +8,5 @@
@include-section["car-cdr.scrbl"]
@include-section["list-ref-take-drop.scrbl"]
@include-section["join-list.scrbl"]
@include-section["assoc.scrbl"]

55
lens/private/list/map.rkt Normal file
View File

@ -0,0 +1,55 @@
#lang racket/base
(require racket/contract/base)
(provide (contract-out
[map-lens
(-> lens? (lens/c list? list?))]
[vector-map-lens
(-> lens? (lens/c immutable-vector? immutable-vector?))]
))
(require lens/private/base/main
lens/private/util/immutable
racket/vector
fancy-app
)
(module+ test
(require rackunit lens/private/list/main))
(define (map-lens lens)
(make-lens
(lens-view/map lens _)
(lens-set/map lens _ _)))
(define (lens-view/map lens tgts)
(map (lens-view lens _) tgts))
(define (lens-set/map lens tgts new-views)
(map (lens-set lens _ _) tgts new-views))
(define (vector-map-lens lens)
(make-lens
(lens-view/vector-map lens _)
(lens-set/vector-map lens _ _)))
(define (lens-view/vector-map lens tgt)
(vector->immutable-vector (vector-map (lens-view lens _) tgt)))
(define (lens-set/vector-map lens tgt new-view)
(vector->immutable-vector (vector-map (lens-set lens _ _) tgt new-view)))
(module+ test
(check-equal? (lens-view (map-lens first-lens) '((a b) (c d) (e f)))
'(a c e))
(check-equal? (lens-set (map-lens first-lens) '((a b) (c d) (e f)) '(1 2 3))
'((1 b) (2 d) (3 f)))
(check-equal? (lens-transform (map-lens first-lens) '((a b) (c d) (e f)) (map symbol->string _))
'(("a" b) ("c" d) ("e" f)))
(check-equal? (lens-view (vector-map-lens first-lens) '#((a b) (c d) (e f)))
'#(a c e))
(check-equal? (lens-set (vector-map-lens first-lens) '#((a b) (c d) (e f)) '#(1 2 3))
'#((1 b) (2 d) (3 f)))
(check-equal? (lens-transform (vector-map-lens first-lens) '#((a b) (c d) (e f))
(immutable-vector-map symbol->string _))
'#(("a" b) ("c" d) ("e" f)))
)

1
lens/private/list/multi.rkt
View File

@ -4,6 +4,7 @@
"../base/main.rkt"
"../compound/main.rkt"
"../util/rest-contract.rkt"
"join-list.rkt"
"list-ref-take-drop.rkt")
(module+ test

2
unstable/lens/list.rkt → lens/private/list/reverse.rkt
View File

@ -10,7 +10,7 @@ provide
require lens/private/base/main
lens/private/list/main
lens/private/compound/main
"isomorphism/base.rkt"
lens/private/isomorphism/base
module+ test
require rackunit fancy-app

19
lens/private/list/sublist.rkt Normal file
View File

@ -0,0 +1,19 @@
#lang racket/base
(provide sublist-lens)
(require lens
lens/private/list/list-ref-take-drop)
(module+ test
(require rackunit))
(define (sublist-lens i j)
(lens-thrush (take-lens j) (drop-lens i)))
(module+ test
(check-equal? (lens-view (sublist-lens 1 4) '(0 1 2 3 4 5))
'(1 2 3))
(check-equal? (lens-set (sublist-lens 1 4) '(0 1 2 3 4 5) '(a b c))
'(0 a b c 4 5))
)

6
lens/private/main.rkt
View File

@ -3,11 +3,11 @@ except-in
combine-in
"base/main.rkt"
"compound/main.rkt"
"dict.rkt"
"dict/dict.rkt"
"hash/main.rkt"
"list/main.rkt"
"stream.rkt"
"string.rkt"
"stream/stream.rkt"
"string/main.rkt"
"struct/main.rkt"
"vector/main.rkt"
gen:lens

34
lens/private/match.rkt Normal file
View File

@ -0,0 +1,34 @@
#lang racket/base
(provide match-lens)
(require racket/match
racket/local
syntax/parse/define
lens/private/base/main
)
(module+ test
(require rackunit lens/private/test-util/test-lens))
(define-simple-macro (match-lens a:id pat:expr replacement:expr)
(local [(define (get target)
(match target
[pat
a]))
(define (set target new-view)
(match target
[pat
(let ([a new-view])
replacement)]))]
(make-lens get set)))
(module+ test
(define car-lens (match-lens a (cons a b) (cons a b)))
(define cdr-lens (match-lens b (cons a b) (cons a b)))
(check-lens-view car-lens (cons 1 2) 1)
(check-lens-view cdr-lens (cons 1 2) 2)
(check-lens-set car-lens (cons 1 2) 'a (cons 'a 2))
(check-lens-set cdr-lens (cons 1 2) 'a (cons 1 'a))
(test-lens-laws car-lens (cons 1 2) 'a 'b)
(test-lens-laws cdr-lens (cons 1 2) 'a 'b)
)

6
lens/private/scribblings/reference.scrbl
View File

@ -10,7 +10,7 @@
@include-section["../hash/main.scrbl"]
@include-section["../struct/main.scrbl"]
@include-section["../vector/main.scrbl"]
@include-section["../string.scrbl"]
@include-section["../stream.scrbl"]
@include-section["../dict.scrbl"]
@include-section["../string/main.scrbl"]
@include-section["../stream/stream.scrbl"]
@include-section["../dict/dict.scrbl"]
@include-section["../../applicable.scrbl"]

54
lens/private/set/set-filterer.rkt Normal file
View File

@ -0,0 +1,54 @@
#lang sweet-exp racket/base
require racket/contract/base
provide
contract-out
set-filterer-lens (-> predicate/c (lens/c functional-set? functional-set?))
require lens/private/base/main
lens/private/util/functional-set
racket/set
racket/function
fancy-app
module+ test
require rackunit
(define (set-filter pred set)
(for/fold ([set set]) ([elem (in-set set)] #:unless (pred elem))
(set-remove set elem)))
(define (set-filter-not pred set)
(for/fold ([set set]) ([elem (in-set set)] #:when (pred elem))
(set-remove set elem)))
(define (andmap-set pred set)
(andmap pred (set->list set)))
(define (check-set-filterer-lens-view pred new-view-to-check)
(unless (andmap-set pred new-view-to-check)
(raise-argument-error 'set-filterer-lens
(format "(set/c ~a)" (contract-name pred))
new-view-to-check)))
(define (set-filterer-lens pred)
(define (insert-filtered-items target new-view)
(check-set-filterer-lens-view pred new-view)
(set-union (set-filter-not pred target) new-view))
(make-lens (set-filter pred _)
insert-filtered-items))
module+ test
(check-equal? (lens-view (set-filterer-lens number?) '(1 a 2 b c 3 d e))
'(1 2 3))
(check-equal? (lens-set (set-filterer-lens number?) '(1 a 2 b c 3 d e) '(4 5 6 7))
'(7 6 5 4 a b c d e))
(check-equal? (lens-view (set-filterer-lens number?) (set 1 'a 2 'b 'c 3 'd 'e))
(set 1 2 3))
(check-equal? (lens-set (set-filterer-lens number?) (set 1 'a 2 'b 'c 3 'd 'e) (set 4 5 6 7))
(set 4 5 6 7 'a 'b 'c 'd 'e))
(check-exn exn:fail:contract?
(thunk (lens-set (set-filterer-lens number?) (set 1) (set 'a))))

30
lens/private/set/set-member.rkt Normal file
View File

@ -0,0 +1,30 @@
#lang sweet-exp racket/base
require racket/contract/base
provide
contract-out
set-member-lens (-> any/c (lens/c functional-set? boolean?))
require fancy-app
lens/private/base/main
lens/private/util/functional-set
racket/set
module+ test
require rackunit
(define (set-member-lens v)
(make-lens
(set-member? _ v)
(λ (tgt nvw)
(if nvw
(set-add tgt v)
(set-remove tgt v)))))
module+ test
(define 2-lens (set-member-lens 2))
(check-equal? (lens-view 2-lens (set 1 2 3)) #t)
(check-equal? (lens-view 2-lens (set 1 3)) #f)
(check-equal? (lens-set 2-lens (set 1 2 3) #t) (set 1 2 3))
(check-equal? (lens-set 2-lens (set 1 2 3) #f) (set 1 3))
(check-equal? (lens-set 2-lens (set 1 3) #t) (set 1 2 3))
(check-equal? (lens-set 2-lens (set 1 3) #f) (set 1 3))

6
lens/private/stream.rkt → lens/private/stream/stream.rkt
View File

@ -10,12 +10,12 @@ provide
require racket/stream
fancy-app
"base/main.rkt"
"compound/main.rkt"
"../base/main.rkt"
"../compound/main.rkt"
module+ test
require rackunit
"test-util/test-lens.rkt"
"../test-util/test-lens.rkt"
module+ test

2
lens/private/stream.scrbl → lens/private/stream/stream.scrbl
View File

@ -1,6 +1,6 @@
#lang scribble/manual
@(require "doc-util/main.rkt")
@(require "../doc-util/main.rkt")
@title[#:tag "streams-reference"]{Stream Lenses}

6
lens/private/compound/join-string.rkt → lens/private/string/join-string.rkt
View File

@ -1,12 +1,12 @@
#lang sweet-exp racket/base
require racket/contract
unstable/lens/isomorphism/base
lens/private/isomorphism/base
"../base/main.rkt"
"../util/immutable.rkt"
"../util/rest-contract.rkt"
"compose.rkt"
"join-list.rkt"
"../compound/compose.rkt"
"../list/join-list.rkt"
module+ test
require rackunit

0
lens/private/compound/join-string.scrbl → lens/private/string/join-string.scrbl
View File

3
lens/private/string/main.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang reprovide
"string.rkt"
"join-string.rkt"

6
lens/private/string/main.scrbl Normal file
View File

@ -0,0 +1,6 @@
#lang scribble/manual
@title{String Lenses}
@include-section["string.scrbl"]
@include-section["join-string.scrbl"]

56
lens/private/string/string-split.rkt Normal file
View File

@ -0,0 +1,56 @@
#lang racket/base
(require racket/contract/base)
(provide (contract-out
[string-split-lens
(-> (or/c immutable-string? char? regexp?)
(lens/c immutable-string? (listof immutable-string?)))]
))
(require racket/match
racket/string
lens/private/base/main
lens/private/util/immutable
)
(module+ test
(require rackunit))
(define (string-split-lens sep)
(define sep-rx
(cond
[(string? sep) (regexp (regexp-quote sep))]
[(char? sep) (regexp (regexp-quote (string sep)))]
[(regexp? sep) sep]
[else (error 'bad)]))
(define (get str)
(map string->immutable-string (regexp-split sep-rx str)))
(define (set str lst)
(for ([s (in-list lst)])
(when (regexp-match? sep-rx s) ; this would violate the lens laws
(error 'string-split-lens "expected a string not matching ~v, given: ~v" sep s)))
(define seps (regexp-match* sep-rx str))
(match-define (cons fst rst) lst)
(string->immutable-string (string-append* fst (map string-append seps rst))))
(make-lens get set))
(module+ test
(define ws-lens (string-split-lens #px"\\s+"))
(check-equal? (lens-view ws-lens " foo bar baz \r\n\t")
'("" "foo" "bar" "baz" ""))
(check-equal? (lens-set ws-lens " foo bar baz \r\n\t" '("a" "b" "c" "d" "e"))
"a b c d \r\n\te")
(check-equal? (lens-view ws-lens "a b c d \r\n\te")
'("a" "b" "c" "d" "e"))
(check-equal? (lens-set ws-lens "a b c d \r\n\te" '("" "foo" "bar" "baz" ""))
" foo bar baz \r\n\t")
(define newline-lens (string-split-lens "\n"))
(check-equal? (lens-view newline-lens "a,b\nc,d\ne,f,g")
'("a,b" "c,d" "e,f,g"))
(check-equal? (lens-set newline-lens "a,b\nc,d\ne,f,g" '("1" "2" "3"))
"1\n2\n3")
(define comma-lens (string-split-lens #\,))
(check-equal? (lens-view comma-lens "a,b,c")
'("a" "b" "c"))
(check-equal? (lens-set comma-lens "a,b,c" '("1" "2" "3"))
"1,2,3")
)

9
lens/private/string.rkt → lens/private/string/string.rkt
View File

@ -11,12 +11,13 @@
))
(require fancy-app
"base/main.rkt"
"util/immutable.rkt"
"compound/main.rkt")
"../base/main.rkt"
"../util/immutable.rkt"
"../string/join-string.rkt"
"../compound/main.rkt")
(module+ test
(require rackunit "test-util/test-lens.rkt"))
(require rackunit "../test-util/test-lens.rkt"))
(define (string-ref-lens i)

2
lens/private/string.scrbl → lens/private/string/string.scrbl
View File

@ -1,6 +1,6 @@
#lang scribble/manual
@(require "doc-util/main.rkt")
@(require "../doc-util/main.rkt")
@title[#:tag "strings-reference"]{String Lenses}

65
lens/private/string/substring.rkt Normal file
View File

@ -0,0 +1,65 @@
#lang racket/base
(require racket/function racket/contract/base unstable/contract)
(provide
(contract-out
[substring-lens (->i ([start exact-nonnegative-integer?]
[end (start) (and/c exact-nonnegative-integer?
(>=/c start))])
[result (start end)
(lens/c (string-length->=/c end)
(string-length-=/c (- end start)))])]))
(define (string-length->=/c min)
(define (length>=? str)
(>= (string-length str) min))
(and/c string?
(rename-contract length>=?
`(string-length->=/c ,min))))
(define (string-length-=/c n)
(define (length=? str)
(= (string-length str) n))
(and/c string?
(rename-contract length=?
`(string-length-=/c ,n))))
(require lens)
(module+ test
(require rackunit))
(define (set-substring str start end replacement-str)
(string-append (substring str 0 start)
replacement-str
(substring str end)))
(module+ test
(check-equal? (set-substring "mitten" 0 4 "MITT") "MITTen")
(check-equal? (set-substring "mitten" 2 4 "ZZ") "miZZen")
(check-equal? (set-substring "mitten" 2 6 "LLER") "miLLER"))
(define (substring-lens start end)
(define (substring-lens-getter str)
(substring str start end))
(define (substring-lens-setter str replacement-str)
(set-substring str start end replacement-str))
(make-lens substring-lens-getter substring-lens-setter))
(module+ test
(check-pred lens? (substring-lens 2 4))
(check-equal? (lens-view (substring-lens 2 4) "mitten") "tt")
(check-equal? (lens-set (substring-lens 2 4) "mitten" "TT") "miTTen"))
(module+ test
(require (submod ".."))
(check-exn exn:fail:contract?
(thunk (substring-lens -1 5))) ; Improper substring boundaries
(check-exn exn:fail:contract?
(thunk (lens-set (substring-lens 2 4) "kitten" "c"))) ; Replacement string is too short
(check-exn exn:fail:contract?
(thunk (lens-set (substring-lens 2 4) "kitten" "cat"))) ; Replacement string is too long
(check-not-exn
(thunk (lens-set (substring-lens 2 4) "kitten" "ca"))) ; Replacement string is just right!
)

81
lens/private/struct/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))
))

59
lens/private/struct/struct-list.rkt Normal file
View File

@ -0,0 +1,59 @@
#lang sweet-exp racket/base
provide struct->list-lens list->struct-lens
require racket/local
lens/private/isomorphism/base
for-syntax racket/base
racket/list
racket/struct-info
syntax/parse
module+ test
require lens/private/base/base
lens/private/test-util/test-lens
rackunit
begin-for-syntax
(define-syntax-class struct-id
#:attributes (info constructor-id [accessor-id 1])
[pattern struct-id:id
#:attr v (syntax-local-value #'struct-id (λ () #f))
#:when (struct-info? (attribute v))
#:attr info (extract-struct-info (attribute v))
#:with descriptor-id:id (first (attribute info))
#:with constructor-id:id (syntax-property (second (attribute info))
'disappeared-use
(list (syntax-local-introduce #'struct-id)))
#:with predicate-id:id (third (attribute info))
#:with [accessor-id:id ...] (reverse (fourth (attribute info)))])
(define-syntax struct->list-lens
(syntax-parser
[(struct->list-lens s:struct-id)
#'(local [(define (struct->list struct)
(list (s.accessor-id struct) ...))
(define (list->struct list)
(apply s.constructor-id list))]
(make-isomorphism-lens struct->list list->struct))]))
(define-syntax list->struct-lens
(syntax-parser
[(list->struct-lens s:struct-id)
#'(isomorphism-lens-inverse (struct->list-lens s))]))
module+ test
(struct foo (a b c))
;; foo is opaque, so struct->vector doesn't work
(check-equal? (struct->vector (foo 1 2 3)) '#(struct:foo ...))
(test-case "without inheritance"
(check-equal? (lens-view (struct->list-lens foo) (foo 1 2 3)) '(1 2 3))
(check-match (lens-set (struct->list-lens foo) (foo 1 2 3) '(4 5 6)) (foo 4 5 6))
(check-match (lens-view (list->struct-lens foo) '(1 2 3)) (foo 1 2 3))
(check-equal? (lens-set (list->struct-lens foo) '(1 2 3) (foo 4 5 6)) '(4 5 6)))
(struct bar foo (d e))
(test-case "inheriting from foo"
(check-equal? (lens-view (struct->list-lens bar) (bar 1 2 3 4 5)) '(1 2 3 4 5))
(check-match (lens-set (struct->list-lens bar) (bar 1 2 3 4 5) '(6 7 8 9 10)) (bar 6 7 8 9 10))
(check-match (lens-view (list->struct-lens bar) '(1 2 3 4 5)) (bar 1 2 3 4 5))
(check-equal? (lens-set (list->struct-lens bar) '(1 2 3 4 4) (bar 6 7 8 9 10)) '(6 7 8 9 10)))

49
lens/private/struct/struct-nested.rkt Normal file
View File

@ -0,0 +1,49 @@
#lang racket/base
(require fancy-app
lens
(for-syntax racket/base
syntax/parse))
(module+ test
(require rackunit))
(provide struct-nested-lens
struct-nested-lens*)
(define-syntax struct-nested-lens
(syntax-parser
[(_ [struct-id:id field-id:id] ...)
#'(lens-thrush (struct-lens struct-id field-id) ...)]))
(define-syntax struct-nested-lens*
(syntax-parser
[(_ struct-id:id field-id:id)
#'(struct-lens struct-id field-id)]
[(_ struct-id:id both0:id both:id ... field-id:id)
#'(lens-thrush (struct-lens struct-id both0)
(struct-nested-lens* both0 both ... field-id))]))
(module+ test
(struct game (player level) #:transparent)
(struct player (posn stats) #:transparent)
(struct posn (x y) #:transparent)
(struct combat-stats (health attack) #:transparent)
(define the-game (game (player (posn 0 0) (combat-stats 10 1)) 'foo-level))
(define game-player-health-lens
(struct-nested-lens [game player]
[player stats]
[combat-stats health]))
(check-equal? (lens-view game-player-health-lens the-game) 10)
(check-equal? (lens-set game-player-health-lens the-game 20)
(game (player (posn 0 0) (combat-stats 20 1)) 'foo-level))
(define game-player-posn-x-lens
(struct-nested-lens* game player posn x))
(check-equal? (lens-view game-player-posn-x-lens the-game) 0)
(check-equal? (lens-set game-player-posn-x-lens the-game 3)
(game (player (posn 3 0) (combat-stats 10 1)) 'foo-level)))

3
lens/private/syntax/main.rkt Normal file
View File

@ -0,0 +1,3 @@
#lang reprovide
"syntax.rkt"
"syntax-keyword.rkt"

0
unstable/lens/syntax/syntax-keyword.rkt → lens/private/syntax/syntax-keyword.rkt
View File

0
unstable/lens/syntax/syntax.rkt → lens/private/syntax/syntax.rkt
View File

0
unstable/lens/private/id-append.rkt → lens/private/util/id-append.rkt
View File

6
lens/private/compound/join-vector.rkt → lens/private/vector/join-vector.rkt
View File

@ -1,12 +1,12 @@
#lang sweet-exp racket/base
require racket/contract
unstable/lens/isomorphism/base
lens/private/isomorphism/base
"../base/main.rkt"
"../util/immutable.rkt"
"../util/rest-contract.rkt"
"compose.rkt"
"join-list.rkt"
"../compound/compose.rkt"
"../list/join-list.rkt"
module+ test
require rackunit

0
lens/private/compound/join-vector.scrbl → lens/private/vector/join-vector.scrbl
View File

1
lens/private/vector/main.rkt
View File

@ -2,3 +2,4 @@
"nested.rkt"
"pick.rkt"
"ref.rkt"
"join-vector.rkt"

1
lens/private/vector/main.scrbl
View File

@ -7,3 +7,4 @@
@scribble-include/no-subsection["ref.scrbl"]
@scribble-include/no-subsection["nested.scrbl"]
@scribble-include/no-subsection["pick.scrbl"]
@scribble-include/no-subsection["join-vector.scrbl"]

1
lens/private/vector/pick.rkt
View File

@ -5,6 +5,7 @@
"../compound/main.rkt"
"../util/immutable.rkt"
"../util/rest-contract.rkt"
"../vector/join-vector.rkt"
"ref.rkt")
(module+ test

0
unstable/lens/view-set.rkt → lens/private/view-set/set-all.rkt
View File

43
unstable/lens/arrow.rkt
View File

@ -1,41 +1,2 @@
#lang racket/base
(provide lens-view~>
lens-set~>
lens-transform~>
lens-view/thrush
lens-set/thrush
lens-transform/thrush)
(require lens)
(module+ test
(require rackunit racket/list fancy-app))
(define (lens-view~> target . lenses)
(for/fold ([target target]) ([lens (in-list lenses)])
(lens-view lens target)))
(define (lens-set~> target #:-> new-val . lenses)
(lens-set (apply lens-thrush lenses) target new-val))
(define (lens-transform~> target #:-> transformer . lenses)
(lens-transform (apply lens-thrush lenses) target transformer))
(define lens-view/thrush lens-view~>)
(define lens-set/thrush lens-set~>)
(define lens-transform/thrush lens-transform~>)
(module+ test
(define (set-first l v)
(list* v (rest l)))
(define (set-second l v)
(list* (first l) v (rest (rest l))))
(define first-lens (make-lens first set-first))
(define second-lens (make-lens second set-second))
(check-equal? (lens-view~> '((1 2) 3) first-lens second-lens)
2)
(check-equal? (lens-set~> '((1 2) 3) first-lens second-lens #:-> 'two)
'((1 two) 3))
(check-equal? (lens-transform~> '((1 2) 3) first-lens second-lens #:-> (* 100 _))
'((1 200) 3)))
#lang reprovide
lens/private/compound/arrow

76
unstable/lens/define-nested.rkt
View File

@ -1,74 +1,2 @@
#lang sweet-exp racket/base
provide define-nested-lenses
require lens/private/compound/thrush
for-syntax racket/base
racket/syntax
syntax/parse
syntax/srcloc
"private/id-append.rkt"
module+ test
require lens/private/base/base
lens/private/list/main
rackunit
begin-for-syntax
(define (with-sub-range-binders stx prop)
(syntax-property stx 'sub-range-binders prop))
(define -- (update-source-location (datum->syntax #f '-)
#:span 1))
(define -lens (update-source-location (datum->syntax #f '-lens)
#:span 5))
;; helper syntax-class for define-nested-lenses
(define-syntax-class (clause base-id base-lens-tmp)
#:attributes (def)
[pattern [suffix-id:id suffix-lens-expr:expr
unchecked-clause ...]
#:with base-lens:id base-lens-tmp
#:do [(define-values [base-suffix-id base-suffix-sub-range]
(id-append #:context base-id
base-id -- #'suffix-id))
(define-values [base-suffix-lens-id base-suffix-lens-sub-range]
(id-append #:context base-id
base-suffix-id -lens))]
#:with base-suffix
base-suffix-id
#:with base-suffix-lens
base-suffix-lens-id
#:with [(~var clause (clause #'base-suffix #'base-suffix-lens)) ...]
#'[unchecked-clause ...]
#:with def
(with-sub-range-binders
#'(begin
(define base-suffix-lens
(lens-thrush base-lens suffix-lens-expr))
clause.def
...)
base-suffix-lens-sub-range)])
(define-syntax define-nested-lenses
(syntax-parser
[(define-nested-lenses [base:id base-lens-expr:expr]
(~parse base-lens:id (generate-temporary #'base))
(~var clause (clause #'base #'base-lens))
...)
#'(begin
(define base-lens base-lens-expr)
clause.def
...)]))
module+ test
(define-nested-lenses [first first-lens]
[first first-lens]
[second second-lens]
[third third-lens
[first first-lens]
[second second-lens]])
(check-equal? (lens-view first-first-lens '((a b c d) e)) 'a)
(check-equal? (lens-view first-second-lens '((a b c d) e)) 'b)
(check-equal? (lens-view first-third-lens '((a b c d) e)) 'c)
(check-equal? (lens-view first-third-first-lens '((a b (c d) e) f)) 'c)
(check-equal? (lens-view first-third-second-lens '((a b (c d) e) f)) 'd)
#lang reprovide
lens/private/compound/define-nested

26
unstable/lens/dict-nested.rkt
View File

@ -1,24 +1,2 @@
#lang sweet-exp racket/base
require racket/contract/base
provide
contract-out
dict-ref-nested-lens (->* [] #:rest (listof any/c) (lens/c functional-dict? any/c))
require lens/private/base/main
lens/private/compound/thrush
lens/private/dict
lens/private/util/functional-dict
module+ test
require rackunit fancy-app
(define (dict-ref-nested-lens . ks)
(apply lens-thrush (map dict-ref-lens ks)))
module+ test
(define a-x (dict-ref-nested-lens 'a 'x))
(let-lens [val ctxt] a-x '([a . ([x . 1] [y . 2])] '[b . ([z . 3])])
(check-equal? val 1)
(check-equal? (ctxt 100) '([a . ([x . 100] [y . 2])] '[b . ([z . 3])])))
(check-equal? (lens-transform/list '([a . ([x . 1] [y . 2])] '[b . ([z . 3])]) a-x (* 10 _))
'([a . ([x . 10] [y . 2])] '[b . ([z . 3])]))
#lang reprovide
lens/private/dict/dict-nested

62
unstable/lens/hash-filterer.rkt
View File

@ -1,60 +1,2 @@
#lang sweet-exp racket
;; inspired by https://github.com/jackfirth/racket-auto-fix-deps/blob/master/job/src/filter-hash.rkt
provide
contract-out
hash-filterer-lens (-> (-> any/c any/c boolean?) (lens/c immutable-hash? immutable-hash?))
hash-filterer-lens/key (-> predicate/c (lens/c immutable-hash? immutable-hash?))
hash-filterer-lens/value (-> predicate/c (lens/c immutable-hash? immutable-hash?))
require fancy-app
lens/private/base/main
lens/private/util/immutable
unstable/hash
module+ test
require lens/private/test-util/test-lens
rackunit
(define (hash-filter keep? hsh)
(for/hash ([(k v) (in-hash hsh)] #:when (keep? k v))
(values k v)))
(define (hash-filter-not drop? hsh)
(hash-filter (λ (k v) (not (drop? k v))) hsh))
(define (hash-andmap f hsh)
(for/and ([(k v) (in-hash hsh)])
(f k v)))
(define (hash-filterer-lens keep?)
(make-lens
(hash-filter keep? _)
(λ (tgt nvw)
(unless (hash-andmap keep? nvw)
(raise-argument-error 'hash-filterer-lens-setter
(format "a hash where all key-value pairs pass ~v" keep?)
nvw))
(hash-union (hash-filter-not keep? tgt) nvw))))
(define (hash-filterer-lens/key keep?)
(hash-filterer-lens (λ (k v) (keep? k))))
(define (hash-filterer-lens/value keep?)
(hash-filterer-lens (λ (k v) (keep? v))))
module+ test
(check-lens-view (hash-filterer-lens/key symbol?) (hash 'a 1 "b" 2 'c 3)
(hash 'a 1 'c 3))
(check-lens-set (hash-filterer-lens/key symbol?) (hash 'a 1 "b" 2 'c 3) (hash 'd 4 'e 5)
(hash "b" 2 'd 4 'e 5))
(check-lens-view (hash-filterer-lens/value number?) (hash 'a 1 'b "two" 'c 3)
(hash 'a 1 'c 3))
(check-lens-set (hash-filterer-lens/value number?) (hash 'a 1 'b "two" 'c 3) (hash 'd 4)
(hash 'b "two" 'd 4))
(check-lens-view (hash-filterer-lens =) (hash 1 1.0 2 45 3 3)
(hash 1 1.0 3 3))
(check-lens-set (hash-filterer-lens =) (hash 1 1.0 2 45 3 3) (hash 4 4.0 5.0 5)
(hash 2 45 4 4.0 5.0 5))
(check-exn exn:fail:contract?
(thunk (lens-set (hash-filterer-lens/key symbol?) (hash 'a 1) (hash "d" 4))))
#lang reprovide
lens/private/hash/hash-filterer

94
unstable/lens/if.rkt
View File

@ -1,92 +1,2 @@
#lang racket/base
(provide lens-if
lens-cond
lens-match
)
(require lens/private/base/main
racket/match
(for-syntax racket/base
syntax/parse
))
(module+ test
(require rackunit lens/private/list/main lens/private/vector/main lens/private/string))
(define (lens-if pred lens1 lens2)
(make-lens
(λ (tgt)
(if (pred tgt)
(lens-view lens1 tgt)
(lens-view lens2 tgt)))
(λ (tgt nvw)
(if (pred tgt)
(lens-set lens1 tgt nvw)
(lens-set lens2 tgt nvw)))))
(define (any? x) #t)
(define-syntax lens-cond
(syntax-parser #:literals (else)
[(lens-cond [pred-expr:expr lens-expr:expr] ... [else else-lens-expr:expr])
#'(lens-cond [pred-expr lens-expr] ... [any? else-lens-expr])]
[(lens-cond [pred-expr:expr lens-expr:expr] ...)
#:with [pred ...] (generate-temporaries #'[pred-expr ...])
#:with [lens ...] (generate-temporaries #'[lens-expr ...])
#'(let ([pred pred-expr] ... [lens lens-expr] ...)
(make-lens
(λ (tgt)
(cond [(pred tgt) (lens-view lens tgt)]
...
[else (raise-lens-cond-error tgt 'pred-expr ...)]))
(λ (tgt nvw)
(cond [(pred tgt) (lens-set lens tgt nvw)]
...
[else (raise-lens-cond-error tgt 'pred-expr ...)]))))]))
(define (raise-lens-cond-error tgt . pred-expr-syms)
(raise-arguments-error 'lens-cond "no matching clause for target"
"target" tgt
"expected" `(or/c ,@pred-expr-syms)))
(define-syntax lens-match
(syntax-parser
[(lens-match [pat:expr lens-expr:expr] ...)
#'(make-lens
(λ (tgt)
(match tgt
[pat (lens-view lens-expr tgt)]
...))
(λ (tgt nvw)
(match tgt
[pat (lens-set lens-expr tgt nvw)]
...)))]))
(module+ test
(define if-lens (lens-if list? first-lens (vector-ref-lens 0)))
(check-equal? (lens-view if-lens '(1 2 3)) 1)
(check-equal? (lens-view if-lens '#(1 2 3)) 1)
(check-equal? (lens-set if-lens '(1 2 3) 'a) '(a 2 3))
(check-equal? (lens-set if-lens '#(1 2 3) 'a) '#(a 2 3))
(define cond-lens (lens-cond [list? first-lens]
[vector? (vector-ref-lens 0)]
[string? (string-ref-lens 0)]))
(check-equal? (lens-view cond-lens '(1 2 3)) 1)
(check-equal? (lens-view cond-lens '#(1 2 3)) 1)
(check-equal? (lens-view cond-lens "123") #\1)
(check-equal? (lens-set cond-lens '(1 2 3) 'a) '(a 2 3))
(check-equal? (lens-set cond-lens '#(1 2 3) 'a) '#(a 2 3))
(check-equal? (lens-set cond-lens "123" #\a) "a23")
(define match-lens (lens-match [(list a) first-lens]
[(list a b) second-lens]
[(list a b c) third-lens]
[(list a ... b) (list-ref-lens (length a))]))
(check-equal? (lens-view match-lens '(1)) 1)
(check-equal? (lens-view match-lens '(1 2)) 2)
(check-equal? (lens-view match-lens '(1 2 3)) 3)
(check-equal? (lens-view match-lens '(1 2 3 4 5 6)) 6)
(check-equal? (lens-set match-lens '(1) 'a) '(a))
(check-equal? (lens-set match-lens '(1 2) 'a) '(1 a))
(check-equal? (lens-set match-lens '(1 2 3) 'a) '(1 2 a))
(check-equal? (lens-set match-lens '(1 2 3 4 5 6) 'a) '(1 2 3 4 5 a))
)
#lang reprovide
lens/private/compound/if

4
unstable/lens/isomorphism.rkt
View File

@ -1,4 +1,2 @@
#lang reprovide
"isomorphism/base.rkt"
"isomorphism/compound.rkt"
"isomorphism/data.rkt"
lens/private/isomorphism/main

37
unstable/lens/join-assoc.rkt
View File

@ -1,35 +1,2 @@
#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))
#lang reprovide
lens/private/list/join-assoc

31
unstable/lens/lazy.rkt
View File

@ -1,29 +1,2 @@
#lang sweet-exp racket/base
provide lazy-lens
rec-lens
require fancy-app lens/private/base/main racket/promise
module+ test
require rackunit "if.rkt" "isomorphism/data.rkt" "map.rkt"
(define-syntax-rule (lazy-lens expr)
(let ([p (delay expr)])
(make-lens (lens-view (force p) _) (lens-set (force p) _ _))))
(define-syntax-rule (rec-lens name expr)
(letrec ([name (lazy-lens expr)])
name))
module+ test
(define (tree-map-lens item-lens)
(rec-lens the-tree-lens
(lens-cond [list? (map-lens the-tree-lens)]
[else item-lens])))
(check-equal? (lens-view (tree-map-lens symbol->string-lens) '(a (b (() c)) (d)))
'("a" ("b" (() "c")) ("d")))
(check-equal? (lens-set (tree-map-lens symbol->string-lens)
'(a (b (() c)) (d))
'("hay" ("bee" (() "sea")) ("deep")))
'(hay (bee (() sea)) (deep)))
#lang reprovide
lens/private/compound/lazy

2
unstable/lens/main.rkt
View File

@ -19,5 +19,5 @@
"sublist.rkt"
"substring.rkt"
"syntax.rkt"
"view-set.rkt"
"set-all.rkt"
"zoom.rkt"

2
unstable/lens/main.scrbl
View File

@ -32,7 +32,7 @@ this library being backwards-compatible.
"sublist.scrbl"
"substring.scrbl"
"syntax.scrbl"
"view-set.scrbl"
"set-all.scrbl"
"zoom.scrbl"
)

57
unstable/lens/map.rkt
View File

@ -1,55 +1,2 @@
#lang racket/base
(require racket/contract/base)
(provide (contract-out
[map-lens
(-> lens? (lens/c list? list?))]
[vector-map-lens
(-> lens? (lens/c immutable-vector? immutable-vector?))]
))
(require lens/private/base/main
lens/private/util/immutable
racket/vector
fancy-app
)
(module+ test
(require rackunit lens/private/list/main))
(define (map-lens lens)
(make-lens
(lens-view/map lens _)
(lens-set/map lens _ _)))
(define (lens-view/map lens tgts)
(map (lens-view lens _) tgts))
(define (lens-set/map lens tgts new-views)
(map (lens-set lens _ _) tgts new-views))
(define (vector-map-lens lens)
(make-lens
(lens-view/vector-map lens _)
(lens-set/vector-map lens _ _)))
(define (lens-view/vector-map lens tgt)
(vector->immutable-vector (vector-map (lens-view lens _) tgt)))
(define (lens-set/vector-map lens tgt new-view)
(vector->immutable-vector (vector-map (lens-set lens _ _) tgt new-view)))
(module+ test
(check-equal? (lens-view (map-lens first-lens) '((a b) (c d) (e f)))
'(a c e))
(check-equal? (lens-set (map-lens first-lens) '((a b) (c d) (e f)) '(1 2 3))
'((1 b) (2 d) (3 f)))
(check-equal? (lens-transform (map-lens first-lens) '((a b) (c d) (e f)) (map symbol->string _))
'(("a" b) ("c" d) ("e" f)))
(check-equal? (lens-view (vector-map-lens first-lens) '#((a b) (c d) (e f)))
'#(a c e))
(check-equal? (lens-set (vector-map-lens first-lens) '#((a b) (c d) (e f)) '#(1 2 3))
'#((1 b) (2 d) (3 f)))
(check-equal? (lens-transform (vector-map-lens first-lens) '#((a b) (c d) (e f))
(immutable-vector-map symbol->string _))
'#(("a" b) ("c" d) ("e" f)))
)
#lang reprovide
lens/private/list/map

36
unstable/lens/match.rkt
View File

@ -1,34 +1,2 @@
#lang racket/base
(provide match-lens)
(require racket/match
racket/local
syntax/parse/define
lens/private/base/main
)
(module+ test
(require rackunit lens/private/test-util/test-lens))
(define-simple-macro (match-lens a:id pat:expr replacement:expr)
(local [(define (get target)
(match target
[pat
a]))
(define (set target new-view)
(match target
[pat
(let ([a new-view])
replacement)]))]
(make-lens get set)))
(module+ test
(define car-lens (match-lens a (cons a b) (cons a b)))
(define cdr-lens (match-lens b (cons a b) (cons a b)))
(check-lens-view car-lens (cons 1 2) 1)
(check-lens-view cdr-lens (cons 1 2) 2)
(check-lens-set car-lens (cons 1 2) 'a (cons 'a 2))
(check-lens-set cdr-lens (cons 1 2) 'a (cons 1 'a))
(test-lens-laws car-lens (cons 1 2) 'a 'b)
(test-lens-laws cdr-lens (cons 1 2) 'a 'b)
)
#lang reprovide
lens/private/match

2
unstable/lens/reverse.rkt Normal file
View File

@ -0,0 +1,2 @@
#lang reprovide
lens/private/list/reverse

2
unstable/lens/set-all.rkt Normal file
View File

@ -0,0 +1,2 @@
#lang reprovide
lens/private/view-set/set-all

0
unstable/lens/view-set.scrbl → unstable/lens/set-all.scrbl
View File

56
unstable/lens/set-filterer.rkt
View File

@ -1,54 +1,2 @@
#lang sweet-exp racket/base
require racket/contract/base
provide
contract-out
set-filterer-lens (-> predicate/c (lens/c functional-set? functional-set?))
require lens/private/base/main
lens/private/util/functional-set
racket/set
racket/function
fancy-app
module+ test
require rackunit
(define (set-filter pred set)
(for/fold ([set set]) ([elem (in-set set)] #:unless (pred elem))
(set-remove set elem)))
(define (set-filter-not pred set)
(for/fold ([set set]) ([elem (in-set set)] #:when (pred elem))
(set-remove set elem)))
(define (andmap-set pred set)
(andmap pred (set->list set)))
(define (check-set-filterer-lens-view pred new-view-to-check)
(unless (andmap-set pred new-view-to-check)
(raise-argument-error 'set-filterer-lens
(format "(set/c ~a)" (contract-name pred))
new-view-to-check)))
(define (set-filterer-lens pred)
(define (insert-filtered-items target new-view)
(check-set-filterer-lens-view pred new-view)
(set-union (set-filter-not pred target) new-view))
(make-lens (set-filter pred _)
insert-filtered-items))
module+ test
(check-equal? (lens-view (set-filterer-lens number?) '(1 a 2 b c 3 d e))
'(1 2 3))
(check-equal? (lens-set (set-filterer-lens number?) '(1 a 2 b c 3 d e) '(4 5 6 7))
'(7 6 5 4 a b c d e))
(check-equal? (lens-view (set-filterer-lens number?) (set 1 'a 2 'b 'c 3 'd 'e))
(set 1 2 3))
(check-equal? (lens-set (set-filterer-lens number?) (set 1 'a 2 'b 'c 3 'd 'e) (set 4 5 6 7))
(set 4 5 6 7 'a 'b 'c 'd 'e))
(check-exn exn:fail:contract?
(thunk (lens-set (set-filterer-lens number?) (set 1) (set 'a))))
#lang reprovide
lens/private/set/set-filterer

32
unstable/lens/set-member.rkt
View File

@ -1,30 +1,2 @@
#lang sweet-exp racket/base
require racket/contract/base
provide
contract-out
set-member-lens (-> any/c (lens/c functional-set? boolean?))
require fancy-app
lens/private/base/main
lens/private/util/functional-set
racket/set
module+ test
require rackunit
(define (set-member-lens v)
(make-lens
(set-member? _ v)
(λ (tgt nvw)
(if nvw
(set-add tgt v)
(set-remove tgt v)))))
module+ test
(define 2-lens (set-member-lens 2))
(check-equal? (lens-view 2-lens (set 1 2 3)) #t)
(check-equal? (lens-view 2-lens (set 1 3)) #f)
(check-equal? (lens-set 2-lens (set 1 2 3) #t) (set 1 2 3))
(check-equal? (lens-set 2-lens (set 1 2 3) #f) (set 1 3))
(check-equal? (lens-set 2-lens (set 1 3) #t) (set 1 2 3))
(check-equal? (lens-set 2-lens (set 1 3) #f) (set 1 3))
#lang reprovide
lens/private/set/set-member

58
unstable/lens/string-split.rkt
View File

@ -1,56 +1,2 @@
#lang racket/base
(require racket/contract/base)
(provide (contract-out
[string-split-lens
(-> (or/c immutable-string? char? regexp?)
(lens/c immutable-string? (listof immutable-string?)))]
))
(require racket/match
racket/string
lens/private/base/main
lens/private/util/immutable
)
(module+ test
(require rackunit))
(define (string-split-lens sep)
(define sep-rx
(cond
[(string? sep) (regexp (regexp-quote sep))]
[(char? sep) (regexp (regexp-quote (string sep)))]
[(regexp? sep) sep]
[else (error 'bad)]))
(define (get str)
(map string->immutable-string (regexp-split sep-rx str)))
(define (set str lst)
(for ([s (in-list lst)])
(when (regexp-match? sep-rx s) ; this would violate the lens laws
(error 'string-split-lens "expected a string not matching ~v, given: ~v" sep s)))
(define seps (regexp-match* sep-rx str))
(match-define (cons fst rst) lst)
(string->immutable-string (string-append* fst (map string-append seps rst))))
(make-lens get set))
(module+ test
(define ws-lens (string-split-lens #px"\\s+"))
(check-equal? (lens-view ws-lens " foo bar baz \r\n\t")
'("" "foo" "bar" "baz" ""))
(check-equal? (lens-set ws-lens " foo bar baz \r\n\t" '("a" "b" "c" "d" "e"))
"a b c d \r\n\te")
(check-equal? (lens-view ws-lens "a b c d \r\n\te")
'("a" "b" "c" "d" "e"))
(check-equal? (lens-set ws-lens "a b c d \r\n\te" '("" "foo" "bar" "baz" ""))
" foo bar baz \r\n\t")
(define newline-lens (string-split-lens "\n"))
(check-equal? (lens-view newline-lens "a,b\nc,d\ne,f,g")
'("a,b" "c,d" "e,f,g"))
(check-equal? (lens-set newline-lens "a,b\nc,d\ne,f,g" '("1" "2" "3"))
"1\n2\n3")
(define comma-lens (string-split-lens #\,))
(check-equal? (lens-view comma-lens "a,b,c")
'("a" "b" "c"))
(check-equal? (lens-set comma-lens "a,b,c" '("1" "2" "3"))
"1,2,3")
)
#lang reprovide
lens/private/string/string-split

83
unstable/lens/struct-join.rkt
View File

@ -1,81 +1,2 @@
#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))
))
#lang reprovide
lens/private/struct/struct-join

61
unstable/lens/struct-list.rkt
View File

@ -1,59 +1,2 @@
#lang sweet-exp racket/base
provide struct->list-lens list->struct-lens
require racket/local
unstable/lens/isomorphism/base
for-syntax racket/base
racket/list
racket/struct-info
syntax/parse
module+ test
require lens/private/base/base
lens/private/test-util/test-lens
rackunit
begin-for-syntax
(define-syntax-class struct-id
#:attributes (info constructor-id [accessor-id 1])
[pattern struct-id:id
#:attr v (syntax-local-value #'struct-id (λ () #f))
#:when (struct-info? (attribute v))
#:attr info (extract-struct-info (attribute v))
#:with descriptor-id:id (first (attribute info))
#:with constructor-id:id (syntax-property (second (attribute info))
'disappeared-use
(list (syntax-local-introduce #'struct-id)))
#:with predicate-id:id (third (attribute info))
#:with [accessor-id:id ...] (reverse (fourth (attribute info)))])
(define-syntax struct->list-lens
(syntax-parser
[(struct->list-lens s:struct-id)
#'(local [(define (struct->list struct)
(list (s.accessor-id struct) ...))
(define (list->struct list)
(apply s.constructor-id list))]
(make-isomorphism-lens struct->list list->struct))]))
(define-syntax list->struct-lens
(syntax-parser
[(list->struct-lens s:struct-id)
#'(isomorphism-lens-inverse (struct->list-lens s))]))
module+ test
(struct foo (a b c))
;; foo is opaque, so struct->vector doesn't work
(check-equal? (struct->vector (foo 1 2 3)) '#(struct:foo ...))
(test-case "without inheritance"
(check-equal? (lens-view (struct->list-lens foo) (foo 1 2 3)) '(1 2 3))
(check-match (lens-set (struct->list-lens foo) (foo 1 2 3) '(4 5 6)) (foo 4 5 6))
(check-match (lens-view (list->struct-lens foo) '(1 2 3)) (foo 1 2 3))
(check-equal? (lens-set (list->struct-lens foo) '(1 2 3) (foo 4 5 6)) '(4 5 6)))
(struct bar foo (d e))
(test-case "inheriting from foo"
(check-equal? (lens-view (struct->list-lens bar) (bar 1 2 3 4 5)) '(1 2 3 4 5))
(check-match (lens-set (struct->list-lens bar) (bar 1 2 3 4 5) '(6 7 8 9 10)) (bar 6 7 8 9 10))
(check-match (lens-view (list->struct-lens bar) '(1 2 3 4 5)) (bar 1 2 3 4 5))
(check-equal? (lens-set (list->struct-lens bar) '(1 2 3 4 4) (bar 6 7 8 9 10)) '(6 7 8 9 10)))
#lang reprovide
lens/private/struct/struct-list

51
unstable/lens/struct-nested.rkt
View File

@ -1,49 +1,2 @@
#lang racket/base
(require fancy-app
lens
(for-syntax racket/base
syntax/parse))
(module+ test
(require rackunit))
(provide struct-nested-lens
struct-nested-lens*)
(define-syntax struct-nested-lens
(syntax-parser
[(_ [struct-id:id field-id:id] ...)
#'(lens-thrush (struct-lens struct-id field-id) ...)]))
(define-syntax struct-nested-lens*
(syntax-parser
[(_ struct-id:id field-id:id)
#'(struct-lens struct-id field-id)]
[(_ struct-id:id both0:id both:id ... field-id:id)
#'(lens-thrush (struct-lens struct-id both0)
(struct-nested-lens* both0 both ... field-id))]))
(module+ test
(struct game (player level) #:transparent)
(struct player (posn stats) #:transparent)
(struct posn (x y) #:transparent)
(struct combat-stats (health attack) #:transparent)
(define the-game (game (player (posn 0 0) (combat-stats 10 1)) 'foo-level))
(define game-player-health-lens
(struct-nested-lens [game player]
[player stats]
[combat-stats health]))
(check-equal? (lens-view game-player-health-lens the-game) 10)
(check-equal? (lens-set game-player-health-lens the-game 20)
(game (player (posn 0 0) (combat-stats 20 1)) 'foo-level))
(define game-player-posn-x-lens
(struct-nested-lens* game player posn x))
(check-equal? (lens-view game-player-posn-x-lens the-game) 0)
(check-equal? (lens-set game-player-posn-x-lens the-game 3)
(game (player (posn 3 0) (combat-stats 10 1)) 'foo-level)))
#lang reprovide
lens/private/struct/struct-nested

21
unstable/lens/sublist.rkt
View File

@ -1,19 +1,2 @@
#lang racket/base
(provide sublist-lens)
(require lens
lens/private/list/list-ref-take-drop)
(module+ test
(require rackunit))
(define (sublist-lens i j)
(lens-thrush (take-lens j) (drop-lens i)))
(module+ test
(check-equal? (lens-view (sublist-lens 1 4) '(0 1 2 3 4 5))
'(1 2 3))
(check-equal? (lens-set (sublist-lens 1 4) '(0 1 2 3 4 5) '(a b c))
'(0 a b c 4 5))
)
#lang reprovide
lens/private/list/sublist

67
unstable/lens/substring.rkt
View File

@ -1,65 +1,2 @@
#lang racket/base
(require racket/function racket/contract/base unstable/contract)
(provide
(contract-out
[substring-lens (->i ([start exact-nonnegative-integer?]
[end (start) (and/c exact-nonnegative-integer?
(>=/c start))])
[result (start end)
(lens/c (string-length->=/c end)
(string-length-=/c (- end start)))])]))
(define (string-length->=/c min)
(define (length>=? str)
(>= (string-length str) min))
(and/c string?
(rename-contract length>=?
`(string-length->=/c ,min))))
(define (string-length-=/c n)
(define (length=? str)
(= (string-length str) n))
(and/c string?
(rename-contract length=?
`(string-length-=/c ,n))))
(require lens)
(module+ test
(require rackunit))
(define (set-substring str start end replacement-str)
(string-append (substring str 0 start)
replacement-str
(substring str end)))
(module+ test
(check-equal? (set-substring "mitten" 0 4 "MITT") "MITTen")
(check-equal? (set-substring "mitten" 2 4 "ZZ") "miZZen")
(check-equal? (set-substring "mitten" 2 6 "LLER") "miLLER"))
(define (substring-lens start end)
(define (substring-lens-getter str)
(substring str start end))
(define (substring-lens-setter str replacement-str)
(set-substring str start end replacement-str))
(make-lens substring-lens-getter substring-lens-setter))
(module+ test
(check-pred lens? (substring-lens 2 4))
(check-equal? (lens-view (substring-lens 2 4) "mitten") "tt")
(check-equal? (lens-set (substring-lens 2 4) "mitten" "TT") "miTTen"))
(module+ test
(require (submod ".."))
(check-exn exn:fail:contract?
(thunk (substring-lens -1 5))) ; Improper substring boundaries
(check-exn exn:fail:contract?
(thunk (lens-set (substring-lens 2 4) "kitten" "c"))) ; Replacement string is too short
(check-exn exn:fail:contract?
(thunk (lens-set (substring-lens 2 4) "kitten" "cat"))) ; Replacement string is too long
(check-not-exn
(thunk (lens-set (substring-lens 2 4) "kitten" "ca"))) ; Replacement string is just right!
)
#lang reprovide
lens/private/string/substring

3
unstable/lens/syntax.rkt
View File

@ -1,3 +1,2 @@
#lang reprovide
"syntax/syntax.rkt"
"syntax/syntax-keyword.rkt"
lens/private/syntax/main

106
unstable/lens/zoom.rkt
View File

@ -1,104 +1,2 @@
#lang sweet-exp racket/base
require racket/contract/base
provide
contract-out
lens-zoom (-> lens? lens? lens?)
lens-zoom* (->* [] #:rest (listof2 lens? lens?) lens?)
require fancy-app
lens/private/base/main
lens/private/compound/thrush
lens/private/util/list-pair-contract
racket/match
unstable/sequence
"isomorphism/base.rkt"
module+ test
require lens/private/list/main
rackunit
"isomorphism/data.rkt"
"map.rkt"
;; lens-zoom : (Lens (Outer Inner) Inner) (Lens A B) -> (Lens (Outer A) (Outer B))
(define (lens-zoom zoom-lens transformer-lens)
(match transformer-lens
[(make-isomorphism-lens transformer inverse)
;; transformer : A -> B
;; inverse : B -> A
(make-isomorphism-lens
(lens-transform zoom-lens _ transformer) ; (Outer A) -> (Outer B)
(lens-transform zoom-lens _ inverse))] ; (Outer B) -> (Outer A)
[transformer-lens
;; get : (Outer A) -> (Outer B)
(define (get tgt)
;; transformer : A -> B
(define (transformer a)
(lens-view transformer-lens a))
(lens-transform zoom-lens tgt transformer))
;; set : (Outer A) (Outer B) -> (Outer A)
(define (set tgt nvw)
;; a : A
(define a (lens-view zoom-lens tgt))
;; transformer : B -> A
(define (transformer b)
(lens-set transformer-lens a b))
(lens-transform zoom-lens nvw transformer))
(make-lens get set)]))
(define (lens-zoom* . lenses/transformers)
(apply lens-thrush
(for/list ([args (in-slice 2 lenses/transformers)])
(apply lens-zoom args))))
module+ test
(define first-sym->str
(lens-zoom first-lens symbol->string-lens))
(check-equal? (lens-view first-sym->str '(a b c))
'("a" b c))
(check-equal? (lens-set first-sym->str '(a b c) '("a" b c))
'(a b c))
(check-equal? (lens-set first-sym->str '(a b c) '("z" b c))
'(z b c))
(check-equal? (lens-set first-sym->str '(a b c) '("z" bee sea))
'(z bee sea))
(check-equal? (lens-view first-sym->str (lens-set first-sym->str '(a b c) '("z" bee sea)))
'("z" bee sea))
(define trans-second-first/third-second
(lens-zoom* second-lens first-lens third-lens second-lens))
(check-equal? (lens-view trans-second-first/third-second '(1 (2 3) (4 5)))
'(1 2 5))
(check-equal? (lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(1 2 5))
'(1 (2 3) (4 5)))
(check-equal? (lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(1 b 5))
'(1 (b 3) (4 5)))
(check-equal? (lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(a b c))
'(a (b 3) (4 c)))
(check-equal? (lens-view trans-second-first/third-second
(lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(a b c)))
'(a b c))
(define (rekey-alist-lens key->new-key-lens)
(map-lens (lens-zoom car-lens key->new-key-lens)))
(check-equal? (lens-view (rekey-alist-lens symbol->string-lens) '((a . 1) (b . 2) (c . 3)))
'(("a" . 1) ("b" . 2) ("c" . 3)))
(check-equal? (lens-set (rekey-alist-lens symbol->string-lens)
'((a . 1) (b . 2) (c . 3))
'(("a" . 10) ("b" . 200) ("c" . 3000)))
'((a . 10) (b . 200) (c . 3000)))
(check-equal? (lens-set (rekey-alist-lens symbol->string-lens)
'((a . 1) (b . 2) (c . 3))
'(("one" . 10) ("two" . 200) ("three" . 3000)))
'((one . 10) (two . 200) (three . 3000)))
(define (rek+v-alist-lens key->new-key-lens value->new-value-lens)
(map-lens (lens-zoom* car-lens key->new-key-lens cdr-lens value->new-value-lens)))
(check-equal? (lens-view (rek+v-alist-lens symbol->string-lens number->string-lens)
'((a . 1) (b . 2) (c . 3)))
'(("a" . "1") ("b" . "2") ("c" . "3")))
(check-equal? (lens-set (rek+v-alist-lens symbol->string-lens number->string-lens)
'((a . 1) (b . 2) (c . 3))
'(("a" . "10") ("b" . "200") ("c" . "3000")))
'((a . 10) (b . 200) (c . 3000)))
(check-equal? (lens-set (rek+v-alist-lens symbol->string-lens number->string-lens)
'((a . 1) (b . 2) (c . 3))
'(("one" . "10") ("two" . "200") ("three" . "3000")))
'((one . 10) (two . 200) (three . 3000)))
#lang reprovide
lens/private/compound/zoom