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.types 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 : visible-dirs ( seq -- seq' )
\r
21 [ type>> +directory+ = ]
\r
22 [ name>> "." head? not ]
\r
26 : vocab-subdirs ( dir -- dirs )
\r
27 directory-entries visible-dirs [ name>> ] map! natural-sort ;
\r
29 : vocab-dir? ( root name -- ? )
\r
31 [ ".factor" append-vocab-dir append-path exists? ]
\r
35 ERROR: vocab-root-required root ;
\r
37 : ensure-vocab-root ( root -- root )
\r
38 dup vocab-roots get member? [ vocab-root-required ] unless ;
\r
40 : ensure-vocab-root/prefix ( root prefix -- root prefix )
\r
41 [ ensure-vocab-root ] [ check-vocab-name ] bi* ;
\r
43 : (child-vocabs) ( root prefix -- vocabs )
\r
45 [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]
\r
46 [ nip [ "." append '[ _ prepend ] map! ] unless-empty ]
\r
47 [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map! ]
\r
50 : ((child-vocabs-recursive)) ( root prefix -- )
\r
51 dupd vocab-name (child-vocabs) [ % ] keep
\r
52 [ ((child-vocabs-recursive)) ] with each ;
\r
54 : (child-vocabs-recursive) ( root prefix -- seq )
\r
55 [ ensure-vocab-root ] dip
\r
56 [ ((child-vocabs-recursive)) ] { } make ;
\r
58 : no-rooted ( seq -- seq' ) [ find-vocab-root not ] filter ;
\r
60 : one-level-only? ( name prefix -- ? )
\r
61 ?head [ "." split1 nip not ] [ drop f ] if ;
\r
63 : unrooted-child-vocabs ( prefix -- seq )
\r
64 [ vocabs no-rooted ] dip
\r
65 dup empty? [ CHAR: . suffix ] unless
\r
66 '[ vocab-name _ one-level-only? ] filter ;
\r
68 : unrooted-child-vocabs-recursive ( prefix -- seq )
\r
69 vocabs:child-vocabs no-rooted ;
\r
73 : no-prefixes ( seq -- seq' ) [ vocab-prefix? not ] filter ;
\r
75 : convert-prefixes ( seq -- seq' )
\r
76 [ dup vocab-prefix? [ name>> <vocab-link> ] when ] map ;
\r
78 : remove-redundant-prefixes ( seq -- seq' )
\r
80 [ vocab-prefix? ] partition
\r
82 [ vocab-name ] map fast-set
\r
83 '[ name>> _ in? not ] filter
\r
88 : no-roots ( assoc -- seq ) values concat ;
\r
90 : filter-vocabs ( assoc -- seq )
\r
91 no-roots no-prefixes members ;
\r
93 : child-vocabs ( prefix -- assoc )
\r
94 [ [ vocab-roots get ] dip '[ dup _ (child-vocabs) ] { } map>assoc ]
\r
95 [ unrooted-child-vocabs [ lookup-vocab ] map! f swap 2array ]
\r
98 : all-vocabs ( -- assoc )
\r
101 : child-vocabs-recursive ( prefix -- assoc )
\r
102 [ [ vocab-roots get ] dip '[ dup _ (child-vocabs-recursive) ] { } map>assoc ]
\r
103 [ unrooted-child-vocabs-recursive [ lookup-vocab ] map! f swap 2array ]
\r
106 MEMO: all-vocabs-recursive ( -- assoc )
\r
107 "" child-vocabs-recursive ;
\r
109 : all-vocab-names ( -- seq )
\r
110 all-vocabs-recursive filter-vocabs [ vocab-name ] map! ;
\r
112 : child-vocab-names ( prefix -- seq )
\r
113 child-vocabs filter-vocabs [ vocab-name ] map! ;
\r
117 : collect-vocabs ( quot -- seq )
\r
118 [ all-vocabs-recursive filter-vocabs ] dip
\r
119 gather natural-sort ; inline
\r
121 : maybe-include-root/prefix ( root prefix -- vocab-link/f )
\r
123 [ find-vocab-root = ] keep swap
\r
125 nip dup find-vocab-root
\r
126 ] if [ >vocab-link ] [ drop f ] if ;
\r
130 : vocabs-in-root/prefix ( root prefix -- seq )
\r
131 [ (child-vocabs-recursive) ]
\r
132 [ maybe-include-root/prefix [ prefix ] when* ] 2bi ;
\r
134 : vocabs-in-root ( root -- seq )
\r
135 "" vocabs-in-root/prefix ;
\r
137 : (load-from-root) ( root prefix -- failures )
\r
138 vocabs-in-root/prefix
\r
139 [ don't-load? not ] filter no-prefixes
\r
142 : load-from-root ( root prefix -- )
\r
143 (load-from-root) load-failures. ;
\r
145 : load-root ( root -- )
\r
146 "" load-from-root ;
\r
148 : (load) ( prefix -- failures )
\r
149 [ vocab-roots get ] dip '[ _ (load-from-root) ] map concat ;
\r
151 : load ( prefix -- )
\r
152 (load) load-failures. ;
\r
157 MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;
\r
159 MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;
\r