From 5484bd3241dc437b1f4deced474cd9a7c2a70f13 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.local>
Date: Mon, 6 Jul 2009 04:23:26 -0500
Subject: [PATCH] vocabs.hierachy: redo with cleaner API

---
 basis/vocabs/hierarchy/hierarchy-docs.factor |  16 ++-
 basis/vocabs/hierarchy/hierarchy.factor      | 101 ++++++++++---------
 2 files changed, 60 insertions(+), 57 deletions(-)

diff --git a/basis/vocabs/hierarchy/hierarchy-docs.factor b/basis/vocabs/hierarchy/hierarchy-docs.factor
index 3bea362582..be719975c1 100644
--- a/basis/vocabs/hierarchy/hierarchy-docs.factor
+++ b/basis/vocabs/hierarchy/hierarchy-docs.factor
@@ -7,19 +7,18 @@ $nl
 "Loading vocabulary hierarchies:"
 { $subsection load }
 { $subsection load-all }
-"Getting all vocabularies on disk:"
+"Getting all vocabularies from disk:"
 { $subsection all-vocabs }
-{ $subsection all-vocabs-seq }
-"Getting " { $link "vocabs.metadata" } " for all vocabularies on disk:"
+{ $subsection all-vocabs-recursive }
+"Getting all vocabularies from disk whose names which match a string prefix:"
+{ $subsection child-vocabs }
+{ $subsection child-vocabs-recursive }
+"Getting " { $link "vocabs.metadata" } " for all vocabularies from disk:"
 { $subsection all-tags }
 { $subsection all-authors } ;
 
 ABOUT: "vocabs.hierarchy"
 
-HELP: all-vocabs
-{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }
-{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;
-
 HELP: load
 { $values { "prefix" string } }
 { $description "Load all vocabularies that match the provided prefix." }
@@ -28,6 +27,3 @@ HELP: load
 HELP: load-all
 { $description "Load all vocabularies in the source tree." } ;
 
-HELP: all-vocabs-under
-{ $values { "prefix" string } { "vocabs" "a sequence of vocabularies" } }
-{ $description "Return a sequence of vocab or vocab-links for each vocab matching the provided prefix. Unlike " { $link all-child-vocabs } " this word will return both loaded and unloaded vocabularies." } ;
diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor
index 046ccb8c2d..6e6dc9cb7e 100644
--- a/basis/vocabs/hierarchy/hierarchy.factor
+++ b/basis/vocabs/hierarchy/hierarchy.factor
@@ -1,11 +1,18 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs combinators.short-circuit fry
+USING: accessors arrays assocs combinators.short-circuit fry
 io.directories io.files io.files.info io.pathnames kernel make
 memoize namespaces sequences sorting splitting vocabs sets
 vocabs.loader vocabs.metadata vocabs.errors ;
+RENAME: child-vocabs vocabs => vocabs:child-vocabs
 IN: vocabs.hierarchy
 
+TUPLE: vocab-prefix name ;
+
+C: <vocab-prefix> vocab-prefix
+
+M: vocab-prefix vocab-name name>> ;
+
 <PRIVATE
 
 : vocab-subdirs ( dir -- dirs )
@@ -15,74 +22,76 @@ IN: vocabs.hierarchy
         ] filter
     ] with-directory-files natural-sort ;
 
