basis/vocabs/hierarchy/hierarchy.factor

   1 ! Copyright (C) 2007, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators.short-circuit fry
   4 io.directories io.files io.files.info io.pathnames kernel make
   5 memoize namespaces sequences sets sorting splitting vocabs
   6 vocabs.loader vocabs.metadata ;
   7 IN: vocabs.hierarchy
   8
   9 TUPLE: vocab-prefix name ;
  10
  11 C: <vocab-prefix> vocab-prefix
  12
  13 M: vocab-prefix vocab-name name>> ;
  14
  15 <PRIVATE
  16
  17 : visible-dir? ( entry -- ? )
  18     { [ directory? ] [ name>> "." head? not ] } 1&& ;
  19
  20 : visible-dirs ( seq -- seq' )
  21     [ visible-dir? ] filter [ name>> ] sort-with ;
  22
  23 ERROR: vocab-root-required root ;
  24
  25 : ensure-vocab-root ( root -- root )
  26     dup vocab-roots get member? [ vocab-root-required ] unless ;
  27
  28 : ensure-vocab-root/prefix ( root prefix -- root prefix )
  29     [ ensure-vocab-root ] [ check-vocab-name ] bi* ;
  30
  31 : vocab-directory-entries ( root prefix -- vocab-path vocab-name entries )
  32     ensure-vocab-root/prefix [ vocab-dir append-path ] keep
  33     over dup file-exists? [ directory-entries ] [ drop { } ] if ;
  34
  35 : (disk-vocabs) ( root prefix -- seq )
  36     vocab-directory-entries visible-dirs [
  37         name>>
  38         [ dup ".factor" append append-path append-path ]
  39         [ over empty? [ nip ] [ "." glue ] if ] bi-curry bi*
  40         swap file-exists? [ >vocab-link ] [ <vocab-prefix> ] if
  41     ] 2with map ;
  42
  43 DEFER: add-vocab%
  44
  45 : add-vocab-children% ( vocab-path vocab-name entries -- )
  46     visible-dirs [
  47         name>>
  48         [ append-path ]
  49         [ over empty? [ nip ] [ "." glue ] if ] bi-curry bi*
  50         over directory-entries add-vocab%
  51     ] 2with each ;
  52
  53 : add-vocab% ( vocab-path vocab-name entries -- )
  54     3dup rot file-name ".factor" append '[ name>> _ =  ] any?
  55     [ >vocab-link ] [ <vocab-prefix> ] if , add-vocab-children% ;
  56
  57 : (disk-vocabs-recursive) ( root prefix -- seq )
  58     vocab-directory-entries
  59     [ add-vocab-children% ] { } make ;
  60
  61 : no-rooted ( seq -- seq' ) [ find-vocab-root ] reject ;
  62
  63 : one-level-only? ( name prefix -- ? )
  64     ?head [ "." split1 nip not ] [ drop f ] if ;
  65
  66 : unrooted-disk-vocabs ( prefix -- seq )
  67     [ loaded-vocab-names no-rooted ] dip
  68     dup empty? [ CHAR: . suffix ] unless
  69     '[ vocab-name _ one-level-only? ] filter ;
  70
  71 : unrooted-disk-vocabs-recursive ( prefix -- seq )
  72     loaded-child-vocab-names no-rooted ;
  73
  74 PRIVATE>
  75
  76 : no-prefixes ( seq -- seq' ) [ vocab-prefix? ] reject ;
  77
  78 : no-roots ( assoc -- seq ) values concat ;
  79
  80 : filter-vocabs ( assoc -- seq )
  81     no-roots no-prefixes members ;
  82
  83 : disk-vocabs-for-prefix ( prefix -- assoc )
  84     [ [ vocab-roots get ] dip '[ dup _ (disk-vocabs) ] { } map>assoc ]
  85     [ unrooted-disk-vocabs [ lookup-vocab ] map! f swap 2array ]
  86     bi suffix ;
  87
  88 : all-disk-vocabs-by-root ( -- assoc )
  89     "" disk-vocabs-for-prefix ;
  90
  91 : disk-vocabs-recursive-for-prefix ( prefix -- assoc )
  92     [ [ vocab-roots get ] dip '[ dup _ (disk-vocabs-recursive) ] { } map>assoc ]
  93     [ unrooted-disk-vocabs-recursive [ lookup-vocab ] map! f swap 2array ]
  94     bi suffix ;
  95
  96 MEMO: all-disk-vocabs-recursive ( -- assoc )
  97     "" disk-vocabs-recursive-for-prefix ;
  98
  99 : all-disk-vocab-names ( -- seq )
 100     all-disk-vocabs-recursive filter-vocabs [ vocab-name ] map! ;
 101
 102 : disk-child-vocab-names ( prefix -- seq )
 103     disk-vocabs-for-prefix filter-vocabs [ vocab-name ] map! ;
 104
 105 <PRIVATE
 106
 107 : collect-vocabs ( quot -- seq )
 108     [ all-disk-vocabs-recursive filter-vocabs ] dip
 109     gather natural-sort ; inline
 110
 111 : maybe-include-root/prefix ( root prefix -- vocab-link/f )
 112     over [
 113         [ find-vocab-root = ] keep swap
 114     ] [
 115         nip dup find-vocab-root
 116     ] if [ >vocab-link ] [ drop f ] if ;
 117
 118 PRIVATE>
 119
 120 : disk-vocabs-in-root/prefix ( root prefix -- seq )
 121     [ (disk-vocabs-recursive) ]
 122     [ maybe-include-root/prefix [ prefix ] when* ] 2bi ;
 123
 124 : disk-vocabs-in-root ( root -- seq )
 125     "" disk-vocabs-in-root/prefix ;
 126
 127 <PRIVATE
 128
 129 : vocabs-to-load ( root prefix -- seq )
 130     disk-vocabs-in-root/prefix
 131     [ don't-load? ] reject no-prefixes ;
 132
 133 PRIVATE>
 134
 135 : load-from-root ( root prefix -- )
 136     vocabs-to-load require-all ;
 137
 138 : load-root ( root -- )
 139     "" load-from-root ;
 140
 141 : load ( prefix -- )
 142     [ vocab-roots get ] dip '[ _ load-from-root ] each ;
 143
 144 : load-all ( -- )
 145     "" load ;
 146
 147 MEMO: all-tags ( -- seq )
 148     [ vocab-tags ] collect-vocabs ;
 149
 150 MEMO: all-authors ( -- seq )
 151     [ vocab-authors ] collect-vocabs ;