1 ! Copyright (C) 2007, 2010 Daniel Ehrenberg, Bruno Deferrari,
3 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors arrays assocs combinators compiler.units
5 continuations hash-sets hashtables kernel math namespaces
6 parser.notes sequences sets sorting splitting vectors vocabs
10 ERROR: no-word-error name ;
12 : word-restarts ( possibilities -- restarts )
14 [ vocabulary>> "Use the " " vocabulary" surround ] keep
17 : word-restarts-with-defer ( name possibilities -- restarts )
19 "Defer word in current vocabulary" rot 2array
22 : <no-word-error> ( name possibilities -- error restarts )
23 [ drop \ no-word-error boa ] [ word-restarts-with-defer ] 2bi ;
27 { search-vocab-names hash-set }
28 { search-vocabs vector }
29 { qualified-vocabs vector }
30 { auto-used vector } ;
32 : <manifest> ( -- manifest )
34 HS{ } clone >>search-vocab-names
35 V{ } clone >>search-vocabs
36 V{ } clone >>qualified-vocabs
37 V{ } clone >>auto-used ;
41 [ clone ] change-search-vocab-names
42 [ clone ] change-search-vocabs
43 [ clone ] change-qualified-vocabs
44 [ clone ] change-auto-used ;
46 TUPLE: extra-words words ;
49 over extra-words? [ [ words>> ] bi@ eq? ] [ 2drop f ] if ;
51 C: <extra-words> extra-words
53 ERROR: no-word-in-vocab word vocab ;
57 : (from) ( vocab words -- vocab words words' vocab )
58 2dup swap load-vocab ;
60 : extract-words ( seq vocab -- assoc )
61 [ words>> extract-keys dup ] [ name>> ] bi
62 [ swap [ 2drop ] [ no-word-in-vocab ] if ] curry assoc-each ;
64 : excluding-words ( seq vocab -- assoc )
65 [ nip words>> ] [ extract-words ] 2bi assoc-diff ;
67 : qualified-words ( prefix vocab -- assoc )
68 words>> swap [ swap [ swap ":" glue ] dip ] curry assoc-map ;
70 : (lookup) ( name assoc -- word/f )
71 at* [ dup forward-reference? [ drop f ] when ] when ;
75 : qualified-vocabs ( -- qualified-vocabs )
76 manifest get qualified-vocabs>> ;
78 : set-current-vocab ( name -- )
80 [ manifest get current-vocab<< ]
81 [ qualified-vocabs push ] bi ;
83 : with-current-vocab ( name quot -- )
84 manifest get clone manifest [
85 [ set-current-vocab ] dip call
86 ] with-variable ; inline
88 TUPLE: no-current-vocab-error ;
90 : no-current-vocab ( -- vocab )
91 no-current-vocab-error boa
92 { { "Define words in scratchpad vocabulary" "scratchpad" } }
93 throw-restarts dup set-current-vocab ;
95 : current-vocab ( -- vocab )
96 manifest get current-vocab>> [ no-current-vocab ] unless* ;
98 ERROR: unbalanced-private-declaration vocab ;
100 : begin-private ( -- )
101 current-vocab name>> ".private" ?tail
102 [ unbalanced-private-declaration ]
103 [ ".private" append set-current-vocab ] if ;
106 current-vocab name>> ".private" ?tail
107 [ set-current-vocab ]
108 [ unbalanced-private-declaration ] if ;
110 : using-vocab? ( vocab -- ? )
111 vocab-name manifest get search-vocab-names>> in? ;
113 : use-vocab ( vocab -- )
115 vocab-name "Already using ``" "'' vocabulary" surround note.
118 [ [ ?load-vocab ] dip search-vocabs>> push ]
119 [ [ vocab-name ] dip search-vocab-names>> adjoin ]
123 : auto-use-vocab ( vocab -- )
124 [ use-vocab ] [ manifest get auto-used>> push ] bi ;
126 : auto-used? ( -- ? )
127 manifest get auto-used>> length 0 > ;
129 : unuse-vocab ( vocab -- )
132 [ [ load-vocab ] dip search-vocabs>> remove-eq! drop ]
133 [ [ vocab-name ] dip search-vocab-names>> delete ]
135 [ vocab-name ] dip qualified-vocabs>> [
136 dup extra-words? [ 2drop f ] [
137 dup vocab? [ vocab>> ] unless vocab-name =
143 TUPLE: qualified vocab prefix words ;
145 : <qualified> ( vocab prefix -- qualified )
146 (from) qualified-words qualified boa ;
148 : add-qualified ( vocab prefix -- )
149 <qualified> qualified-vocabs push ;
151 TUPLE: from vocab names words ;
153 : <from> ( vocab words -- from )
154 (from) extract-words from boa ;
156 : add-words-from ( vocab words -- )
157 <from> qualified-vocabs push ;
159 TUPLE: exclude vocab names words ;
161 : <exclude> ( vocab words -- from )
162 (from) excluding-words exclude boa ;
164 : add-words-excluding ( vocab words -- )
165 <exclude> qualified-vocabs push ;
167 TUPLE: rename word vocab words ;
169 : <rename> ( word vocab new-name -- rename )
171 2dup load-vocab words>> dupd at
172 [ ] [ swap no-word-in-vocab ] ?if
173 ] dip associate rename boa ;
175 : add-renamed-word ( word vocab new-name -- )
176 <rename> qualified-vocabs push ;
178 : use-words ( words -- )
179 <extra-words> qualified-vocabs push ;
181 : unuse-words ( words -- )
182 <extra-words> qualified-vocabs remove! drop ;
188 : ?restart-with-words ( words error -- * )
191 [ restarts>> rethrow-restarts ]
192 [ continuation>> '[ _ _ continue-with ] with-words ] tri
193 ] [ nip rethrow ] if ;
197 : with-words ( words quot -- )
198 [ over '[ _ use-words @ _ unuse-words ] ]
199 [ drop dup '[ _ unuse-words _ swap ?restart-with-words ] ]
202 TUPLE: ambiguous-use-error name words ;
204 : <ambiguous-use-error> ( name words -- error restarts )
205 [ ambiguous-use-error boa ] [ word-restarts ] bi ;
209 : (lookup-word) ( words name vocab -- words )
210 words>> (lookup) [ suffix! ] when* ; inline
212 : (vocab-search) ( name assocs -- words )
213 [ V{ } clone ] 2dip [ (lookup-word) ] with each ;
215 : (vocab-search-qualified) ( words name assocs -- words )
216 [ ":" split1 swap ] dip pick [
217 [ name>> = ] with find nip [ (lookup-word) ] with when*
222 : (vocab-search-full) ( name assocs -- words )
223 [ (vocab-search) ] [ (vocab-search-qualified) ] 2bi ;
225 : vocab-search ( name manifest -- word/f )
226 dupd search-vocabs>> (vocab-search-full) dup length {
230 drop <ambiguous-use-error> throw-restarts
231 dup [ vocabulary>> ] [ name>> 1array ] bi add-words-from
235 : qualified-search ( name manifest -- word/f )
236 qualified-vocabs>> (vocab-search) ?last ;
240 : search-manifest ( name manifest -- word/f )
241 2dup qualified-search [ 2nip ] [ vocab-search ] if* ;
243 : search ( name -- word/f )
244 manifest get search-manifest ;
248 GENERIC: update ( search-path-elt -- valid? )
250 : trim-forgotten ( qualified-vocab -- valid? )
251 [ [ nip "forgotten" word-prop ] assoc-reject ] change-words
252 words>> assoc-empty? not ;
254 M: from update trim-forgotten ;
255 M: rename update trim-forgotten ;
256 M: extra-words update trim-forgotten ;
257 M: exclude update trim-forgotten ;
260 dup vocab>> lookup-vocab [
261 dup [ prefix>> ] [ vocab>> load-vocab ] bi qualified-words
265 M: vocab update dup name>> lookup-vocab eq? ;
267 : update-current-vocab ( manifest -- manifest )
268 [ dup [ name>> lookup-vocab ] when ] change-current-vocab ; inline
270 : compute-search-vocabs ( manifest -- search-vocab-names search-vocabs )
271 search-vocab-names>> members dup length <vector> [
272 [ push ] curry [ when* ] curry
273 [ lookup-vocab dup ] prepose filter fast-set
276 : update-search-vocabs ( manifest -- manifest )
277 dup compute-search-vocabs
278 [ >>search-vocab-names ] [ >>search-vocabs ] bi* ; inline
280 : update-qualified-vocabs ( manifest -- manifest )
281 dup qualified-vocabs>> [ update ] filter! drop ; inline
283 : update-manifest ( manifest -- manifest )
286 update-qualified-vocabs ; inline
288 M: manifest definitions-changed
289 nip update-manifest drop ;
293 : (with-manifest) ( quot manifest -- )
296 [ manifest get add-definition-observer call ]
297 [ manifest get remove-definition-observer ]
300 ] with-variable ; inline
302 : with-manifest ( quot -- )
303 <manifest> (with-manifest) ; inline
305 : with-current-manifest ( quot -- )
306 manifest get (with-manifest) ; inline