1 ! Copyright (C) 2007, 2009 Slava Pestov.
\r
2 ! See http://factorcode.org/license.txt for BSD license.
\r
3 USING: accessors arrays assocs combinators.short-circuit fry
\r
4 io.directories io.files io.files.info io.pathnames kernel make
\r
5 memoize namespaces sequences sorting splitting vocabs sets
\r
6 vocabs.loader vocabs.metadata vocabs.errors ;
\r
7 RENAME: child-vocabs vocabs => vocabs:child-vocabs
\r
10 TUPLE: vocab-prefix name ;
\r
12 C: <vocab-prefix> vocab-prefix
\r
14 M: vocab-prefix vocab-name name>> ;
\r
18 : vocab-subdirs ( dir -- dirs )
\r
21 { [ link-info directory? ] [ "." head? not ] } 1&&
\r
23 ] with-directory-files natural-sort ;
\r
25 : vocab-dir? ( root name -- ? )
\r
27 [ ".factor" vocab-dir+ append-path exists? ]
\r
31 : (child-vocabs) ( root prefix -- vocabs )
\r
32 [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]
\r
33 [ nip [ '[ [ _ "." ] dip 3append ] map ] unless-empty ]
\r
34 [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map ]
\r
37 : ((child-vocabs-recursive)) ( root name -- )
\r
38 dupd vocab-name (child-vocabs)
\r
39 [ dup , ((child-vocabs-recursive)) ] with each ;
\r
41 : (child-vocabs-recursive) ( root name -- seq )
\r
42 [ ((child-vocabs-recursive)) ] { } make ;
\r
44 : no-rooted ( seq -- seq' ) [ find-vocab-root not ] filter ;
\r
46 : one-level-only? ( name prefix -- ? )
\r
47 ?head [ "." split1 nip not ] dip and ;
\r
49 : unrooted-child-vocabs ( prefix -- seq )
\r
50 [ vocabs no-rooted ] dip
\r
51 dup empty? [ CHAR: . suffix ] unless
\r
52 '[ vocab-name _ one-level-only? ] filter ;
\r
54 : unrooted-child-vocabs-recursive ( prefix -- seq )
\r
55 vocabs:child-vocabs no-rooted ;
\r
59 : no-prefixes ( seq -- seq' ) [ vocab-prefix? not ] filter ;
\r
61 : convert-prefixes ( seq -- seq' )
\r
62 [ dup vocab-prefix? [ name>> vocab-link boa ] when ] map ;
\r
64 : remove-redundant-prefixes ( seq -- seq' )
\r
66 [ vocab-prefix? ] partition
\r
68 [ vocab-name ] map unique
\r
69 '[ name>> _ key? not ] filter
\r
74 : no-roots ( assoc -- seq ) values concat ;
\r
76 : child-vocabs ( prefix -- assoc )
\r
77 [ [ vocab-roots get ] dip '[ dup _ (child-vocabs) ] { } map>assoc ]
\r
78 [ unrooted-child-vocabs [ vocab ] map f swap 2array ]
\r
81 : all-vocabs ( -- assoc )
\r
84 : child-vocabs-recursive ( prefix -- assoc )
\r
85 [ [ vocab-roots get ] dip '[ dup _ (child-vocabs-recursive) ] { } map>assoc ]
\r
86 [ unrooted-child-vocabs-recursive [ vocab ] map f swap 2array ]
\r
89 MEMO: all-vocabs-recursive ( -- assoc )
\r
90 "" child-vocabs-recursive ;
\r
92 : all-vocab-names ( -- seq )
\r
93 all-vocabs-recursive no-roots no-prefixes [ vocab-name ] map ;
\r
95 : child-vocab-names ( prefix -- seq )
\r
96 child-vocabs no-roots no-prefixes [ vocab-name ] map ;
\r
100 : filter-unportable ( seq -- seq' )
\r
101 [ vocab-name unportable? not ] filter ;
\r
103 : collect-vocabs ( quot -- seq )
\r
104 [ all-vocabs-recursive no-roots no-prefixes ] dip
\r
105 gather natural-sort ; inline
\r
109 : (load) ( prefix -- failures )
\r
110 [ child-vocabs-recursive no-roots no-prefixes ]
\r
111 [ dup find-vocab-root [ >vocab-link prefix ] [ drop ] if ] bi
\r
115 : load ( prefix -- )
\r
116 (load) load-failures. ;
\r
121 MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;
\r
123 MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;
\r