vocabs.hierachy: redo with cleaner API

db4
Slava Pestov 2009-07-06 04:23:26 -05:00
parent 6aaad1ea9f
commit 5484bd3241
2 changed files with 60 additions and 57 deletions

View File

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

View File

@ -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 ;
MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;