basis/vocabs/hierarchy/hierarchy.factor

   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 ;
   7 IN: vocabs.hierarchy
   8
   9 TUPLE: vocab-prefix name ;
  10
  11 C: <vocab-prefix> vocab-prefix
  12
  13 M: vocab-prefix vocab-name name>> ;
  14
  15 <PRIVATE
  16
  17 : visible-dirs ( seq -- seq' )
  18     [
  19         {
  20             [ directory? ]
  21             [ name>> "." head? not ]
  22         } 1&&
  23     ] filter ;
  24
  25 : vocab-subdirs ( dir -- dirs )
  26     directory-entries visible-dirs [ name>> ] map! natural-sort ;
  27
  28 : vocab-dir? ( root name -- ? )
  29     over
  30     [ ".factor" append-vocab-dir append-path exists? ]
  31     [ 2drop f ]
  32     if ;
  33
  34 ERROR: vocab-root-required root ;
  35
  36 : ensure-vocab-root ( root -- root )
  37     dup vocab-roots get member? [ vocab-root-required ] unless ;
  38
  39 : ensure-vocab-root/prefix ( root prefix -- root prefix )
  40     [ ensure-vocab-root ] [ check-vocab-name ] bi* ;
  41
  42 : (disk-vocab-children) ( root prefix -- vocabs )
  43     check-vocab-name
  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! ]
  47     2tri ;
  48
  49 : ((disk-vocabs-recursive)) ( root prefix -- )
  50     dupd vocab-name (disk-vocab-children) [ % ] keep
  51     [ ((disk-vocabs-recursive)) ] with each ;
  52
  53 : (disk-vocabs-recursive) ( root prefix -- seq )
  54     [ ensure-vocab-root ] dip
  55     [ ((disk-vocabs-recursive)) ] { } make ;
  56
  57 : no-rooted ( seq -- seq' ) [ find-vocab-root ] reject ;
  58
  59 : one-level-only? ( name prefix -- ? )
  60     ?head [ "." split1 nip not ] [ drop f ] if ;
  61
  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 ;
  66
  67 : unrooted-disk-vocabs-recursive ( prefix -- seq )
  68     loaded-child-vocab-names no-rooted ;
  69
  70 PRIVATE>
  71
  72 : no-prefixes ( seq -- seq' ) [ vocab-prefix? ] reject ;
  73
  74 : convert-prefixes ( seq -- seq' )
  75     [ dup vocab-prefix? [ name>> <vocab-link> ] when ] map ;
  76
  77 : remove-redundant-prefixes ( seq -- seq' )
  78     #! Hack.
  79     [ vocab-prefix? ] partition
  80     [
  81         [ vocab-name ] map fast-set
  82         '[ name>> _ in? ] reject
  83         convert-prefixes
  84     ] keep
  85     append ;
  86
  87 : no-roots ( assoc -- seq ) values concat ;
  88
  89 : filter-vocabs ( assoc -- seq )
  90     no-roots no-prefixes members ;
  91
  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 ]
  95     bi suffix ;
  96
  97 : all-disk-vocabs-by-root ( -- assoc )
  98     "" disk-vocabs-for-prefix ;
  99
 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 ]
 103     bi suffix ;
 104
 105 MEMO: all-disk-vocabs-recursive ( -- assoc )
 106     "" disk-vocabs-recursive-for-prefix ;
 107
 108 : all-disk-vocab-names ( -- seq )
 109     all-disk-vocabs-recursive filter-vocabs [ vocab-name ] map! ;
 110
 111 : disk-child-vocab-names ( prefix -- seq )
 112     disk-vocabs-for-prefix filter-vocabs [ vocab-name ] map! ;
 113
 114 <PRIVATE
 115
 116 : collect-vocabs ( quot -- seq )
 117     [ all-disk-vocabs-recursive filter-vocabs ] dip
 118     gather natural-sort ; inline
 119
 120 : maybe-include-root/prefix ( root prefix -- vocab-link/f )
 121     over [
 122         [ find-vocab-root = ] keep swap
 123     ] [
 124         nip dup find-vocab-root
 125     ] if [ >vocab-link ] [ drop f ] if ;
 126
 127 PRIVATE>
 128
 129 : disk-vocabs-in-root/prefix ( root prefix -- seq )
 130     [ (disk-vocabs-recursive) ]
 131     [ maybe-include-root/prefix [ prefix ] when* ] 2bi ;
 132
 133 : disk-vocabs-in-root ( root -- seq )
 134     "" disk-vocabs-in-root/prefix ;
 135
 136 <PRIVATE
 137
 138 : vocabs-to-load ( root prefix -- seq )
 139     disk-vocabs-in-root/prefix
 140     [ don't-load? ] reject no-prefixes ;
 141
 142 PRIVATE>
 143
 144 : load-from-root ( root prefix -- )
 145     vocabs-to-load require-all ;
 146
 147 : load-root ( root -- )
 148     "" load-from-root ;
 149
 150 : load ( prefix -- )
 151     [ vocab-roots get ] dip '[ _ load-from-root ] each ;
 152
 153 : load-all ( -- )
 154     "" load ;
 155
 156 MEMO: all-tags ( -- seq )
 157     [ vocab-tags ] collect-vocabs ;
 158
 159 MEMO: all-authors ( -- seq )
 160     [ vocab-authors ] collect-vocabs ;