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 ] { } 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 hash-set }
27 { search-vocabs vector }
28 { qualified-vocabs vector }
29 { auto-used vector } ;
31 : <manifest> ( -- manifest )
33 HS{ } clone >>search-vocab-names
34 V{ } clone >>search-vocabs
35 V{ } clone >>qualified-vocabs
36 V{ } clone >>auto-used ;
40 [ clone ] change-search-vocab-names
41 [ clone ] change-search-vocabs
42 [ clone ] change-qualified-vocabs
43 [ clone ] change-auto-used ;
45 TUPLE: extra-words words ;
48 over extra-words? [ [ words>> ] bi@ eq? ] [ 2drop f ] if ;
50 C: <extra-words> extra-words
52 ERROR: no-word-in-vocab word vocab ;
56 : (from) ( vocab words -- vocab words words' vocab )
57 2dup swap load-vocab ;
59 : extract-words ( seq vocab -- assoc )
60 [ words>> extract-keys dup ] [ name>> ] bi
61 [ swap [ 2drop ] [ throw-no-word-in-vocab ] if ] curry assoc-each ;
63 : excluding-words ( seq vocab -- assoc )
64 [ nip words>> ] [ extract-words ] 2bi assoc-diff ;
66 : qualified-words ( prefix vocab -- assoc )
67 words>> swap [ swap [ swap ":" glue ] dip ] curry assoc-map ;
69 : (lookup) ( name assoc -- word/f )
70 at* [ dup forward-reference? [ drop f ] when ] when ;
74 : qualified-vocabs ( -- qualified-vocabs )
75 manifest get qualified-vocabs>> ;
77 : set-current-vocab ( name -- )
79 [ manifest get current-vocab<< ]
80 [ qualified-vocabs push ] bi ;
82 : with-current-vocab ( name quot -- )
83 manifest get clone manifest [
84 [ set-current-vocab ] dip call
85 ] with-variable ; inline
87 TUPLE: no-current-vocab-error ;
89 : no-current-vocab ( -- vocab )
90 no-current-vocab-error boa
91 { { "Define words in scratchpad vocabulary" "scratchpad" } }
92 throw-restarts dup set-current-vocab ;
94 : current-vocab ( -- vocab )
95 manifest get current-vocab>> [ no-current-vocab ] unless* ;
97 ERROR: unbalanced-private-declaration vocab ;
99 : begin-private ( -- )
100 current-vocab name>> ".private" ?tail
101 [ throw-unbalanced-private-declaration ]
102 [ ".private" append set-current-vocab ] if ;
105 current-vocab name>> ".private" ?tail
106 [ set-current-vocab ]
107 [ throw-unbalanced-private-declaration ] if ;
109 : using-vocab? ( vocab -- ? )
110 vocab-name manifest get search-vocab-names>> in? ;
112 : use-vocab ( vocab -- )
114 [ vocab-name "Already using ``" "'' vocabulary" surround note. ] [
116 [ [ load-vocab ] dip search-vocabs>> push ]
117 [ [ vocab-name ] dip search-vocab-names>> adjoin ]
121 : auto-use-vocab ( vocab -- )
122 [ use-vocab ] [ manifest get auto-used>> push ] bi ;
124 : auto-used? ( -- ? )
125 manifest get auto-used>> length 0 > ;
127 : unuse-vocab ( vocab -- )
130 [ [ load-vocab ] dip search-vocabs>> remove-eq! drop ]
131 [ [ vocab-name ] dip search-vocab-names>> delete ]
135 TUPLE: qualified vocab prefix words ;
137 : <qualified> ( vocab prefix -- qualified )
138 (from) qualified-words qualified boa ;
140 : add-qualified ( vocab prefix -- )
141 <qualified> qualified-vocabs push ;
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> qualified-vocabs push ;
151 TUPLE: exclude vocab names words ;
153 : <exclude> ( vocab words -- from )
154 (from) excluding-words exclude boa ;
156 : add-words-excluding ( vocab words -- )
157 <exclude> qualified-vocabs push ;
159 TUPLE: rename word vocab words ;
161 : <rename> ( word vocab new-name -- rename )
163 2dup load-vocab words>> dupd at
164 [ ] [ swap throw-no-word-in-vocab ] ?if
165 ] dip associate rename boa ;
167 : add-renamed-word ( word vocab new-name -- )
168 <rename> qualified-vocabs push ;
170 : use-words ( assoc -- )
171 <extra-words> qualified-vocabs push ;
173 : unuse-words ( assoc -- )
174 <extra-words> qualified-vocabs remove! drop ;
176 TUPLE: ambiguous-use-error words ;
178 : <ambiguous-use-error> ( words -- error restarts )
179 [ ambiguous-use-error boa ] [ word-restarts ] bi ;
183 : (vocab-search) ( name assocs -- words n )
184 [ words>> (lookup) ] with map sift dup length ;
186 : vocab-search ( name manifest -- word/f )
192 drop <ambiguous-use-error> throw-restarts
193 dup [ vocabulary>> ] [ name>> 1array ] bi add-words-from
197 : qualified-search ( name manifest -- word/f )
199 (vocab-search) 0 = [ drop f ] [ last ] if ;
203 : search-manifest ( name manifest -- word/f )
204 2dup qualified-search [ 2nip ] [ vocab-search ] if* ;
206 : search ( name -- word/f )
207 manifest get search-manifest ;
211 GENERIC: update ( search-path-elt -- valid? )
213 : trim-forgotten ( qualified-vocab -- valid? )
214 [ [ nip "forgotten" word-prop ] assoc-reject ] change-words
215 words>> assoc-empty? not ;
217 M: from update trim-forgotten ;
218 M: rename update trim-forgotten ;
219 M: extra-words update trim-forgotten ;
220 M: exclude update trim-forgotten ;
223 dup vocab>> lookup-vocab [
224 dup [ prefix>> ] [ vocab>> load-vocab ] bi qualified-words
228 M: vocab update dup name>> lookup-vocab eq? ;
230 : update-current-vocab ( manifest -- manifest )
231 [ dup [ name>> lookup-vocab ] when ] change-current-vocab ; inline
233 : compute-search-vocabs ( manifest -- search-vocab-names search-vocabs )
234 search-vocab-names>> members dup length <vector> [
235 [ push ] curry [ when* ] curry
236 [ lookup-vocab dup ] prepose filter fast-set
239 : update-search-vocabs ( manifest -- manifest )
240 dup compute-search-vocabs
241 [ >>search-vocab-names ] [ >>search-vocabs ] bi* ; inline
243 : update-qualified-vocabs ( manifest -- manifest )
244 dup qualified-vocabs>> [ update ] filter! drop ; inline
246 : update-manifest ( manifest -- manifest )
249 update-qualified-vocabs ; inline
251 M: manifest definitions-changed
252 nip update-manifest drop ;
256 : with-manifest ( quot -- )
257 <manifest> manifest [
259 [ manifest get add-definition-observer call ]
260 [ manifest get remove-definition-observer ]
264 ] with-variable ; inline