factor/basis/vocabs/hierarchy/hierarchy.factor

99 lines
2.4 KiB
Factor

! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators.short-circuit fry
io.directories io.files io.files.info io.pathnames kernel make
memoize namespaces sequences sorting splitting vocabs sets
vocabs.loader vocabs.metadata vocabs.errors ;
IN: vocabs.hierarchy
<PRIVATE
: vocab-subdirs ( dir -- dirs )
[
[
{ [ link-info directory? ] [ "." head? not ] } 1&&
] filter
] with-directory-files natural-sort ;
: (all-child-vocabs) ( root name -- vocabs )
[
vocab-dir append-path dup exists?
[ vocab-subdirs ] [ drop { } ] if
] keep
[ '[ [ _ "." ] dip 3append ] map ] unless-empty ;
: vocab-dir? ( root name -- ? )
over
[ ".factor" vocab-dir+ append-path exists? ]
[ 2drop f ]
if ;
: vocabs-in-dir ( root name -- )
dupd (all-child-vocabs) [
2dup vocab-dir? [ dup >vocab-link , ] when
vocabs-in-dir
] with each ;
PRIVATE>
: all-vocabs ( -- assoc )
vocab-roots get [
dup [ "" vocabs-in-dir ] { } make
] { } map>assoc ;
: all-vocabs-under ( prefix -- vocabs )
[
[ vocab-roots get ] dip '[ _ vocabs-in-dir ] each
] { } make ;
MEMO: all-vocabs-seq ( -- seq )
"" all-vocabs-under ;
<PRIVATE
: unrooted-child-vocabs ( prefix -- seq )
dup empty? [ CHAR: . suffix ] unless
vocabs
[ find-vocab-root not ] filter
[
vocab-name swap ?head CHAR: . rot member? not and
] with filter
[ vocab ] map ;
PRIVATE>
: all-child-vocabs ( prefix -- assoc )
vocab-roots get [
dup pick (all-child-vocabs) [ >vocab-link ] map
] { } map>assoc
swap unrooted-child-vocabs f swap 2array suffix ;
: all-child-vocabs-seq ( prefix -- assoc )
vocab-roots get swap '[
dup _ (all-child-vocabs)
[ vocab-dir? ] with filter
] map concat ;
<PRIVATE
: filter-unportable ( seq -- seq' )
[ vocab-name unportable? not ] filter ;
PRIVATE>
: (load) ( prefix -- failures )
all-vocabs-under
filter-unportable
require-all ;
: load ( prefix -- )
(load) load-failures. ;
: load-all ( -- )
"" load ;
MEMO: all-tags ( -- seq )
all-vocabs-seq [ vocab-tags ] gather natural-sort ;
MEMO: all-authors ( -- seq )
all-vocabs-seq [ vocab-authors ] gather natural-sort ;