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" vocab-dir+ append-path exists? ]\r
  28     [ 2drop f ]\r
  29     if ;\r
  30 \r
  31 : (child-vocabs) ( root prefix -- vocabs )\r
  32     [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]\r
  33     [ nip [ '[ [ _ "." ] dip 3append ] map ] unless-empty ]\r
  34     [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map ]\r
  35     2tri ;\r
  36 \r
  37 : ((child-vocabs-recursive)) ( root name -- )\r
  38     dupd vocab-name (child-vocabs)\r
  39     [ dup , ((child-vocabs-recursive)) ] with each ;\r
  40 \r
  41 : (child-vocabs-recursive) ( root name -- seq )\r
  42     [ ((child-vocabs-recursive)) ] { } make ;\r
  43 \r
  44 : no-rooted ( seq -- seq' ) [ find-vocab-root not ] filter ;\r
  45 \r
  46 : one-level-only? ( name prefix -- ? )\r
  47     ?head [ "." split1 nip not ] dip and ;\r
  48 \r
  49 : unrooted-child-vocabs ( prefix -- seq )\r
  50     [ vocabs no-rooted ] dip\r
  51     dup empty? [ CHAR: . suffix ] unless\r
  52     '[ vocab-name _ one-level-only? ] filter ;\r
  53 \r
  54 : unrooted-child-vocabs-recursive ( prefix -- seq )\r
  55     vocabs:child-vocabs no-rooted ;\r
  56 \r
  57 PRIVATE>\r
  58 \r
  59 : no-prefixes ( seq -- seq' ) [ vocab-prefix? not ] filter ;\r
  60 \r
  61 : convert-prefixes ( seq -- seq' )\r
  62     [ dup vocab-prefix? [ name>> vocab-link boa ] when ] map ;\r
  63 \r
  64 : remove-redundant-prefixes ( seq -- seq' )\r
  65     #! Hack.\r
  66     [ vocab-prefix? ] partition\r
  67     [\r
  68         [ vocab-name ] map unique\r
  69         '[ name>> _ key? not ] filter\r
  70         convert-prefixes\r
  71     ] keep\r
  72     append ;\r
  73 \r
  74 : no-roots ( assoc -- seq ) values concat ;\r
  75 \r
  76 : child-vocabs ( prefix -- assoc )\r
  77     [ [ vocab-roots get ] dip '[ dup _ (child-vocabs) ] { } map>assoc ]\r
  78     [ unrooted-child-vocabs [ vocab ] map f swap 2array ]\r
  79     bi suffix ;\r
  80 \r
  81 : all-vocabs ( -- assoc )\r
  82     "" child-vocabs ;\r
  83 \r
  84 : child-vocabs-recursive ( prefix -- assoc )\r
  85     [ [ vocab-roots get ] dip '[ dup _ (child-vocabs-recursive) ] { } map>assoc ]\r
  86     [ unrooted-child-vocabs-recursive [ vocab ] map f swap 2array ]\r
  87     bi suffix ;\r
  88 \r
  89 MEMO: all-vocabs-recursive ( -- assoc )\r
  90     "" child-vocabs-recursive ;\r
  91 \r
  92 : all-vocab-names ( -- seq )\r
  93     all-vocabs-recursive no-roots no-prefixes [ vocab-name ] map ;\r
  94 \r
  95 : child-vocab-names ( prefix -- seq )\r
  96     child-vocabs no-roots no-prefixes [ vocab-name ] map ;\r
  97 \r
  98 <PRIVATE\r
  99 \r
 100 : filter-unportable ( seq -- seq' )\r
 101     [ vocab-name unportable? not ] filter ;\r
 102 \r
 103 : collect-vocabs ( quot -- seq )\r
 104     [ all-vocabs-recursive no-roots no-prefixes ] dip\r
 105     gather natural-sort ; inline\r
 106 \r
 107 PRIVATE>\r
 108 \r
 109 : (load) ( prefix -- failures )\r
 110     child-vocabs-recursive no-roots no-prefixes\r
 111     filter-unportable\r
 112     require-all ;\r
 113 \r
 114 : load ( prefix -- )\r
 115     (load) load-failures. ;\r
 116 \r
 117 : load-all ( -- )\r
 118     "" load ;\r
 119 \r
 120 MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;\r
 121 \r
 122 MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;\r