-! Copyright (C) 2007, 2009 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors arrays assocs combinators.short-circuit fry\r
-io.directories io.files io.files.types io.pathnames kernel make\r
-memoize namespaces sequences sorting splitting vocabs sets\r
-vocabs.loader vocabs.metadata vocabs.errors ;\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
-: visible-dirs ( seq -- seq' )\r
- [\r
- {\r
- [ type>> +directory+ = ]\r
- [ name>> "." head? not ]\r
- } 1&&\r
- ] filter ;\r
-\r
-: vocab-subdirs ( dir -- dirs )\r
- directory-entries visible-dirs [ name>> ] map! natural-sort ;\r
-\r
-: vocab-dir? ( root name -- ? )\r
- over\r
- [ ".factor" append-vocab-dir append-path exists? ]\r
- [ 2drop f ]\r
- if ;\r
-\r
-ERROR: vocab-root-required root ;\r
-\r
-: ensure-vocab-root ( root -- root )\r
- dup vocab-roots get member? [ vocab-root-required ] unless ;\r
-\r
-: ensure-vocab-root/prefix ( root prefix -- root prefix )\r
- [ ensure-vocab-root ] [ check-vocab-name ] bi* ;\r
-\r
-: (disk-vocab-children) ( root prefix -- vocabs )\r
- check-vocab-name\r
- [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]\r
- [ nip [ "." append '[ _ prepend ] map! ] unless-empty ]\r
- [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map! ]\r
- 2tri ;\r
-\r
-: ((disk-vocabs-recursive)) ( root prefix -- )\r
- dupd vocab-name (disk-vocab-children) [ % ] keep\r
- [ ((disk-vocabs-recursive)) ] with each ;\r
-\r
-: (disk-vocabs-recursive) ( root prefix -- seq )\r
- [ ensure-vocab-root ] dip\r
- [ ((disk-vocabs-recursive)) ] { } make ;\r
-\r
-: no-rooted ( seq -- seq' ) [ find-vocab-root ] reject ;\r
-\r
-: one-level-only? ( name prefix -- ? )\r
- ?head [ "." split1 nip not ] [ drop f ] if ;\r
-\r
-: unrooted-disk-vocabs ( prefix -- seq )\r
- [ loaded-vocab-names no-rooted ] dip\r
- dup empty? [ CHAR: . suffix ] unless\r
- '[ vocab-name _ one-level-only? ] filter ;\r
-\r
-: unrooted-disk-vocabs-recursive ( prefix -- seq )\r
- loaded-child-vocab-names no-rooted ;\r
-\r
-PRIVATE>\r
-\r
-: no-prefixes ( seq -- seq' ) [ vocab-prefix? ] reject ;\r
-\r
-: convert-prefixes ( seq -- seq' )\r
- [ dup vocab-prefix? [ name>> <vocab-link> ] when ] map ;\r
-\r
-: remove-redundant-prefixes ( seq -- seq' )\r
- #! Hack.\r
- [ vocab-prefix? ] partition\r
- [\r
- [ vocab-name ] map fast-set\r
- '[ name>> _ in? ] reject\r
- convert-prefixes\r
- ] keep\r
- append ;\r
-\r
-: no-roots ( assoc -- seq ) values concat ;\r
-\r
-: filter-vocabs ( assoc -- seq )\r
- no-roots no-prefixes members ;\r
-\r
-: disk-vocabs-for-prefix ( prefix -- assoc )\r
- [ [ vocab-roots get ] dip '[ dup _ (disk-vocab-children) ] { } map>assoc ]\r
- [ unrooted-disk-vocabs [ lookup-vocab ] map! f swap 2array ]\r
- bi suffix ;\r
-\r
-: all-disk-vocabs-by-root ( -- assoc )\r
- "" disk-vocabs-for-prefix ;\r
-\r
-: disk-vocabs-recursive-for-prefix ( prefix -- assoc )\r
- [ [ vocab-roots get ] dip '[ dup _ (disk-vocabs-recursive) ] { } map>assoc ]\r
- [ unrooted-disk-vocabs-recursive [ lookup-vocab ] map! f swap 2array ]\r
- bi suffix ;\r
-\r
-MEMO: all-disk-vocabs-recursive ( -- assoc )\r
- "" disk-vocabs-recursive-for-prefix ;\r
-\r
-: all-disk-vocab-names ( -- seq )\r
- all-disk-vocabs-recursive filter-vocabs [ vocab-name ] map! ;\r
-\r
-: disk-child-vocab-names ( prefix -- seq )\r
- disk-vocabs-for-prefix filter-vocabs [ vocab-name ] map! ;\r
-\r
-<PRIVATE\r
-\r
-: collect-vocabs ( quot -- seq )\r
- [ all-disk-vocabs-recursive filter-vocabs ] dip\r
- gather natural-sort ; inline\r
-\r
-: maybe-include-root/prefix ( root prefix -- vocab-link/f )\r
- over [\r
- [ find-vocab-root = ] keep swap\r
- ] [\r
- nip dup find-vocab-root\r
- ] if [ >vocab-link ] [ drop f ] if ;\r
-\r
-PRIVATE>\r
-\r
-: disk-vocabs-in-root/prefix ( root prefix -- seq )\r
- [ (disk-vocabs-recursive) ]\r
- [ maybe-include-root/prefix [ prefix ] when* ] 2bi ;\r
-\r
-: disk-vocabs-in-root ( root -- seq )\r
- "" disk-vocabs-in-root/prefix ;\r
-\r
-: (load-from-root) ( root prefix -- failures )\r
- disk-vocabs-in-root/prefix\r
- [ don't-load? ] reject no-prefixes\r
- require-all ;\r
-\r
-: load-from-root ( root prefix -- )\r
- (load-from-root) load-failures. ;\r
-\r
-: load-root ( root -- )\r
- "" load-from-root ;\r
-\r
-: (load) ( prefix -- failures )\r
- [ vocab-roots get ] dip '[ _ (load-from-root) ] map concat ;\r
-\r
-: load ( prefix -- )\r
- (load) load-failures. ;\r
-\r
-: load-all ( -- )\r
- "" load ;\r
-\r
-MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;\r
-\r
-MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;\r
+! Copyright (C) 2007, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators.short-circuit fry
+io.directories io.files io.files.types io.pathnames kernel make
+memoize namespaces sequences sorting splitting vocabs sets
+vocabs.loader vocabs.metadata vocabs.errors ;
+IN: vocabs.hierarchy
+
+TUPLE: vocab-prefix name ;
+
+C: <vocab-prefix> vocab-prefix
+
+M: vocab-prefix vocab-name name>> ;
+
+<PRIVATE
+
+: visible-dirs ( seq -- seq' )
+ [
+ {
+ [ type>> +directory+ = ]
+ [ name>> "." head? not ]
+ } 1&&
+ ] filter ;
+
+: vocab-subdirs ( dir -- dirs )
+ directory-entries visible-dirs [ name>> ] map! natural-sort ;
+
+: vocab-dir? ( root name -- ? )
+ over
+ [ ".factor" append-vocab-dir append-path exists? ]
+ [ 2drop f ]
+ if ;
+
+ERROR: vocab-root-required root ;
+
+: ensure-vocab-root ( root -- root )
+ dup vocab-roots get member? [ vocab-root-required ] unless ;
+
+: ensure-vocab-root/prefix ( root prefix -- root prefix )
+ [ ensure-vocab-root ] [ check-vocab-name ] bi* ;
+
+: (disk-vocab-children) ( root prefix -- vocabs )
+ check-vocab-name
+ [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]
+ [ nip [ "." append '[ _ prepend ] map! ] unless-empty ]
+ [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map! ]
+ 2tri ;
+
+: ((disk-vocabs-recursive)) ( root prefix -- )
+ dupd vocab-name (disk-vocab-children) [ % ] keep
+ [ ((disk-vocabs-recursive)) ] with each ;
+
+: (disk-vocabs-recursive) ( root prefix -- seq )
+ [ ensure-vocab-root ] dip
+ [ ((disk-vocabs-recursive)) ] { } make ;
+
+: no-rooted ( seq -- seq' ) [ find-vocab-root ] reject ;
+
+: one-level-only? ( name prefix -- ? )
+ ?head [ "." split1 nip not ] [ drop f ] if ;
+
+: unrooted-disk-vocabs ( prefix -- seq )
+ [ loaded-vocab-names no-rooted ] dip
+ dup empty? [ CHAR: . suffix ] unless
+ '[ vocab-name _ one-level-only? ] filter ;
+
+: unrooted-disk-vocabs-recursive ( prefix -- seq )
+ loaded-child-vocab-names no-rooted ;
+
+PRIVATE>
+
+: no-prefixes ( seq -- seq' ) [ vocab-prefix? ] reject ;
+
+: convert-prefixes ( seq -- seq' )
+ [ dup vocab-prefix? [ name>> <vocab-link> ] when ] map ;
+
+: remove-redundant-prefixes ( seq -- seq' )
+ #! Hack.
+ [ vocab-prefix? ] partition
+ [
+ [ vocab-name ] map fast-set
+ '[ name>> _ in? ] reject
+ convert-prefixes
+ ] keep
+ append ;
+
+: no-roots ( assoc -- seq ) values concat ;
+
+: filter-vocabs ( assoc -- seq )
+ no-roots no-prefixes members ;
+
+: disk-vocabs-for-prefix ( prefix -- assoc )
+ [ [ vocab-roots get ] dip '[ dup _ (disk-vocab-children) ] { } map>assoc ]
+ [ unrooted-disk-vocabs [ lookup-vocab ] map! f swap 2array ]
+ bi suffix ;
+
+: all-disk-vocabs-by-root ( -- assoc )
+ "" disk-vocabs-for-prefix ;
+
+: disk-vocabs-recursive-for-prefix ( prefix -- assoc )
+ [ [ vocab-roots get ] dip '[ dup _ (disk-vocabs-recursive) ] { } map>assoc ]
+ [ unrooted-disk-vocabs-recursive [ lookup-vocab ] map! f swap 2array ]
+ bi suffix ;
+
+MEMO: all-disk-vocabs-recursive ( -- assoc )
+ "" disk-vocabs-recursive-for-prefix ;
+
+: all-disk-vocab-names ( -- seq )
+ all-disk-vocabs-recursive filter-vocabs [ vocab-name ] map! ;
+
+: disk-child-vocab-names ( prefix -- seq )
+ disk-vocabs-for-prefix filter-vocabs [ vocab-name ] map! ;
+
+<PRIVATE
+
+: collect-vocabs ( quot -- seq )
+ [ all-disk-vocabs-recursive filter-vocabs ] dip
+ gather natural-sort ; inline
+
+: maybe-include-root/prefix ( root prefix -- vocab-link/f )
+ over [
+ [ find-vocab-root = ] keep swap
+ ] [
+ nip dup find-vocab-root
+ ] if [ >vocab-link ] [ drop f ] if ;
+
+PRIVATE>
+
+: disk-vocabs-in-root/prefix ( root prefix -- seq )
+ [ (disk-vocabs-recursive) ]
+ [ maybe-include-root/prefix [ prefix ] when* ] 2bi ;
+
+: disk-vocabs-in-root ( root -- seq )
+ "" disk-vocabs-in-root/prefix ;
+
+: (load-from-root) ( root prefix -- failures )
+ disk-vocabs-in-root/prefix
+ [ don't-load? ] reject no-prefixes
+ require-all ;
+
+: load-from-root ( root prefix -- )
+ (load-from-root) load-failures. ;
+
+: load-root ( root -- )
+ "" load-from-root ;
+
+: (load) ( prefix -- failures )
+ [ vocab-roots get ] dip '[ _ (load-from-root) ] map concat ;
+
+: load ( prefix -- )
+ (load) load-failures. ;
+
+: load-all ( -- )
+ "" load ;
+
+MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;
+
+MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;
projects / factor.git / blobdiff