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: 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 IN: vocabs.hierarchy\r
   8 \r
   9 <PRIVATE\r
  10 \r
  11 : vocab-subdirs ( dir -- dirs )\r
  12     [\r
  13         [\r
  14             { [ link-info directory? ] [ "." head? not ] } 1&&\r
  15         ] filter\r
  16     ] with-directory-files natural-sort ;\r
  17 \r
  18 : (all-child-vocabs) ( root name -- vocabs )\r
  19     [\r
  20         vocab-dir append-path dup exists?\r
  21         [ vocab-subdirs ] [ drop { } ] if\r
  22     ] keep\r
  23     [ '[ [ _ "." ] dip 3append ] map ] unless-empty ;\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 : vocabs-in-dir ( root name -- )\r
  32     dupd (all-child-vocabs) [\r
  33         2dup vocab-dir? [ dup >vocab-link , ] when\r
  34         vocabs-in-dir\r
  35     ] with each ;\r
  36 \r
  37 PRIVATE>\r
  38 \r
  39 : all-vocabs ( -- assoc )\r
  40     vocab-roots get [\r
  41         dup [ "" vocabs-in-dir ] { } make\r
  42     ] { } map>assoc ;\r
  43 \r
  44 : all-vocabs-under ( prefix -- vocabs )\r
  45     [\r
  46         [ vocab-roots get ] dip '[ _ vocabs-in-dir ] each\r
  47     ] { } make ;\r
  48 \r
  49 MEMO: all-vocabs-seq ( -- seq )\r
  50     "" all-vocabs-under ;\r
  51 \r
  52 <PRIVATE\r
  53 \r
  54 : unrooted-child-vocabs ( prefix -- seq )\r
  55     dup empty? [ CHAR: . suffix ] unless\r
  56     vocabs\r
  57     [ find-vocab-root not ] filter\r
  58     [\r
  59         vocab-name swap ?head CHAR: . rot member? not and\r
  60     ] with filter\r
  61     [ vocab ] map ;\r
  62 \r
  63 PRIVATE>\r
  64 \r
  65 : all-child-vocabs ( prefix -- assoc )\r
  66     vocab-roots get [\r
  67         dup pick (all-child-vocabs) [ >vocab-link ] map\r
  68     ] { } map>assoc\r
  69     swap unrooted-child-vocabs f swap 2array suffix ;\r
  70 \r
  71 : all-child-vocabs-seq ( prefix -- assoc )\r
  72     vocab-roots get swap '[\r
  73         dup _ (all-child-vocabs)\r
  74         [ vocab-dir? ] with filter\r
  75     ] map concat ;\r
  76 \r
  77 <PRIVATE\r
  78 \r
  79 : filter-unportable ( seq -- seq' )\r
  80     [ vocab-name unportable? not ] filter ;\r
  81 \r
  82 PRIVATE>\r
  83 \r
  84 : (load) ( prefix -- failures )\r
  85     all-vocabs-under\r
  86     filter-unportable\r
  87     require-all ;\r
  88 \r
  89 : load ( prefix -- )\r
  90     (load) load-failures. ;\r
  91 \r
  92 : load-all ( -- )\r
  93     "" load ;\r
  94 \r
  95 MEMO: all-tags ( -- seq )\r
  96     all-vocabs-seq [ vocab-tags ] gather natural-sort ;\r
  97 \r
  98 MEMO: all-authors ( -- seq )\r
  99     all-vocabs-seq [ vocab-authors ] gather natural-sort ;