1 ! Copyright (C) 2007, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators.short-circuit fry
4 io.directories io.files io.files.info io.pathnames kernel make
5 memoize namespaces sequences sets sorting splitting vocabs
6 vocabs.loader vocabs.metadata ;
9 TUPLE: vocab-prefix name ;
11 C: <vocab-prefix> vocab-prefix
13 M: vocab-prefix vocab-name name>> ;
17 : visible-dirs ( seq -- seq' )
21 [ name>> "." head? not ]
25 : vocab-subdirs ( dir -- dirs )
26 directory-entries visible-dirs [ name>> ] map! natural-sort ;
28 : vocab-dir? ( root name -- ? )
30 [ ".factor" append-vocab-dir append-path exists? ]
34 ERROR: vocab-root-required root ;
36 : ensure-vocab-root ( root -- root )
37 dup vocab-roots get member? [ throw-vocab-root-required ] unless ;
39 : ensure-vocab-root/prefix ( root prefix -- root prefix )
40 [ ensure-vocab-root ] [ check-vocab-name ] bi* ;
42 : (disk-vocab-children) ( root prefix -- vocabs )
44 [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]
45 [ nip [ "." append '[ _ prepend ] map! ] unless-empty ]
46 [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map! ]
49 : ((disk-vocabs-recursive)) ( root prefix -- )
50 dupd vocab-name (disk-vocab-children) [ % ] keep
51 [ ((disk-vocabs-recursive)) ] with each ;
53 : (disk-vocabs-recursive) ( root prefix -- seq )
54 [ ensure-vocab-root ] dip
55 [ ((disk-vocabs-recursive)) ] { } make ;
57 : no-rooted ( seq -- seq' ) [ find-vocab-root ] reject ;
59 : one-level-only? ( name prefix -- ? )
60 ?head [ "." split1 nip not ] [ drop f ] if ;
62 : unrooted-disk-vocabs ( prefix -- seq )
63 [ loaded-vocab-names no-rooted ] dip
64 dup empty? [ CHAR: . suffix ] unless
65 '[ vocab-name _ one-level-only? ] filter ;
67 : unrooted-disk-vocabs-recursive ( prefix -- seq )
68 loaded-child-vocab-names no-rooted ;
72 : no-prefixes ( seq -- seq' ) [ vocab-prefix? ] reject ;
74 : convert-prefixes ( seq -- seq' )
75 [ dup vocab-prefix? [ name>> <vocab-link> ] when ] map ;
77 : remove-redundant-prefixes ( seq -- seq' )
79 [ vocab-prefix? ] partition
81 [ vocab-name ] map fast-set
82 '[ name>> _ in? ] reject
87 : no-roots ( assoc -- seq ) values concat ;
89 : filter-vocabs ( assoc -- seq )
90 no-roots no-prefixes members ;
92 : disk-vocabs-for-prefix ( prefix -- assoc )
93 [ [ vocab-roots get ] dip '[ dup _ (disk-vocab-children) ] { } map>assoc ]
94 [ unrooted-disk-vocabs [ lookup-vocab ] map! f swap 2array ]
97 : all-disk-vocabs-by-root ( -- assoc )
98 "" disk-vocabs-for-prefix ;
100 : disk-vocabs-recursive-for-prefix ( prefix -- assoc )
101 [ [ vocab-roots get ] dip '[ dup _ (disk-vocabs-recursive) ] { } map>assoc ]
102 [ unrooted-disk-vocabs-recursive [ lookup-vocab ] map! f swap 2array ]
105 MEMO: all-disk-vocabs-recursive ( -- assoc )
106 "" disk-vocabs-recursive-for-prefix ;
108 : all-disk-vocab-names ( -- seq )
109 all-disk-vocabs-recursive filter-vocabs [ vocab-name ] map! ;
111 : disk-child-vocab-names ( prefix -- seq )
112 disk-vocabs-for-prefix filter-vocabs [ vocab-name ] map! ;
116 : collect-vocabs ( quot -- seq )
117 [ all-disk-vocabs-recursive filter-vocabs ] dip
118 gather natural-sort ; inline
120 : maybe-include-root/prefix ( root prefix -- vocab-link/f )
122 [ find-vocab-root = ] keep swap
124 nip dup find-vocab-root
125 ] if [ >vocab-link ] [ drop f ] if ;
129 : disk-vocabs-in-root/prefix ( root prefix -- seq )
130 [ (disk-vocabs-recursive) ]
131 [ maybe-include-root/prefix [ prefix ] when* ] 2bi ;
133 : disk-vocabs-in-root ( root -- seq )
134 "" disk-vocabs-in-root/prefix ;
138 : vocabs-to-load ( root prefix -- seq )
139 disk-vocabs-in-root/prefix
140 [ don't-load? ] reject no-prefixes ;
144 : load-from-root ( root prefix -- )
145 vocabs-to-load require-all ;
147 : load-root ( root -- )
151 [ vocab-roots get ] dip '[ _ load-from-root ] each ;
156 MEMO: all-tags ( -- seq )
157 [ vocab-tags ] collect-vocabs ;
159 MEMO: all-authors ( -- seq )
160 [ vocab-authors ] collect-vocabs ;