From 434f08a3033f03d4bb1ac9157e51824de1b010b5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 8 Aug 2015 11:58:40 -0500
Subject: [PATCH] assocs: Add harvest-keys, harvest-values to core/. Remove
 assoc-sift because it's sift-keys, sift-values in core/.

---
 core/assocs/assocs-docs.factor    | 37 +++++++++++++++++++++++++++++--
 core/assocs/assocs-tests.factor   | 22 ++++++++++++++++++
 core/assocs/assocs.factor         |  6 +++++
 extra/assocs/extras/extras.factor |  6 -----
 4 files changed, 63 insertions(+), 8 deletions(-)

diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor
index 96300ac86d..00c9847914 100644
--- a/core/assocs/assocs-docs.factor
+++ b/core/assocs/assocs-docs.factor
@@ -161,6 +161,8 @@ $nl
 { $subsections
     sift-keys
     sift-values
+    harvest-keys
+    harvest-values
 }
 "Mapping between assocs and sequences:"
 { $subsections
@@ -343,11 +345,42 @@ HELP: assoc-subset?
 
 HELP: sift-keys
 { $values { "assoc" assoc } { "assoc'" "a new assoc" } }
-{ $description "Outputs an assoc removing keys that are " { $link f } "." } ;
+{ $description "Outputs an assoc removing keys that are " { $link f } "." }
+{ $examples
+    { $example "USING: prettyprint assocs hashtables ;"
+        "H{ { 1 2 } { f 3 } } sift-keys ."
+        "H{ { 1 2 } }" }
+} ;
 
 HELP: sift-values
 { $values { "assoc" assoc } { "assoc'" "a new assoc" } }
-{ $description "Outputs an assoc removing values that are " { $link f } "." } ;
+{ $description "Outputs an assoc removing values that are " { $link f } "." }
+{ $examples
+    { $example "USING: prettyprint assocs hashtables ;"
+        "H{ { 1 f } { 3 4 } } sift-values ."
+        "H{ { 3 4 } }" }
+} ;
+
+{ sift-keys sift-values harvest-keys harvest-values } related-words
+
+HELP: harvest-keys
+{ $values { "assoc" assoc } { "assoc'" "a new assoc" } }
+{ $description "Outputs an assoc removing keys that are empty sequences." }
+{ $examples
+    { $example "USING: prettyprint assocs hashtables ;"
+        "H{ { { 2 } 1 } { { } 3 } } harvest-keys ."
+        "H{ { { 2 } 1 } }" }
+} ;
+
+HELP: harvest-values
+{ $values { "assoc" assoc } { "assoc'" "a new assoc" } }
+{ $description "Outputs an assoc removing values that are empty sequences." }
+{ $examples
+    { $example "USING: prettyprint assocs hashtables ;"
+        "H{ { 1 { } } { 3 { 4 } } } harvest-values ."
+        "H{ { 3 { 4 } } }" }
+} ;
+
 
 HELP: assoc=
 { $values { "assoc1" assoc } { "assoc2" assoc } { "?" boolean } }
diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor
index 6e715a3248..f780adbca2 100644
--- a/core/assocs/assocs-tests.factor
+++ b/core/assocs/assocs-tests.factor
@@ -217,6 +217,28 @@ unit-test
     { { 1 f } { f 2 } } sift-keys
 ] unit-test
 
+{
+    {
+        { { 2 } 1 }
+    }
+} [
+    {
+        { { 2 } 1 }
+        { { } 3 }
+    } harvest-keys
+] unit-test
+
+{
+    {
+        { 1 { 2 } }
+    }
+} [
+    {
+        { 1 { 2 } }
+        { 3 { } }
+    } harvest-values
+] unit-test
+
 {
     { { f 2 } }
 } [
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index ef61ab0bbb..8294c8c83c 100644
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -95,6 +95,12 @@ PRIVATE>
 : sift-values ( assoc -- assoc' )
     [ nip ] assoc-filter ; inline
 
+: harvest-keys ( assoc -- assoc' )
+    [ drop empty? ] assoc-reject ; inline
+
+: harvest-values ( assoc -- assoc' )
+    [ nip empty? ] assoc-reject ; 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 a145599605..cf63ee8472 100644
--- a/extra/assocs/extras/extras.factor
+++ b/extra/assocs/extras/extras.factor
@@ -5,12 +5,6 @@ USING: arrays assocs assocs.private kernel math sequences ;
 
 IN: assocs.extras
 
-: assoc-sift ( assoc -- assoc' )
-    [ nip ] assoc-filter ; inline
-
-: assoc-harvest ( assoc -- assoc' )
-    [ nip empty? ] assoc-reject ; inline
-
 : deep-at ( assoc seq -- value/f )
     [ of ] each ; inline
 
-- 
2.34.1