vocabs.hierachy: redo with cleaner API

diff --git a/basis/vocabs/hierarchy/hierarchy-docs.factor b/basis/vocabs/hierarchy/hierarchy-docs.factor
index 3bea36258231f3519059adbfc7795e45906629f1..be719975c139ba19b534cdae42ab4ee53fef6fed 100644 (file)
--- a/basis/vocabs/hierarchy/hierarchy-docs.factor
+++ b/basis/vocabs/hierarchy/hierarchy-docs.factor
@@ -7,19 +7,18 @@ $nl
 "Loading vocabulary hierarchies:"\r
 { $subsection load }\r
 { $subsection load-all }\r
-"Getting all vocabularies on disk:"\r
+"Getting all vocabularies from disk:"\r
 { $subsection all-vocabs }\r
-{ $subsection all-vocabs-seq }\r
-"Getting " { $link "vocabs.metadata" } " for all vocabularies on disk:"\r
+{ $subsection all-vocabs-recursive }\r
+"Getting all vocabularies from disk whose names which match a string prefix:"\r
+{ $subsection child-vocabs }\r
+{ $subsection child-vocabs-recursive }\r
+"Getting " { $link "vocabs.metadata" } " for all vocabularies from disk:"\r
 { $subsection all-tags }\r
 { $subsection all-authors } ;\r
 \r
 ABOUT: "vocabs.hierarchy"\r
 \r
-HELP: all-vocabs\r
-{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }\r
-{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;\r
-\r
 HELP: load\r
 { $values { "prefix" string } }\r
 { $description "Load all vocabularies that match the provided prefix." }\r
@@ -28,6 +27,3 @@ HELP: load
 HELP: load-all\r
 { $description "Load all vocabularies in the source tree." } ;\r
 \r
-HELP: all-vocabs-under\r
-{ $values { "prefix" string } { "vocabs" "a sequence of vocabularies" } }\r
-{ $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." } ;\r

diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor
index 046ccb8c2d9f1687205547113f97d6a08908ed33..6e6dc9cb7e0e490b6dc5604e6c5b2bd5f0ef603d 100644 (file)
--- a/basis/vocabs/hierarchy/hierarchy.factor
+++ b/basis/vocabs/hierarchy/hierarchy.factor
@@ -1,11 +1,18 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.\r
 ! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays assocs combinators.short-circuit fry\r
+USING: accessors arrays assocs combinators.short-circuit fry\r
 io.directories io.files io.files.info io.pathnames kernel make\r
 memoize namespaces sequences sorting splitting vocabs sets\r
 vocabs.loader vocabs.metadata vocabs.errors ;\r
+RENAME: child-vocabs vocabs => vocabs:child-vocabs\r
 IN: vocabs.hierarchy\r
 \r
+TUPLE: vocab-prefix name ;\r
+\r
+C: <vocab-prefix> vocab-prefix\r
+\r
+M: vocab-prefix vocab-name name>> ;\r
+\r
 <PRIVATE\r
 \r
 : vocab-subdirs ( dir -- dirs )\r
@@ -15,74 +22,76 @@ IN: vocabs.hierarchy
         ] filter\r
     ] with-directory-files natural-sort ;\r
 \r
