core/vocabs/vocabs.factor

   1 ! Copyright (C) 2007, 2009 Eduardo Cavazos, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs definitions kernel namespaces sequences
   4 sets sorting splitting strings ;
   5 IN: vocabs
   6
   7 SYMBOL: dictionary
   8
   9 TUPLE: vocab < identity-tuple
  10 name words
  11 main help
  12 source-loaded? docs-loaded? ;
  13
  14 ! sources-loaded? and docs-loaded? slots could be
  15 SYMBOLS: +parsing+ +done+ ;
  16
  17 : <vocab> ( name -- vocab )
  18     vocab new
  19         swap >>name
  20         H{ } clone >>words ;
  21
  22 ERROR: bad-vocab-name name ;
  23
  24 : check-vocab-name ( name -- name )
  25     dup string? [ bad-vocab-name ] unless
  26     dup [ ":/\\ " member? ] any? [ bad-vocab-name ] when ;
  27
  28 TUPLE: vocab-link name ;
  29
  30 C: <vocab-link> vocab-link
  31
  32 UNION: vocab-spec vocab vocab-link ;
  33
  34 INSTANCE: vocab-spec definition-mixin
  35
  36 GENERIC: vocab-name ( vocab-spec -- name )
  37
  38 M: vocab vocab-name name>> ;
  39
  40 M: vocab-link vocab-name name>> ;
  41
  42 M: object vocab-name check-vocab-name ;
  43
  44 GENERIC: lookup-vocab ( vocab-spec -- vocab )
  45
  46 M: vocab lookup-vocab ;
  47
  48 M: object lookup-vocab vocab-name dictionary get at ;
  49
  50 ERROR: no-vocab-named name ;
  51
  52 : ?lookup-vocab ( vocab-spec -- vocab )
  53     dup lookup-vocab [ nip ] [ no-vocab-named ] if* ;
  54
  55 GENERIC: vocab-words-assoc ( vocab-spec -- assoc/f )
  56
  57 M: vocab vocab-words-assoc words>> ;
  58
  59 M: object vocab-words-assoc lookup-vocab vocab-words-assoc ;
  60
  61 M: f vocab-words-assoc ;
  62
  63 GENERIC: vocab-help ( vocab-spec -- help )
  64
  65 M: vocab vocab-help help>> ;
  66
  67 M: object vocab-help lookup-vocab vocab-help ;
  68
  69 M: f vocab-help ;
  70
  71 GENERIC: vocab-main ( vocab-spec -- main )
  72
  73 M: vocab vocab-main main>> ;
  74
  75 M: object vocab-main lookup-vocab vocab-main ;
  76
  77 M: f vocab-main ;
  78
  79 PREDICATE: runnable-vocab < vocab
  80     vocab-main >boolean ;
  81
  82 SYMBOL: vocab-observers
  83
  84 GENERIC: vocab-changed ( vocab obj -- )
  85
  86 : add-vocab-observer ( obj -- )
  87     vocab-observers get push ;
  88
  89 : remove-vocab-observer ( obj -- )
  90     vocab-observers get remove-eq! drop ;
  91
  92 : notify-vocab-observers ( vocab -- )
  93     vocab-observers get [ vocab-changed ] with each ;
  94
  95 : create-vocab ( name -- vocab )
  96     check-vocab-name dictionary get [ <vocab> ] cache
  97     dup notify-vocab-observers ;
  98
  99 ERROR: no-vocab name ;
 100
 101 : loaded-vocab-names ( -- seq )
 102     dictionary get keys natural-sort ;
 103
 104 : vocab-words ( vocab-spec -- seq )
 105     vocab-words-assoc values ;
 106
 107 : all-words ( -- seq )
 108     dictionary get values [ vocab-words ] map concat ;
 109
 110 : words-named ( str -- seq )
 111     dictionary get
 112     [ values [ vocab-words-assoc at ] with map sift ]
 113     [
 114         [ ":" split1 swap ] dip at
 115         [ vocab-words-assoc at [ suffix ] when* ] [ drop ] if*
 116     ] 2bi ;
 117
 118 : child-vocab? ( prefix name -- ? )
 119     swap [ drop t ] [
 120         2dup = [ 2drop t ] [
 121             2dup head? [
 122                 length swap ?nth CHAR: . =
 123             ] [ 2drop f ] if
 124         ] if
 125     ] if-empty ;
 126
 127 : loaded-child-vocab-names ( vocab-spec -- seq )
 128     vocab-name loaded-vocab-names [ child-vocab? ] with filter ;
 129
 130 GENERIC: >vocab-link ( name -- vocab )
 131
 132 M: vocab-spec >vocab-link ;
 133
 134 M: object >vocab-link dup lookup-vocab [ ] [ <vocab-link> ] ?if ;
 135
 136 <PRIVATE
 137
 138 : (forget-vocab) ( vocab -- )
 139     [ vocab-words forget-all ]
 140     [ vocab-name dictionary get delete-at ]
 141     [ notify-vocab-observers ] tri ;
 142
 143 PRIVATE>
 144
 145 : forget-vocab ( vocab -- )
 146     [ (forget-vocab) ] [
 147         vocab-name dup ".private" tail? [ drop ] [
 148             ".private" append (forget-vocab)
 149         ] if
 150     ] bi ;
 151
 152 M: vocab-spec forget* forget-vocab ;
 153
 154 SYMBOL: require-hook
 155
 156 <PRIVATE
 157
 158 SYMBOL: requiring
 159
 160 : with-requiring ( quot -- )
 161     requiring get [
 162         swap call
 163     ] [
 164         HS{ } clone dup requiring [ swap call ] with-variable
 165     ] if* ; inline
 166
 167 PRIVATE>
 168
 169 GENERIC: require ( object -- )
 170
 171 M: vocab require name>> require ;
 172
 173 M: vocab-link require name>> require ;
 174
 175 ! When calling "foo.private" require, load "foo" instead, but
 176 ! only when "foo.private" does not exist. The reason for this is
 177 ! that stage1 bootstrap starts out with some .private vocabs
 178 ! that contain primitives, and loading the public vocabs would
 179 ! cause circularity issues.
 180 M: string require
 181     [ ".private" ?tail ] keep swap [ lookup-vocab not ] when [
 182         [
 183             dupd ?adjoin
 184             [ require-hook get call( name -- ) ] [ drop ] if
 185         ] with-requiring
 186     ] [ drop ] if ;
 187
 188 : require-all ( vocabs -- )
 189     [ require ] each ;
 190
 191 : load-vocab ( name -- vocab )
 192     [ require ] [ lookup-vocab ] bi ;
 193
 194 : ?load-vocab ( name -- vocab )
 195     [ require ] [ ?lookup-vocab ] bi ;