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 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 SYMBOL: vocab-observers
  80
  81 GENERIC: vocab-changed ( vocab obj -- )
  82
  83 : add-vocab-observer ( obj -- )
  84     vocab-observers get push ;
  85
  86 : remove-vocab-observer ( obj -- )
  87     vocab-observers get remove-eq! drop ;
  88
  89 : notify-vocab-observers ( vocab -- )
  90     vocab-observers get [ vocab-changed ] with each ;
  91
  92 : create-vocab ( name -- vocab )
  93     check-vocab-name dictionary get [ <vocab> ] cache
  94     dup notify-vocab-observers ;
  95
  96 ERROR: no-vocab name ;
  97
  98 : loaded-vocab-names ( -- seq )
  99     dictionary get keys natural-sort ;
 100
 101 : vocab-words ( vocab-spec -- seq )
 102     vocab-words-assoc values ;
 103
 104 : all-words ( -- seq )
 105     dictionary get values [ vocab-words ] map concat ;
 106
 107 : words-named ( str -- seq )
 108     dictionary get
 109     [ values [ vocab-words-assoc at ] with map sift ]
 110     [
 111         [ ":" split1 swap ] dip at
 112         [ vocab-words-assoc at [ suffix ] when* ] [ drop ] if*
 113     ] 2bi ;
 114
 115 : child-vocab? ( prefix name -- ? )
 116     swap [ drop t ] [
 117         2dup = [ 2drop t ] [
 118             2dup head? [
 119                 length swap ?nth CHAR: . =
 120             ] [ 2drop f ] if
 121         ] if
 122     ] if-empty ;
 123
 124 : loaded-child-vocab-names ( vocab-spec -- seq )
 125     vocab-name loaded-vocab-names [ child-vocab? ] with filter ;
 126
 127 GENERIC: >vocab-link ( name -- vocab )
 128
 129 M: vocab-spec >vocab-link ;
 130
 131 M: object >vocab-link dup lookup-vocab [ ] [ <vocab-link> ] ?if ;
 132
 133 : forget-vocab ( vocab -- )
 134     [ vocab-words forget-all ]
 135     [ vocab-name dictionary get delete-at ]
 136     [ notify-vocab-observers ] tri ;
 137
 138 M: vocab-spec forget* forget-vocab ;
 139
 140 SYMBOL: require-hook
 141
 142 PREDICATE: runnable-vocab < vocab
 143     vocab-main >boolean ;
 144
 145 INSTANCE: vocab-spec definition-mixin
 146
 147 GENERIC: require ( object -- )
 148
 149 M: vocab require name>> require ;
 150
 151 M: vocab-link require name>> require ;
 152
 153 ! When calling "foo.private" require, load "foo" instead, but
 154 ! only when "foo.private" does not exist. The reason for this is
 155 ! that stage1 bootstrap starts out with some .private vocabs
 156 ! that contain primitives, and loading the public vocabs would
 157 ! cause circularity issues.
 158 M: string require
 159     [ ".private" ?tail ] keep swap [ lookup-vocab not ] when
 160     [ require-hook get call( name -- ) ] [ drop ] if ;
 161
 162 : load-vocab ( name -- vocab )
 163     [ require ] [ lookup-vocab ] bi ;
 164
 165 : ?load-vocab ( name -- vocab )
 166     [ require ] [ ?lookup-vocab ] bi ;