diff --git a/info.rkt b/info.rkt index 2eca171..4660de1 100644 --- a/info.rkt +++ b/info.rkt @@ -27,43 +27,43 @@ (define test-omit-paths '("info.rkt" - "lens/base/base.scrbl" - "lens/base/contract.scrbl" - "lens/base/laws.scrbl" - "lens/base/main.scrbl" - "lens/base/transform.scrbl" - "lens/base/view-set.scrbl" - "lens/compound/compose.scrbl" - "lens/compound/join-hash.scrbl" - "lens/compound/join-list.scrbl" - "lens/compound/join-string.scrbl" - "lens/compound/join-vector.scrbl" - "lens/compound/main.scrbl" - "lens/compound/thrush.scrbl" - "lens/doc-util" - "lens/hash/main.scrbl" - "lens/hash/nested.scrbl" - "lens/hash/pick.scrbl" - "lens/hash/ref.scrbl" - "lens/list/assoc.scrbl" - "lens/list/car-cdr.scrbl" - "lens/list/list-ref-take-drop.scrbl" - "lens/list/main.scrbl" - "lens/list/multi.scrbl" - "lens/struct/field.scrbl" - "lens/struct/main.scrbl" - "lens/struct/struct.scrbl" - "lens/test-util" - "lens/vector/main.scrbl" - "lens/vector/nested.scrbl" - "lens/vector/pick.scrbl" - "lens/vector/ref.scrbl" + "lens/private/base/base.scrbl" + "lens/private/base/contract.scrbl" + "lens/private/base/laws.scrbl" + "lens/private/base/main.scrbl" + "lens/private/base/transform.scrbl" + "lens/private/base/view-set.scrbl" + "lens/private/compound/compose.scrbl" + "lens/private/compound/join-hash.scrbl" + "lens/private/compound/join-list.scrbl" + "lens/private/compound/join-string.scrbl" + "lens/private/compound/join-vector.scrbl" + "lens/private/compound/main.scrbl" + "lens/private/compound/thrush.scrbl" + "lens/private/doc-util" + "lens/private/hash/main.scrbl" + "lens/private/hash/nested.scrbl" + "lens/private/hash/pick.scrbl" + "lens/private/hash/ref.scrbl" + "lens/private/list/assoc.scrbl" + "lens/private/list/car-cdr.scrbl" + "lens/private/list/list-ref-take-drop.scrbl" + "lens/private/list/main.scrbl" + "lens/private/list/multi.scrbl" + "lens/private/struct/field.scrbl" + "lens/private/struct/main.scrbl" + "lens/private/struct/struct.scrbl" + "lens/private/test-util" + "lens/private/vector/main.scrbl" + "lens/private/vector/nested.scrbl" + "lens/private/vector/pick.scrbl" + "lens/private/vector/ref.scrbl" "lens/applicable.scrbl" - "lens/dict.scrbl" + "lens/private/dict.scrbl" "lens/info.rkt" "lens/main.scrbl" - "lens/stream.scrbl" - "lens/string.scrbl" + "lens/private/stream.scrbl" + "lens/private/string.scrbl" "unstable/lens/arrow.scrbl" "unstable/lens/main.scrbl" "unstable/lens/sublist.scrbl" diff --git a/lens/private/compound/compose.rkt b/lens/private/compound/compose.rkt index 3e203ef..71b0efa 100644 --- a/lens/private/compound/compose.rkt +++ b/lens/private/compound/compose.rkt @@ -11,6 +11,7 @@ require racket/contract module+ test require rackunit + racket/set provide contract-out @@ -39,7 +40,7 @@ provide (foldr lens-compose2 identity-lens args)])) -(module+ test +module+ test (define (set-first l v) (list* v (rest l))) (define first-lens (make-lens first set-first)) @@ -49,4 +50,7 @@ provide (define test-alist '((a 1) (b 2) (c 3))) (define first-of-second-lens (lens-compose first-lens second-lens)) (check-equal? (lens-view first-of-second-lens test-alist) 'b) - (check-equal? (lens-set first-of-second-lens test-alist 'B) '((a 1) (B 2) (c 3)))) + (check-equal? (lens-set first-of-second-lens test-alist 'B) '((a 1) (B 2) (c 3))) + (check-eq? (lens-compose) identity-lens) + (check-pred isomorphism-lens? (lens-compose (make-isomorphism-lens set->list list->set) + (make-isomorphism-lens list->vector vector->list))) diff --git a/lens/private/stream.rkt b/lens/private/stream.rkt index 882e7c4..e805b0b 100644 --- a/lens/private/stream.rkt +++ b/lens/private/stream.rkt @@ -1,16 +1,27 @@ -#lang racket/base +#lang sweet-exp racket/base -(provide stream-first-lens - stream-rest-lens - stream-ref-lens) +require racket/contract/base -(require racket/stream - fancy-app - "base/main.rkt" - "compound/main.rkt") +provide + contract-out + stream-first-lens (lens/c stream? any/c) + stream-rest-lens (lens/c stream? stream?) + stream-ref-lens (-> exact-nonnegative-integer? (lens/c stream? any/c)) + +require racket/stream + fancy-app + "base/main.rkt" + "compound/main.rkt" + +module+ test + require rackunit + "test-util/test-lens.rkt" + + +module+ test + (define-check (check-stream-equal? stream1 stream2) + (equal? (stream->list stream1) (stream->list stream2))) -(module+ test - (require rackunit "test-util/test-lens.rkt")) (define (stream-ref-lens i) (lens-compose stream-first-lens (stream-tail-lens i))) @@ -43,14 +54,22 @@ (for/fold ([rst rst]) ([v (in-list rev-fst)]) (stream-cons v rst))) +module+ test + (check-equal? (lens-view stream-first-lens (stream 'a 'b 'c)) 'a) + (check-equal? (lens-view (stream-ref-lens 2) (stream 'a 'b 'c)) 'c) + (check-stream-equal? (lens-set stream-first-lens (stream 'a 'b 'c) 1) + (stream 1 'b 'c)) + (check-stream-equal? (lens-set (stream-ref-lens 2) (stream 'a 'b 'c) 1) + (stream 'a 'b 1)) + (define (stream-ref-nested-lens . is) (apply lens-thrush (map stream-ref-lens is))) -(module+ test - (check-view stream-first-lens (stream 'a 'b 'c) 'a) - (check-view (stream-ref-lens 2) (stream 'a 'b 'c) 'c) - (check-set-view stream-first-lens (stream 'a 'b 'c) (gensym)) - (check-set-view (stream-ref-lens 2) (stream 'a 'b 'c) (gensym)) - (check-set-set stream-first-lens (stream 'a 'b 'c) (gensym) (gensym)) - (check-set-set (stream-ref-lens 2) (stream 'a 'b 'c) (gensym) (gensym)) - ) +module+ test + (check-equal? (lens-view (stream-ref-nested-lens 1 2 0) + (stream 'a (stream 1 2 (stream 'foo 'bar 'baz) 3 4) 'b 'c 'd)) + 'foo) + (check-stream-equal? (lens-set (stream-ref-nested-lens 1 2 0) + (stream 'a (stream 1 2 (stream 'foo 'bar 'baz) 3 4) 'b 'c 'd) + 'FOO) + (stream 'a (stream 1 2 (stream 'FOO 'bar 'baz) 3 4) 'b 'c 'd)) diff --git a/unstable/lens/set-filterer.rkt b/unstable/lens/set-filterer.rkt index 10a4873..d941b01 100644 --- a/unstable/lens/set-filterer.rkt +++ b/unstable/lens/set-filterer.rkt @@ -1,26 +1,19 @@ -#lang racket/base +#lang sweet-exp racket/base -(require racket/contract/base) -(provide (contract-out - [set-filterer-lens - (-> predicate/c (lens/c functional-set? functional-set?))] - )) +require racket/contract/base -(require lens/private/base/main - racket/list - racket/set - fancy-app - ) -(module+ test - (require rackunit)) +provide + contract-out + set-filterer-lens (-> predicate/c (lens/c functional-set? functional-set?)) + +require lens/private/base/main + racket/set + racket/function + fancy-app + +module+ test + require rackunit -(define (set-filterer-lens pred) - (make-lens - (set-filter pred _) - (λ (tgt nvw) - (unless (andmap pred (set->list nvw)) - (error 'set-filterer-lens "expected (set/c ~a), given: ~v" (contract-name pred) nvw)) - (set-union (set-filter-not pred tgt) nvw)))) (define (set-filter pred set) (for/fold ([set set]) ([elem (in-set set)] #:unless (pred elem)) @@ -30,11 +23,24 @@ (for/fold ([set set]) ([elem (in-set set)] #:when (pred elem)) (set-remove set elem))) -(define (functional-set? st) - (and (generic-set? st) - (set-implements? st 'set-add 'set-remove))) +(define (andmap-set pred set) + (andmap pred (set->list set))) -(module+ test + +(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)) @@ -43,4 +49,16 @@ (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)))) + + +(define (functional-set? st) + (and (generic-set? st) + (set-implements? st 'set-add 'set-remove) + (not (set-mutable? st)))) + +module+ test + (check-true (functional-set? (set 1 2 3))) + (check-true (functional-set? '(1 2 3))) + (check-false (functional-set? (mutable-set 1 2 3)))