use reject instead of [ ... not ] filter.

[factor.git] / basis / vocabs / hierarchy / hierarchy.factor

diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor
index d3436d7dba6525d5d79325b94f3bafce21d702e3..07c2097e35b1b868c0ba5f5aac18622be4f0c836 100644 (file)
--- a/basis/vocabs/hierarchy/hierarchy.factor
+++ b/basis/vocabs/hierarchy/hierarchy.factor
@@ -1,7 +1,7 @@
 ! 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
@@ -15,12 +15,16 @@ M: vocab-prefix vocab-name name>> ;
 \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
@@ -34,26 +38,27 @@ ERROR: vocab-root-required root ;
     dup vocab-roots get member? [ vocab-root-required ] unless ;\r
 \r
 : ensure-vocab-root/prefix ( root prefix -- root prefix )\r
-    [ ensure-vocab-root ] [ forbid-absolute-path ] bi* ;\r
+    [ ensure-vocab-root ] [ check-vocab-name ] bi* ;\r
 \r
 : (child-vocabs) ( root prefix -- vocabs )\r
-    ensure-vocab-root/prefix\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 prefix -- )\r
-    dupd vocab-name (child-vocabs)\r
-    [ dup , ((child-vocabs-recursive)) ] with each ;\r
+    dupd vocab-name (child-vocabs) [ % ] keep\r
+    [ ((child-vocabs-recursive)) ] with each ;\r
 \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
@@ -65,17 +70,17 @@ ERROR: vocab-root-required root ;
 \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
@@ -87,7 +92,7 @@ PRIVATE>
 \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
@@ -95,17 +100,17 @@ PRIVATE>
 \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 filter-vocabs [ vocab-name ] map ;\r
+    all-vocabs-recursive filter-vocabs [ vocab-name ] map! ;\r
 \r
 : child-vocab-names ( prefix -- seq )\r
-    child-vocabs filter-vocabs [ vocab-name ] map ;\r
+    child-vocabs filter-vocabs [ vocab-name ] map! ;\r
 \r
 <PRIVATE\r
 \r
@@ -131,7 +136,7 @@ PRIVATE>
 \r
 : (load-from-root) ( root prefix -- failures )\r
     vocabs-in-root/prefix\r
-    [ don't-load? not ] filter no-prefixes\r
+    [ don't-load? ] reject no-prefixes\r
     require-all ;\r
 \r
 : load-from-root ( root prefix -- )\r
@@ -144,7 +149,7 @@ PRIVATE>
     [ vocab-roots get ] dip '[ _ (load-from-root) ] map concat ;\r
 \r
 : load ( prefix -- )\r
-    (load) [ load-failures. ] each ;\r
+    (load) load-failures. ;\r
 \r
 : load-all ( -- )\r
     "" load ;\r