-: (all-child-vocabs) ( root name -- vocabs )
-    [
-        vocab-dir append-path dup exists?
-        [ vocab-subdirs ] [ drop { } ] if
-    ] keep
-    [ '[ [ _ "." ] dip 3append ] map ] unless-empty ;
-
 : vocab-dir? ( root name -- ? )
     over
     [ ".factor" vocab-dir+ append-path exists? ]
     [ 2drop f ]
     if ;
 
-: vocabs-in-dir ( root name -- )
-    dupd (all-child-vocabs) [
-        2dup vocab-dir? [ dup >vocab-link , ] when
-        vocabs-in-dir
-    ] with each ;
+: (child-vocabs) ( root prefix -- vocabs )
+    [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]
+    [ nip [ '[ [ _ "." ] dip 3append ] map ] unless-empty ]
+    [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map ]
+    2tri ;
 
-PRIVATE>
+: ((child-vocabs-recursive)) ( root name -- )
+    dupd vocab-name (child-vocabs)
+    [ dup , ((child-vocabs-recursive)) ] with each ;
 
-: all-vocabs ( -- assoc )
-    vocab-roots get [
-        dup [ "" vocabs-in-dir ] { } make
-    ] { } map>assoc ;
+: (child-vocabs-recursive) ( root name -- seq )
+    [ ((child-vocabs-recursive)) ] { } make ;
 
-: all-vocabs-under ( prefix -- vocabs )
-    [
-        [ vocab-roots get ] dip '[ _ vocabs-in-dir ] each
-    ] { } make ;
+: no-rooted ( seq -- seq' ) [ find-vocab-root not ] filter ;
 
-MEMO: all-vocabs-seq ( -- seq )
-    "" all-vocabs-under ;
-
-<PRIVATE
+: one-level-only? ( name prefix -- ? )
+    ?head [ "." split1 nip not ] dip and ;
 
 : unrooted-child-vocabs ( prefix -- seq )
+    [ vocabs no-rooted ] dip
     dup empty? [ CHAR: . suffix ] unless
-    vocabs
-    [ find-vocab-root not ] filter
-    [
-        vocab-name swap ?head CHAR: . rot member? not and
-    ] with filter
-    [ vocab ] map ;
+    '[ vocab-name _ one-level-only? ] filter ;
+
+: unrooted-child-vocabs-recursive ( prefix -- seq )
+    vocabs:child-vocabs no-rooted ;
 
 PRIVATE>
 
-: all-child-vocabs ( prefix -- assoc )
-    vocab-roots get [
-        dup pick (all-child-vocabs) [ >vocab-link ] map
-    ] { } map>assoc
-    swap unrooted-child-vocabs f swap 2array suffix ;
+: no-prefixes ( seq -- seq' ) [ vocab-prefix? not ] filter ;
 
-: all-child-vocabs-seq ( prefix -- assoc )
-    vocab-roots get swap '[
-        dup _ (all-child-vocabs)
-        [ vocab-dir? ] with filter
-    ] map concat ;
+: no-roots ( assoc -- seq ) values concat ;
+
+: child-vocabs ( prefix -- assoc )
+    [ [ vocab-roots get ] dip '[ dup _ (child-vocabs) ] { } map>assoc ]
+    [ unrooted-child-vocabs [ vocab ] map f swap 2array ]
+    bi suffix ;
+
+: all-vocabs ( -- assoc )
+    "" child-vocabs ;
+
+: child-vocabs-recursive ( prefix -- assoc )
+    [ [ vocab-roots get ] dip '[ dup _ (child-vocabs-recursive) ] { } map>assoc ]
+    [ unrooted-child-vocabs-recursive [ vocab ] map f swap 2array ]
+    bi suffix ;
+
+MEMO: all-vocabs-recursive ( -- assoc )
+    "" child-vocabs-recursive ;
+
+: all-vocab-names ( -- seq )
+    all-vocabs-recursive no-roots no-prefixes [ vocab-name ] map ;
 
 <PRIVATE
 
 : filter-unportable ( seq -- seq' )
     [ vocab-name unportable? not ] filter ;
 
+: collect-vocabs ( quot -- seq )
+    [ all-vocabs-recursive no-roots no-prefixes ] dip
+    gather natural-sort ; inline
+
 PRIVATE>
 
 : (load) ( prefix -- failures )
-    all-vocabs-under
+    child-vocabs-recursive
     filter-unportable
     require-all ;
 
@@ -92,8 +101,6 @@ PRIVATE>
 : load-all ( -- )
     "" load ;
 
-MEMO: all-tags ( -- seq )
-    all-vocabs-seq [ vocab-tags ] gather natural-sort ;
+MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;
 
-MEMO: all-authors ( -- seq )
-    all-vocabs-seq [ vocab-authors ] gather natural-sort ;
\ No newline at end of file
+MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;