From 27f445d505152fcab4e689977c60cdde2f2e2fa9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 23 Aug 2012 22:36:10 -0700 Subject: [PATCH] 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 | 2 +- basis/io/encodings/shift-jis/shift-jis.factor | 2 +- basis/math/partial-dispatch/partial-dispatch.factor | 2 +- basis/regexp/classes/classes.factor | 3 +-- basis/tools/deploy/shaker/shaker.factor | 4 +--- basis/ui/commands/commands.factor | 2 +- basis/xml/syntax/syntax.factor | 5 +---- core/assocs/assocs-docs.factor | 13 +++++++++++++ core/assocs/assocs-tests.factor | 13 +++++++++++++ core/assocs/assocs.factor | 6 ++++++ extra/assocs/extras/extras.factor | 3 --- 11 files changed, 39 insertions(+), 16 deletions(-) diff --git a/basis/compiler/tree/combinators/combinators.factor b/basis/compiler/tree/combinators/combinators.factor index 596cf7fd20..8b095e9ab5 100644 --- 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 879adbc338..0d130d9da6 100644 --- 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 57f2a62309..cb719eb24a 100644 --- 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 d9eb05acc3..ab4a102eae 100644 --- a/basis/regexp/classes/classes.factor +++ b/basis/regexp/classes/classes.factor @@ -300,8 +300,7 @@ M: object substitute answer ; M: not-class substitute [ ] 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 1573a20484..75a8f6cbe1 100755 --- 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 1580f3fa13..5ff99e658d 100644 --- 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 ca196ac7ad..8738bef20b 100644 --- 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 ] dip ] + '[ @ _ swap [ narray sift-values ] dip ] ] when-interpolated ; : interpolate-tag ( tag -- quot ) diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 43ac635666..9212d6a363 100644 --- 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 50fbf9a7ff..bb91c79928 100644 --- 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 0f327b17df..0c9f8c1c83 100644 --- 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 3019a5e86a..6193c24ba6 100644 --- 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 -- 2.34.1