basis/vocabs/hierarchy/hierarchy.factor

   1 ! Copyright (C) 2007, 2009 Slava Pestov.\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: accessors arrays assocs combinators.short-circuit fry\r
   4 io.directories io.files io.files.types io.pathnames kernel make\r
   5 memoize namespaces sequences sorting splitting vocabs sets\r
   6 vocabs.loader vocabs.metadata vocabs.errors ;\r
   7 IN: vocabs.hierarchy\r
   8 \r
   9 TUPLE: vocab-prefix name ;\r
  10 \r
  11 C: <vocab-prefix> vocab-prefix\r
  12 \r
  13 M: vocab-prefix vocab-name name>> ;\r
  14 \r
  15 <PRIVATE\r
  16 \r
  17 : visible-dirs ( seq -- seq' )\r
  18     [\r
  19         {\r
  20             [ type>> +directory+ = ]\r
  21             [ name>> "." head? not ]\r
  22         } 1&&\r
  23     ] filter ;\r
  24 \r
  25 : vocab-subdirs ( dir -- dirs )\r
  26     directory-entries visible-dirs [ name>> ] map! natural-sort ;\r
  27 \r
  28 : vocab-dir? ( root name -- ? )\r
  29     over\r
  30     [ ".factor" append-vocab-dir append-path exists? ]\r
  31     [ 2drop f ]\r
  32     if ;\r
  33 \r
  34 ERROR: vocab-root-required root ;\r
  35 \r
  36 : ensure-vocab-root ( root -- root )\r
  37     dup vocab-roots get member? [ vocab-root-required ] unless ;\r
  38 \r
  39 : ensure-vocab-root/prefix ( root prefix -- root prefix )\r
  40     [ ensure-vocab-root ] [ check-vocab-name ] bi* ;\r
  41 \r
  42 : (disk-vocab-children) ( root prefix -- vocabs )\r
  43     check-vocab-name\r
  44     [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]\r
  45     [ nip [ "." append '[ _ prepend ] map! ] unless-empty ]\r
  46     [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map! ]\r
  47     2tri ;\r
  48 \r
  49 : ((disk-vocabs-recursive)) ( root prefix -- )\r
  50     dupd vocab-name (disk-vocab-children) [ % ] keep\r
  51     [ ((disk-vocabs-recursive)) ] with each ;\r
  52 \r
  53 : (disk-vocabs-recursive) ( root prefix -- seq )\r
  54     [ ensure-vocab-root ] dip\r
  55     [ ((disk-vocabs-recursive)) ] { } make ;\r
  56 \r
  57 : no-rooted ( seq -- seq' ) [ find-vocab-root ] reject ;\r
  58 \r
  59 : one-level-only? ( name prefix -- ? )\r
  60     ?head [ "." split1 nip not ] [ drop f ] if ;\r
  61 \r
  62 : unrooted-disk-vocabs ( prefix -- seq )\r
  63     [ loaded-vocab-names no-rooted ] dip\r
  64     dup empty? [ CHAR: . suffix ] unless\r
  65     '[ vocab-name _ one-level-only? ] filter ;\r
  66 \r
  67 : unrooted-disk-vocabs-recursive ( prefix -- seq )\r
  68     loaded-child-vocab-names no-rooted ;\r
  69 \r
  70 PRIVATE>\r
  71 \r
  72 : no-prefixes ( seq -- seq' ) [ vocab-prefix? ] reject ;\r
  73 \r
  74 : convert-prefixes ( seq -- seq' )\r
  75     [ dup vocab-prefix? [ name>> <vocab-link> ] when ] map ;\r
  76 \r
  77 : remove-redundant-prefixes ( seq -- seq' )\r
  78     #! Hack.\r
  79     [ vocab-prefix? ] partition\r
  80     [\r
  81         [ vocab-name ] map fast-set\r
  82         '[ name>> _ in? ] reject\r
  83         convert-prefixes\r
  84     ] keep\r
  85     append ;\r
  86 \r
  87 : no-roots ( assoc -- seq ) values concat ;\r
  88 \r
  89 : filter-vocabs ( assoc -- seq )\r
  90     no-roots no-prefixes members ;\r
  91 \r
  92 : disk-vocabs-for-prefix ( prefix -- assoc )\r
  93     [ [ vocab-roots get ] dip '[ dup _ (disk-vocab-children) ] { } map>assoc ]\r
  94     [ unrooted-disk-vocabs [ lookup-vocab ] map! f swap 2array ]\r
  95     bi suffix ;\r
  96 \r
  97 : all-disk-vocabs-by-root ( -- assoc )\r
  98     "" disk-vocabs-for-prefix ;\r
  99 \r
 100 : disk-vocabs-recursive-for-prefix ( prefix -- assoc )\r
 101     [ [ vocab-roots get ] dip '[ dup _ (disk-vocabs-recursive) ] { } map>assoc ]\r
 102     [ unrooted-disk-vocabs-recursive [ lookup-vocab ] map! f swap 2array ]\r
 103     bi suffix ;\r
 104 \r
 105 MEMO: all-disk-vocabs-recursive ( -- assoc )\r
 106     "" disk-vocabs-recursive-for-prefix ;\r
 107 \r
 108 : all-disk-vocab-names ( -- seq )\r
 109     all-disk-vocabs-recursive filter-vocabs [ vocab-name ] map! ;\r
 110 \r
 111 : disk-child-vocab-names ( prefix -- seq )\r
 112     disk-vocabs-for-prefix filter-vocabs [ vocab-name ] map! ;\r
 113 \r
 114 <PRIVATE\r
 115 \r
 116 : collect-vocabs ( quot -- seq )\r
 117     [ all-disk-vocabs-recursive filter-vocabs ] dip\r
 118     gather natural-sort ; inline\r
 119 \r
 120 : maybe-include-root/prefix ( root prefix -- vocab-link/f )\r
 121     over [\r
 122         [ find-vocab-root = ] keep swap\r
 123     ] [\r
 124         nip dup find-vocab-root\r
 125     ] if [ >vocab-link ] [ drop f ] if ;\r
 126 \r
 127 PRIVATE>\r
 128 \r
 129 : disk-vocabs-in-root/prefix ( root prefix -- seq )\r
 130     [ (disk-vocabs-recursive) ]\r
 131     [ maybe-include-root/prefix [ prefix ] when* ] 2bi ;\r
 132 \r
 133 : disk-vocabs-in-root ( root -- seq )\r
 134     "" disk-vocabs-in-root/prefix ;\r
 135 \r
 136 : (load-from-root) ( root prefix -- failures )\r
 137     disk-vocabs-in-root/prefix\r
 138     [ don't-load? ] reject no-prefixes\r
 139     require-all ;\r
 140 \r
 141 : load-from-root ( root prefix -- )\r
 142     (load-from-root) load-failures. ;\r
 143 \r
 144 : load-root ( root -- )\r
 145     "" load-from-root ;\r
 146 \r
 147 : (load) ( prefix -- failures )\r
 148     [ vocab-roots get ] dip '[ _ (load-from-root) ] map concat ;\r
 149 \r
 150 : load ( prefix -- )\r
 151     (load) load-failures. ;\r
 152 \r
 153 : load-all ( -- )\r
 154     "" load ;\r
 155 \r
 156 MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;\r
 157 \r
 158 MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;\r