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 : no-roots ( assoc -- seq ) values concat ;\r
  62 \r
  63 : child-vocabs ( prefix -- assoc )\r
  64     [ [ vocab-roots get ] dip '[ dup _ (child-vocabs) ] { } map>assoc ]\r
  65     [ unrooted-child-vocabs [ vocab ] map f swap 2array ]\r
  66     bi suffix ;\r
  67 \r
  68 : all-vocabs ( -- assoc )\r
  69     "" child-vocabs ;\r
  70 \r
  71 : child-vocabs-recursive ( prefix -- assoc )\r
  72     [ [ vocab-roots get ] dip '[ dup _ (child-vocabs-recursive) ] { } map>assoc ]\r
  73     [ unrooted-child-vocabs-recursive [ vocab ] map f swap 2array ]\r
  74     bi suffix ;\r
  75 \r
  76 MEMO: all-vocabs-recursive ( -- assoc )\r
  77     "" child-vocabs-recursive ;\r
  78 \r
  79 : all-vocab-names ( -- seq )\r
  80     all-vocabs-recursive no-roots no-prefixes [ vocab-name ] map ;\r
  81 \r
  82 <PRIVATE\r
  83 \r
  84 : filter-unportable ( seq -- seq' )\r
  85     [ vocab-name unportable? not ] filter ;\r
  86 \r
  87 : collect-vocabs ( quot -- seq )\r
  88     [ all-vocabs-recursive no-roots no-prefixes ] dip\r
  89     gather natural-sort ; inline\r
  90 \r
  91 PRIVATE>\r
  92 \r
  93 : (load) ( prefix -- failures )\r
  94     child-vocabs-recursive\r
  95     filter-unportable\r
  96     require-all ;\r
  97 \r
  98 : load ( prefix -- )\r
  99     (load) load-failures. ;\r
 100 \r
 101 : load-all ( -- )\r
 102     "" load ;\r
 103 \r
 104 MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;\r
 105 \r
 106 MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;\r