core/vocabs/vocabs.factor

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