assocs: Add sift-keys and sift-values. Remove three other implementations

of sift-values and use the new one.

diff --git a/basis/compiler/tree/combinators/combinators.factor b/basis/compiler/tree/combinators/combinators.factor
index 596cf7fd20076c8771281faedb09a5538d3cbd16..8b095e9ab50f863b77c9d520f62029d6b46a5e34 100644 (file)
--- a/basis/compiler/tree/combinators/combinators.factor
+++ b/basis/compiler/tree/combinators/combinators.factor
@@ -48,7 +48,7 @@ IN: compiler.tree.combinators
     [ [ drop f ] unless ] 2map ;
 
 : sift-children ( seq flags -- seq' )
-    zip [ nip ] assoc-filter keys ;
+    zip sift-values keys ;
 
 : until-fixed-point ( ... #recursive quot: ( ... node -- ... ) -- ... )
     over label>> t >>fixed-point drop

diff --git a/basis/io/encodings/shift-jis/shift-jis.factor b/basis/io/encodings/shift-jis/shift-jis.factor
index 879adbc33838384c73b9f5c8d75a056748f6e7d7..0d130d9da60fec0a2a61759d919ffa0fdc4d54f0 100644 (file)
--- a/basis/io/encodings/shift-jis/shift-jis.factor
+++ b/basis/io/encodings/shift-jis/shift-jis.factor
@@ -33,7 +33,7 @@ TUPLE: jis assoc ;
 : jis>ch ( jis tuple -- string ) assoc>> at replacement-char or ;
 
 : make-jis ( filename -- jis )
-    flat-file>biassoc [ nip ] assoc-filter jis boa ;
+    flat-file>biassoc sift-values jis boa ;
 
 "vocab:io/encodings/shift-jis/CP932.txt"
 make-jis windows-31j-table set-global

diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor
index 57f2a62309a566c2a65202e5e6a166b0d8bc20cf..cb719eb24adfbe3d4717c4953edad7314fdbd664 100644 (file)
--- a/basis/math/partial-dispatch/partial-dispatch.factor
+++ b/basis/math/partial-dispatch/partial-dispatch.factor
@@ -129,7 +129,7 @@ M: word integer-op-input-classes
 : define-math-ops ( op -- )
     { fixnum bignum float }
     [ [ dup 3array ] [ swap ?lookup-method ] 2bi ] with { } map>assoc
-    [ nip ] assoc-filter
+    sift-values
     [ def>> ] assoc-map
     [ nip length 1 = ] assoc-filter
     [ first ] assoc-map % ;

diff --git a/basis/regexp/classes/classes.factor b/basis/regexp/classes/classes.factor
index d9eb05acc351a314a9af1865cdbe67aea64b1602..ab4a102eaea5a9163037f33b84c43f563719eb55 100644 (file)
--- a/basis/regexp/classes/classes.factor
+++ b/basis/regexp/classes/classes.factor
@@ -300,8 +300,7 @@ M: object substitute answer ;
 M: not-class substitute [ <not-class> ] bi@ answer ;
 
 : assoc-answer ( table question answer -- new-table )
-    '[ _ _ substitute ] assoc-map
-    [ nip ] assoc-filter ;
+    '[ _ _ substitute ] assoc-map sift-values ;
 
 : assoc-answers ( table questions answer -- new-table )
     '[ _ assoc-answer ] each ;

diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index 1573a204842cf53a54aaa1bff4160e04180a3e32..75a8f6cbe19231686cc75b3ecab4ce4accfe1f94 100755 (executable)
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -125,13 +125,11 @@ IN: tools.deploy.shaker
     [ "no-def-strip" word-prop not ] filter
     [ [ ] >>def drop ] each ;
 
-: sift-assoc ( assoc -- assoc' ) [ nip ] assoc-filter ;
-
 : strip-word-props ( stripped-props words -- )
     "Stripping word properties" show
     swap '[
         [
-            [ drop _ member? not ] assoc-filter sift-assoc
+            [ drop _ member? not ] assoc-filter sift-values
             >alist f like
         ] change-props drop
     ] each ;

diff --git a/basis/ui/commands/commands.factor b/basis/ui/commands/commands.factor
index 1580f3fa13b4233c047b300b59150290ab43e316..5ff99e658db390bc0850b37c7dadbf7f7a95b4c7 100644 (file)
--- a/basis/ui/commands/commands.factor
+++ b/basis/ui/commands/commands.factor
@@ -36,7 +36,7 @@ GENERIC: command-word ( command -- word )
     commands values [
         [
             commands>>
-            [ drop ] assoc-filter
+            sift-keys
             [ '[ _ invoke-command ] swap ,, ] assoc-each
         ] each
     ] H{ } make ;

diff --git a/basis/xml/syntax/syntax.factor b/basis/xml/syntax/syntax.factor
index ca196ac7ad5d2ff9be3d84a635ed358c3e1023a7..8738bef20b69011235a5d592430fe2384e593ddd 100644 (file)
--- a/basis/xml/syntax/syntax.factor
+++ b/basis/xml/syntax/syntax.factor
@@ -82,14 +82,11 @@ DEFER: interpolate-sequence
     [ get-interpolated '[ _ swap @ [ ?present 2array ] dip ] ]
     [ 2array '[ _ swap ] ] if ;
 
-: filter-nulls ( assoc -- newassoc )
-    [ nip ] assoc-filter ;
-
 : interpolate-attrs ( attrs -- quot )
     [
         [ [ interpolate-attr ] { } assoc>map [ ] join ]
         [ assoc-size ] bi
-        '[ @ _ swap [ narray filter-nulls <attrs> ] dip ]
+        '[ @ _ swap [ narray sift-values <attrs> ] dip ]
     ] when-interpolated ;
 
 : interpolate-tag ( tag -- quot )

diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor
index 43ac635666abd0b9c2b3cdeb9b4d7db3399fa092..9212d6a363a111301b2adb9b7b8636dacdf6f291 100644 (file)
--- a/core/assocs/assocs-docs.factor
+++ b/core/assocs/assocs-docs.factor
@@ -151,6 +151,11 @@ $nl
     assoc-any?
     assoc-all?
 }
+"Removing empty keys or values:"
+{ $subsections
+    sift-keys
+    sift-values
+}
 "Mapping between assocs and sequences:"
 { $subsections
     map>assoc
@@ -306,6 +311,14 @@ HELP: assoc-subset?
 { $values { "assoc1" assoc } { "assoc2" assoc } { "?" boolean } }
 { $description "Tests if " { $snippet "assoc2" } " contains all key/value pairs of " { $snippet "assoc1" } "." } ;
 
+HELP: sift-keys
+{ $values { "assoc" assoc } { "assoc'" "a new assoc" } }
+{ $description "Outputs an assoc removing keys that are " { $link f } "." } ;
+
+HELP: sift-values
+{ $values { "assoc" assoc } { "assoc'" "a new assoc" } }
+{ $description "Outputs an assoc removing values that are " { $link f } "." } ;
+
 HELP: assoc=
 { $values { "assoc1" assoc } { "assoc2" assoc } { "?" boolean } }
 { $description "Tests if two assocs contain the same entries. Unlike " { $link = } ", the two assocs may be of different types." }

diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor
index 50fbf9a7ffe564700cde2c3ec127466b3a35506d..bb91c79928f354370c0108af78d9844462a6508a 100644 (file)
--- a/core/assocs/assocs-tests.factor
+++ b/core/assocs/assocs-tests.factor
@@ -199,3 +199,16 @@ unit-test
 [ 1 ] [ "a" { H{ { "a" 1 } } H{ { "b" 2 } } } assoc-stack ] unit-test
 [ 2 ] [ "b" { H{ { "a" 1 } } H{ { "b" 2 } } } assoc-stack ] unit-test
 [ f ] [ "c" { H{ { "a" 1 } } H{ { "b" 2 } } } assoc-stack ] unit-test
+
+
+{
+    { { 1 f } }
+} [
+    { { 1 f } { f 2 } } sift-keys
+] unit-test
+
+{
+    { { f 2 } }
+} [
+    { { 1 f } { f 2 } } sift-values
+] unit-test
\ No newline at end of file

diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index 0f327b17df0b553ed7df98bd28b0ef9ee364cd88..0c9f8c1c8376eedcaca75a7186a025877cb140ca 100644 (file)
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -78,6 +78,12 @@ PRIVATE>
         assoc-each
     ] [ drop ] 2bi ; inline
 
+: sift-keys ( assoc -- assoc' )
+    [ drop ] assoc-filter ; inline
+
+: sift-values ( assoc -- assoc' )
+    [ nip ] assoc-filter ; inline
+
 : assoc-partition ( ... assoc quot: ( ... key value -- ... ? ) -- ... true-assoc false-assoc )
     [ (assoc-each) partition ] [ drop ] 2bi
     [ assoc-like ] curry bi@ ; inline

diff --git a/extra/assocs/extras/extras.factor b/extra/assocs/extras/extras.factor
index 3019a5e86a4a413c67074f01715f00aebe092a6e..6193c24ba650421d0d6c0d964945189a6fa3afe5 100644 (file)
--- a/extra/assocs/extras/extras.factor
+++ b/extra/assocs/extras/extras.factor
@@ -8,9 +8,6 @@ IN: assocs.extras
 : assoc-harvest ( assoc -- assoc' )
     [ nip empty? not ] assoc-filter ; inline
 
-: assoc-sift ( assoc -- assoc' )
-    [ nip ] assoc-filter ; inline
-
 : deep-at ( assoc seq -- value/f )
     [ swap at ] each ; inline