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