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
   4 sequences 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? slot is one of these three
  15 SYMBOL: +parsing+
  16 SYMBOL: +running+
  17 SYMBOL: +done+
  18
  19 : <vocab> ( name -- vocab )
  20     vocab new
  21         swap >>name
  22         H{ } clone >>words ;
  23
  24 ERROR: bad-vocab-name name ;
  25
  26 : check-vocab-name ( name -- name )
  27     dup string? [ bad-vocab-name ] unless
  28     dup [ ":/\\ " member? ] any? [ bad-vocab-name ] when ;
  29
  30 TUPLE: vocab-link name ;
  31
  32 C: <vocab-link> vocab-link
  33
  34 UNION: vocab-spec vocab vocab-link ;
  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 ( name -- vocab ) vocab-name dictionary get at ;
  49
  50 GENERIC: vocab-words-assoc ( vocab-spec -- assoc/f )
  51
  52 M: vocab vocab-words-assoc words>> ;
  53
  54 M: object vocab-words-assoc lookup-vocab vocab-words-assoc ;
  55
  56 M: f vocab-words-assoc ;
  57
  58 GENERIC: vocab-help ( vocab-spec -- help )
  59
  60 M: vocab vocab-help help>> ;
  61
  62 M: object vocab-help lookup-vocab vocab-help ;
  63
  64 M: f vocab-help ;
  65
  66 GENERIC: vocab-main ( vocab-spec -- main )
  67
  68 M: vocab vocab-main main>> ;
  69
  70 M: object vocab-main lookup-vocab vocab-main ;
  71
  72 M: f vocab-main ;
  73
  74 SYMBOL: vocab-observers
  75
  76 GENERIC: vocab-changed ( vocab obj -- )
  77
  78 : add-vocab-observer ( obj -- )
  79     vocab-observers get push ;
  80
  81 : remove-vocab-observer ( obj -- )
  82     vocab-observers get remove-eq! drop ;
  83
  84 : notify-vocab-observers ( vocab -- )
  85     vocab-observers get [ vocab-changed ] with each ;
  86
  87 : create-vocab ( name -- vocab )
  88     check-vocab-name dictionary get
  89     [ <vocab> dup notify-vocab-observers ] cache ;
  90
  91 ERROR: no-vocab name ;
  92
  93 : loaded-vocab-names ( -- seq )
  94     dictionary get keys natural-sort ;
  95
  96 : vocab-words ( vocab-spec -- seq )
  97     vocab-words-assoc values ;
  98
  99 : all-words ( -- seq )
 100     dictionary get values [ vocab-words ] map concat ;
 101
 102 : words-named ( str -- seq )
 103     dictionary get
 104     [ values [ vocab-words-assoc at ] with map sift ]
 105     [
 106         [ ":" split1 swap ] dip at
 107         [ vocab-words-assoc at [ suffix ] when* ] [ drop ] if*
 108     ] 2bi ;
 109
 110 : child-vocab? ( prefix name -- ? )
 111     swap [ drop t ] [
 112         2dup = [ 2drop t ] [
 113             2dup head? [
 114                 length swap ?nth CHAR: . =
 115             ] [ 2drop f ] if
 116         ] if
 117     ] if-empty ;
 118
 119 : loaded-child-vocab-names ( vocab-spec -- seq )
 120     vocab-name loaded-vocab-names [ child-vocab? ] with filter ;
 121
 122 GENERIC: >vocab-link ( name -- vocab )
 123
 124 M: vocab-spec >vocab-link ;
 125
 126 M: object >vocab-link dup lookup-vocab [ ] [ <vocab-link> ] ?if ;
 127
 128 : forget-vocab ( vocab -- )
 129     [ vocab-words forget-all ]
 130     [ vocab-name dictionary get delete-at ]
 131     [ notify-vocab-observers ] tri ;
 132
 133 M: vocab-spec forget* forget-vocab ;
 134
 135 SYMBOL: require-hook
 136
 137 PREDICATE: runnable-vocab < vocab
 138     vocab-main >boolean ;
 139
 140 INSTANCE: vocab-spec definition-mixin
 141
 142 : call-require-hook ( name -- )
 143     require-hook get call( name -- ) ;
 144
 145 GENERIC: require ( object -- )
 146
 147 M: vocab require name>> require ;
 148
 149 M: vocab-link require name>> require ;
 150
 151 ! When calling "foo.private" require, load "foo" instead, but only when
 152 ! "foo.private" does not exist. The reason for this is that stage1 bootstrap
 153 ! starts out with some .private vocabs that contain primitives, and
 154 ! loading the public vocabs would cause circularity issues.
 155 M: string require ( vocab -- )
 156     dup ".private" ?tail [
 157         over lookup-vocab
 158         [ 2drop ]
 159         [ nip call-require-hook ]
 160         if
 161     ] [
 162         nip call-require-hook
 163     ] if ;
 164
 165 : load-vocab ( name -- vocab )
 166     [ require ] [ lookup-vocab ] bi ;