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