Merge pull request #216 from AlexKnauth/hash-filter

add hash-filterer-lens

unstable/lens/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))))

unstable/lens/hash-filterer.scrbl

@@ -0,0 +1,35 @@
+#lang scribble/manual
+
+@(require lens/private/doc-util/main)
+
+@title{Filtering hash-tables}
+
+@defmodule[unstable/lens/hash-filterer]
+
+@defproc[(hash-filterer-lens/key [keep? (-> any/c boolean?)])
+         (lens/c immutable-hash? immutable?)]{
+Creates a lens that filters a hash-table to keys that pass the predicate
+@racket[keep?].
+@lens-unstable-examples[
+  (lens-view (hash-filterer-lens/key symbol?) (hash 'a 1 "b" 2 'c 3))
+  (lens-set (hash-filterer-lens/key symbol?) (hash 'a 1 "b" 2 'c 3) (hash 'd 4 'e 5))
+]}
+
+@defproc[(hash-filterer-lens/value [keep? (-> any/c boolean?)])
+         (lens/c immutable-hash? immutable?)]{
+Like @racket[hash-filterer-lens/value], but filters based on values that pass
+@racket[keep?], not keys.
+@lens-unstable-examples[
+  (lens-view (hash-filterer-lens/value number?) (hash 'a 1 'b "two" 'c 3))
+  (lens-set (hash-filterer-lens/value number?) (hash 'a 1 'b "two" 'c 3) (hash 'd 4))
+]}
+
+@defproc[(hash-filterer-lens [keep? (-> any/c any/c boolean?)])
+         (lens/c immutable-hash? immutable?)]{
+Creates a lens that filters a hash-table by the predicate @racket[keep?], which
+takes the key and the value as its two arguments.
+@lens-unstable-examples[
+  (lens-view (hash-filterer-lens =) (hash 1 1.0 2 45 3 3))
+  (lens-set (hash-filterer-lens =) (hash 1 1.0 2 45 3 3) (hash 4 4.0 5.0 5))
+]}
+

unstable/lens/main.rkt

@@ -1,6 +1,7 @@
 #lang reprovide
 "arrow.rkt"
 "dict-nested.rkt"
+"hash-filterer.rkt"
 "if.rkt"
 "isomorphism.rkt"
 "join-assoc.rkt"

unstable/lens/main.scrbl

@@ -14,6 +14,7 @@ this library being backwards-compatible.
 @(include-sections
   "arrow.scrbl"
   "dict-nested.scrbl"
+  "hash-filterer.scrbl"
   "if.scrbl"
   "isomorphism.scrbl"
   "join-assoc.scrbl"