1 ! Copyright (C) 2007, 2009 Daniel Ehrenberg, Bruno Deferrari,
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: assocs hashtables kernel namespaces sequences
5 sets strings vocabs sorting accessors arrays compiler.units
6 combinators vectors splitting continuations math
10 ERROR: no-word-error name ;
12 : word-restarts ( possibilities -- restarts )
14 [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc ;
16 : word-restarts-with-defer ( name possibilities -- restarts )
18 swap "Defer word in current vocabulary" swap 2array
21 : <no-word-error> ( name possibilities -- error restarts )
22 [ drop \ no-word-error boa ] [ word-restarts-with-defer ] 2bi ;
26 { search-vocab-names hashtable }
27 { search-vocabs vector }
28 { qualified-vocabs vector }
29 { extra-words vector }
30 { auto-used vector } ;
32 : <manifest> ( -- manifest )
34 H{ } clone >>search-vocab-names
35 V{ } clone >>search-vocabs
36 V{ } clone >>qualified-vocabs
37 V{ } clone >>extra-words
38 V{ } clone >>auto-used ;
42 [ clone ] change-search-vocab-names
43 [ clone ] change-search-vocabs
44 [ clone ] change-qualified-vocabs
45 [ clone ] change-extra-words
46 [ clone ] change-auto-used ;
48 TUPLE: extra-words words ;
51 over extra-words? [ [ words>> ] bi@ eq? ] [ 2drop f ] if ;
53 C: <extra-words> extra-words
57 : clear-manifest ( -- )
59 [ search-vocab-names>> clear-assoc ]
60 [ search-vocabs>> delete-all ]
61 [ qualified-vocabs>> delete-all ]
64 : (add-qualified) ( qualified -- )
65 manifest get qualified-vocabs>> push ;
67 : (from) ( vocab words -- vocab words words' assoc )
68 2dup swap load-vocab words>> ;
70 : extract-words ( seq assoc -- assoc' )
71 extract-keys dup [ [ drop ] [ no-word-error ] if ] assoc-each ;
73 : (lookup) ( name assoc -- word/f )
74 at dup forward-reference? [ drop f ] when ;
76 : (use-words) ( assoc -- extra-words seq )
77 <extra-words> manifest get qualified-vocabs>> ;
81 : set-current-vocab ( name -- )
83 [ manifest get (>>current-vocab) ]
84 [ words>> <extra-words> (add-qualified) ] bi ;
86 TUPLE: no-current-vocab ;
88 : no-current-vocab ( -- vocab )
89 \ no-current-vocab boa
90 { { "Define words in scratchpad vocabulary" "scratchpad" } }
91 throw-restarts dup set-current-vocab ;
93 : current-vocab ( -- vocab )
94 manifest get current-vocab>> [ no-current-vocab ] unless* ;
96 : begin-private ( -- )
97 manifest get current-vocab>> vocab-name ".private" ?tail
98 [ drop ] [ ".private" append set-current-vocab ] if ;
101 manifest get current-vocab>> vocab-name ".private" ?tail
102 [ set-current-vocab ] [ drop ] if ;
104 : using-vocab? ( vocab -- ? )
105 vocab-name manifest get search-vocab-names>> key? ;
107 : use-vocab ( vocab -- )
109 [ vocab-name "Already using ``" "'' vocabulary" surround note. ] [
111 [ [ load-vocab ] dip search-vocabs>> push ]
112 [ [ vocab-name ] dip search-vocab-names>> conjoin ]
116 : auto-use-vocab ( vocab -- )
117 [ use-vocab ] [ manifest get auto-used>> push ] bi ;
119 : auto-used? ( -- ? ) manifest get auto-used>> length 0 > ;
121 : unuse-vocab ( vocab -- )
124 [ [ load-vocab ] dip search-vocabs>> delq ]
125 [ [ vocab-name ] dip search-vocab-names>> delete-at ]
129 : only-use-vocabs ( vocabs -- )
130 clear-manifest [ vocab ] filter [ use-vocab ] each ;
132 TUPLE: qualified vocab prefix words ;
134 : <qualified> ( vocab prefix -- qualified )
136 [ load-vocab words>> ] [ CHAR: : suffix ] bi*
137 [ swap [ prepend ] dip ] curry assoc-map
140 : add-qualified ( vocab prefix -- )
141 <qualified> (add-qualified) ;
143 TUPLE: from vocab names words ;
145 : <from> ( vocab words -- from )
146 (from) extract-words from boa ;
148 : add-words-from ( vocab words -- )
149 <from> (add-qualified) ;
151 TUPLE: exclude vocab names words ;
153 : <exclude> ( vocab words -- from )
154 (from) [ nip ] [ extract-words ] 2bi assoc-diff exclude boa ;
156 : add-words-excluding ( vocab words -- )
157 <exclude> (add-qualified) ;
159 TUPLE: rename word vocab words ;
161 : <rename> ( word vocab new-name -- rename )
162 [ 2dup load-vocab words>> dupd at [ ] [ no-word-error ] ?if ] dip
163 associate rename boa ;
165 : add-renamed-word ( word vocab new-name -- )
166 <rename> (add-qualified) ;
168 : use-words ( assoc -- ) (use-words) push ;
170 : unuse-words ( assoc -- ) (use-words) delete ;
172 TUPLE: ambiguous-use-error words ;
174 : <ambiguous-use-error> ( words -- error restarts )
175 [ \ ambiguous-use-error boa ] [ word-restarts ] bi ;
179 : (vocab-search) ( name assocs -- words n )
180 [ words>> (lookup) ] with map
183 : vocab-search ( name manifest -- word/f )
189 drop <ambiguous-use-error> throw-restarts
190 dup [ vocabulary>> ] [ name>> 1array ] bi add-words-from
194 : qualified-search ( name manifest -- word/f )
196 (vocab-search) 0 = [ drop f ] [ last ] if ;
200 : search-manifest ( name manifest -- word/f )
201 2dup qualified-search dup [ 2nip ] [ drop vocab-search ] if ;
203 : search ( name -- word/f )
204 manifest get search-manifest ;