! 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.info io.pathnames kernel make\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
RENAME: child-vocabs vocabs => vocabs:child-vocabs\r
\r
<PRIVATE\r
\r
-: vocab-subdirs ( dir -- dirs )\r
+: visible-dirs ( seq -- seq' )\r
[\r
- [\r
- { [ link-info directory? ] [ "." head? not ] } 1&&\r
- ] filter\r
- ] with-directory-files natural-sort ;\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" vocab-dir+ append-path exists? ]\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
: (child-vocabs) ( root prefix -- vocabs )\r
+ check-vocab-name\r
[ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]\r
- [ nip [ '[ [ _ "." ] dip 3append ] map ] unless-empty ]\r
- [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map ]\r
+ [ nip [ "." append '[ _ prepend ] map! ] unless-empty ]\r
+ [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map! ]\r
2tri ;\r
\r
-: ((child-vocabs-recursive)) ( root name -- )\r
- dupd vocab-name (child-vocabs)\r
- [ dup , ((child-vocabs-recursive)) ] with each ;\r
+: ((child-vocabs-recursive)) ( root prefix -- )\r
+ dupd vocab-name (child-vocabs) [ % ] keep\r
+ [ ((child-vocabs-recursive)) ] with each ;\r
\r
-: (child-vocabs-recursive) ( root name -- seq )\r
+: (child-vocabs-recursive) ( root prefix -- seq )\r
+ [ ensure-vocab-root ] dip\r
[ ((child-vocabs-recursive)) ] { } make ;\r
\r
-: no-rooted ( seq -- seq' ) [ find-vocab-root not ] filter ;\r
+: no-rooted ( seq -- seq' ) [ find-vocab-root ] reject ;\r
\r
: one-level-only? ( name prefix -- ? )\r
- ?head [ "." split1 nip not ] dip and ;\r
+ ?head [ "." split1 nip not ] [ drop f ] if ;\r
\r
: unrooted-child-vocabs ( prefix -- seq )\r
[ vocabs no-rooted ] dip\r
\r
PRIVATE>\r
\r
-: no-prefixes ( seq -- seq' ) [ vocab-prefix? not ] filter ;\r
+: no-prefixes ( seq -- seq' ) [ vocab-prefix? ] reject ;\r
\r
: convert-prefixes ( seq -- seq' )\r
- [ dup vocab-prefix? [ name>> vocab-link boa ] when ] map ;\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? not ] filter\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
: child-vocabs ( prefix -- assoc )\r
[ [ vocab-roots get ] dip '[ dup _ (child-vocabs) ] { } map>assoc ]\r
- [ unrooted-child-vocabs [ vocab ] map f swap 2array ]\r
+ [ unrooted-child-vocabs [ lookup-vocab ] map! f swap 2array ]\r
bi suffix ;\r
\r
: all-vocabs ( -- assoc )\r
\r
: child-vocabs-recursive ( prefix -- assoc )\r
[ [ vocab-roots get ] dip '[ dup _ (child-vocabs-recursive) ] { } map>assoc ]\r
- [ unrooted-child-vocabs-recursive [ vocab ] map f swap 2array ]\r
+ [ unrooted-child-vocabs-recursive [ lookup-vocab ] map! f swap 2array ]\r
bi suffix ;\r
\r
MEMO: all-vocabs-recursive ( -- assoc )\r
"" child-vocabs-recursive ;\r
\r
: all-vocab-names ( -- seq )\r
- all-vocabs-recursive no-roots no-prefixes [ vocab-name ] map ;\r
+ all-vocabs-recursive filter-vocabs [ vocab-name ] map! ;\r
\r
: child-vocab-names ( prefix -- seq )\r
- child-vocabs no-roots no-prefixes [ vocab-name ] map ;\r
+ child-vocabs filter-vocabs [ vocab-name ] map! ;\r
\r
<PRIVATE\r
\r
: collect-vocabs ( quot -- seq )\r
- [ all-vocabs-recursive no-roots no-prefixes ] dip\r
+ [ all-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
-: (load) ( prefix -- failures )\r
- [ child-vocabs-recursive no-roots no-prefixes ]\r
- [ dup find-vocab-root [ >vocab-link prefix ] [ drop ] if ] bi\r
- filter-don't-load\r
+: vocabs-in-root/prefix ( root prefix -- seq )\r
+ [ (child-vocabs-recursive) ]\r
+ [ maybe-include-root/prefix [ prefix ] when* ] 2bi ;\r
+\r
+: vocabs-in-root ( root -- seq )\r
+ "" vocabs-in-root/prefix ;\r
+\r
+: (load-from-root) ( root prefix -- failures )\r
+ 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
projects / factor.git / blobdiff