IN: vocabs.parser.tests
-USING: vocabs.parser tools.test eval kernel accessors ;
+USING: vocabs.parser tools.test eval kernel accessors definitions
+compiler.units words vocabs ;
[ "FROM: kernel => doesnotexist ;" eval( -- ) ]
[ error>> T{ no-word-in-vocab { word "doesnotexist" } { vocab "kernel" } } = ]
[ "RENAME: doesnotexist kernel => newname" eval( -- ) ]
[ error>> T{ no-word-in-vocab { word "doesnotexist" } { vocab "kernel" } } = ]
-must-fail-with
\ No newline at end of file
+must-fail-with
+
+: aaa ( -- ) ;
+
+[
+ [ ] [ "aaa" "vocabs.parser.tests" "uutt" add-renamed-word ] unit-test
+
+ [ ] [ "vocabs.parser.tests" dup add-qualified ] unit-test
+
+ [ aaa ] [ "uutt" search ] unit-test
+ [ aaa ] [ "vocabs.parser.tests:aaa" search ] unit-test
+
+ [ ] [ [ "bbb" "vocabs.parser.tests" create drop ] with-compilation-unit ] unit-test
+
+ [ "bbb" ] [ "vocabs.parser.tests:bbb" search name>> ] unit-test
+
+ [ ] [ [ \ aaa forget ] with-compilation-unit ] unit-test
+
+ [ ] [ [ "bbb" "vocabs.parser.tests" lookup forget ] with-compilation-unit ] unit-test
+
+ [ f ] [ "uutt" search ] unit-test
+
+ [ f ] [ "vocabs.parser.tests:aaa" search ] unit-test
+
+ [ ] [ "vocabs.parser.tests.foo" set-current-vocab ] unit-test
+
+ [ ] [ [ "bbb" current-vocab create drop ] with-compilation-unit ] unit-test
+
+ [ t ] [ "bbb" search >boolean ] unit-test
+
+ [ ] [ [ "vocabs.parser.tests.foo" forget-vocab ] with-compilation-unit ] unit-test
+
+ [ [ "bbb" current-vocab create drop ] with-compilation-unit ] [ error>> no-current-vocab? ] must-fail-with
+
+ [ begin-private ] [ error>> no-current-vocab? ] must-fail-with
+
+ [ end-private ] [ error>> no-current-vocab? ] must-fail-with
+
+ [ f ] [ "bbb" search >boolean ] unit-test
+
+] with-manifest
\ No newline at end of file
-! Copyright (C) 2007, 2009 Daniel Ehrenberg, Bruno Deferrari,
+! Copyright (C) 2007, 2010 Daniel Ehrenberg, Bruno Deferrari,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel namespaces sequences
sets strings vocabs sorting accessors arrays compiler.units
-combinators vectors splitting continuations math
+combinators vectors splitting continuations math words
parser.notes ;
IN: vocabs.parser
{ search-vocab-names hashtable }
{ search-vocabs vector }
{ qualified-vocabs vector }
-{ extra-words vector }
{ auto-used vector } ;
: <manifest> ( -- manifest )
H{ } clone >>search-vocab-names
V{ } clone >>search-vocabs
V{ } clone >>qualified-vocabs
- V{ } clone >>extra-words
V{ } clone >>auto-used ;
M: manifest clone
[ clone ] change-search-vocab-names
[ clone ] change-search-vocabs
[ clone ] change-qualified-vocabs
- [ clone ] change-extra-words
[ clone ] change-auto-used ;
TUPLE: extra-words words ;
: (from) ( vocab words -- vocab words words' vocab )
2dup swap load-vocab ;
-: extract-words ( seq vocab -- assoc' )
+: extract-words ( seq vocab -- assoc )
[ words>> extract-keys dup ] [ name>> ] bi
[ swap [ 2drop ] [ no-word-in-vocab ] if ] curry assoc-each ;
+: excluding-words ( seq vocab -- assoc )
+ [ nip words>> ] [ extract-words ] 2bi assoc-diff ;
+
+: qualified-words ( prefix vocab -- assoc )
+ words>> swap [ swap [ swap ":" glue ] dip ] curry assoc-map ;
+
: (lookup) ( name assoc -- word/f )
at dup forward-reference? [ drop f ] when ;
manifest get current-vocab>> [ no-current-vocab ] unless* ;
: begin-private ( -- )
- manifest get current-vocab>> vocab-name ".private" ?tail
+ current-vocab name>> ".private" ?tail
[ drop ] [ ".private" append set-current-vocab ] if ;
: end-private ( -- )
- manifest get current-vocab>> vocab-name ".private" ?tail
+ current-vocab name>> ".private" ?tail
[ set-current-vocab ] [ drop ] if ;
: using-vocab? ( vocab -- ? )
TUPLE: qualified vocab prefix words ;
: <qualified> ( vocab prefix -- qualified )
- 2dup
- [ load-vocab words>> ] [ CHAR: : suffix ] bi*
- [ swap [ prepend ] dip ] curry assoc-map
- qualified boa ;
+ (from) qualified-words qualified boa ;
: add-qualified ( vocab prefix -- )
<qualified> (add-qualified) ;
TUPLE: exclude vocab names words ;
: <exclude> ( vocab words -- from )
- (from) [ nip words>> ] [ extract-words ] 2bi assoc-diff exclude boa ;
+ (from) excluding-words exclude boa ;
: add-words-excluding ( vocab words -- )
<exclude> (add-qualified) ;
: search ( name -- word/f )
manifest get search-manifest ;
+
+<PRIVATE
+
+GENERIC: update ( search-path-elt -- valid? )
+
+: trim-forgotten ( qualified-vocab -- valid? )
+ [ [ nip "forgotten" word-prop not ] assoc-filter ] change-words
+ words>> assoc-empty? not ;
+
+M: from update trim-forgotten ;
+M: rename update trim-forgotten ;
+M: extra-words update trim-forgotten ;
+M: exclude update trim-forgotten ;
+
+M: qualified update
+ dup vocab>> vocab [
+ dup [ prefix>> ] [ vocab>> load-vocab ] bi qualified-words
+ >>words
+ ] [ drop f ] if ;
+
+M: vocab update dup name>> vocab eq? ;
+
+: update-manifest ( manifest -- )
+ [ dup [ name>> vocab ] when ] change-current-vocab
+ [ [ drop vocab ] assoc-filter ] change-search-vocab-names
+ dup search-vocab-names>> keys [ vocab ] V{ } map-as >>search-vocabs
+ qualified-vocabs>> [ update ] filter! drop ;
+
+M: manifest definitions-changed ( assoc manifest -- )
+ nip update-manifest ;
+
+PRIVATE>
+
+: with-manifest ( quot -- )
+ <manifest> manifest [
+ [ manifest get add-definition-observer call ]
+ [ manifest get remove-definition-observer ]
+ [ ]
+ cleanup
+ ] with-variable ; inline