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