diff --git a/lens/private/dict/dict-nested.rkt b/lens/private/dict/dict-nested.rkt new file mode 100644 index 0000000..c54b362 --- /dev/null +++ b/lens/private/dict/dict-nested.rkt @@ -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 + 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])])) diff --git a/lens/private/hash/hash-filterer.rkt b/lens/private/hash/hash-filterer.rkt new file mode 100644 index 0000000..087b405 --- /dev/null +++ b/lens/private/hash/hash-filterer.rkt @@ -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)))) diff --git a/lens/private/if.rkt b/lens/private/if.rkt new file mode 100644 index 0000000..7bd2090 --- /dev/null +++ b/lens/private/if.rkt @@ -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)) + +(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)) + ) diff --git a/unstable/lens/dict-nested.rkt b/unstable/lens/dict-nested.rkt index c54b362..0ee5ed1 100644 --- a/unstable/lens/dict-nested.rkt +++ b/unstable/lens/dict-nested.rkt @@ -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 diff --git a/unstable/lens/hash-filterer.rkt b/unstable/lens/hash-filterer.rkt index 087b405..085f45d 100644 --- a/unstable/lens/hash-filterer.rkt +++ b/unstable/lens/hash-filterer.rkt @@ -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 diff --git a/unstable/lens/if.rkt b/unstable/lens/if.rkt index 7bd2090..1f9e32d 100644 --- a/unstable/lens/if.rkt +++ b/unstable/lens/if.rkt @@ -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/if