-: (all-child-vocabs) ( root name -- vocabs )\r
-    [\r
-        vocab-dir append-path dup exists?\r
-        [ vocab-subdirs ] [ drop { } ] if\r
-    ] keep\r
-    [ '[ [ _ "." ] dip 3append ] map ] unless-empty ;\r
-\r
 : vocab-dir? ( root name -- ? )\r
     over\r
     [ ".factor" vocab-dir+ append-path exists? ]\r
     [ 2drop f ]\r
     if ;\r
 \r
-: vocabs-in-dir ( root name -- )\r
-    dupd (all-child-vocabs) [\r
-        2dup vocab-dir? [ dup >vocab-link , ] when\r
-        vocabs-in-dir\r
-    ] with each ;\r
+: (child-vocabs) ( root prefix -- vocabs )\r
+    [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]\r
+    [ nip [ '[ [ _ "." ] dip 3append ] map ] unless-empty ]\r
+    [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map ]\r
+    2tri ;\r
 \r
-PRIVATE>\r
+: ((child-vocabs-recursive)) ( root name -- )\r
+    dupd vocab-name (child-vocabs)\r
+    [ dup , ((child-vocabs-recursive)) ] with each ;\r
 \r
-: all-vocabs ( -- assoc )\r
-    vocab-roots get [\r
-        dup [ "" vocabs-in-dir ] { } make\r
-    ] { } map>assoc ;\r
+: (child-vocabs-recursive) ( root name -- seq )\r
+    [ ((child-vocabs-recursive)) ] { } make ;\r
 \r
-: all-vocabs-under ( prefix -- vocabs )\r
-    [\r
-        [ vocab-roots get ] dip '[ _ vocabs-in-dir ] each\r
-    ] { } make ;\r
+: no-rooted ( seq -- seq' ) [ find-vocab-root not ] filter ;\r
 \r
-MEMO: all-vocabs-seq ( -- seq )\r
-    "" all-vocabs-under ;\r
-\r
-<PRIVATE\r
+: one-level-only? ( name prefix -- ? )\r
+    ?head [ "." split1 nip not ] dip and ;\r
 \r
 : unrooted-child-vocabs ( prefix -- seq )\r
+    [ vocabs no-rooted ] dip\r
     dup empty? [ CHAR: . suffix ] unless\r
-    vocabs\r
-    [ find-vocab-root not ] filter\r
-    [\r
-        vocab-name swap ?head CHAR: . rot member? not and\r
-    ] with filter\r
-    [ vocab ] map ;\r
+    '[ vocab-name _ one-level-only? ] filter ;\r
+\r
+: unrooted-child-vocabs-recursive ( prefix -- seq )\r
+    vocabs:child-vocabs no-rooted ;\r
 \r
 PRIVATE>\r
 \r
-: all-child-vocabs ( prefix -- assoc )\r
-    vocab-roots get [\r
-        dup pick (all-child-vocabs) [ >vocab-link ] map\r
-    ] { } map>assoc\r
-    swap unrooted-child-vocabs f swap 2array suffix ;\r
+: no-prefixes ( seq -- seq' ) [ vocab-prefix? not ] filter ;\r
+\r
+: no-roots ( assoc -- seq ) values concat ;\r
 \r
-: all-child-vocabs-seq ( prefix -- assoc )\r
-    vocab-roots get swap '[\r
-        dup _ (all-child-vocabs)\r
-        [ vocab-dir? ] with filter\r
-    ] map concat ;\r
+: child-vocabs ( prefix -- assoc )\r
+    [ [ vocab-roots get ] dip '[ dup _ (child-vocabs) ] { } map>assoc ]\r
+    [ unrooted-child-vocabs [ vocab ] map f swap 2array ]\r
+    bi suffix ;\r
+\r
+: all-vocabs ( -- assoc )\r
+    "" child-vocabs ;\r
+\r
+: child-vocabs-recursive ( prefix -- assoc )\r
+    [ [ vocab-roots get ] dip '[ dup _ (child-vocabs-recursive) ] { } map>assoc ]\r
+    [ unrooted-child-vocabs-recursive [ vocab ] map f swap 2array ]\r
+    bi suffix ;\r
+\r
+MEMO: all-vocabs-recursive ( -- assoc )\r
+    "" child-vocabs-recursive ;\r
+\r
+: all-vocab-names ( -- seq )\r
+    all-vocabs-recursive no-roots no-prefixes [ vocab-name ] map ;\r
 \r
 <PRIVATE\r
 \r
 : filter-unportable ( seq -- seq' )\r
     [ vocab-name unportable? not ] filter ;\r
 \r
+: collect-vocabs ( quot -- seq )\r
+    [ all-vocabs-recursive no-roots no-prefixes ] dip\r
+    gather natural-sort ; inline\r
+\r
 PRIVATE>\r
 \r
 : (load) ( prefix -- failures )\r
-    all-vocabs-under\r
+    child-vocabs-recursive\r
     filter-unportable\r
     require-all ;\r
 \r
@@ -92,8 +101,6 @@ PRIVATE>
 : load-all ( -- )\r
     "" load ;\r
 \r
-MEMO: all-tags ( -- seq )\r
-    all-vocabs-seq [ vocab-tags ] gather natural-sort ;\r
+MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;\r
 \r
-MEMO: all-authors ( -- seq )\r
-    all-vocabs-seq [ vocab-authors ] gather natural-sort ;
\ No newline at end of file
+MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;\r