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

of sift-values and use the new one.

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

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

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 % ;

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
+    '[ _ _ substitute ] assoc-map sift-values ;
-    [ nip ] assoc-filter ;
 
 : assoc-answers ( table questions answer -- new-table )
     '[ _ assoc-answer ] each ;

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 ;

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 ;

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 )

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." }

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

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

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