Better presentation for ambiguous-use-error, fix ui.tools.listener now that 'search' can throw, make USE: and UNUSE: ignore dupes

db4
Slava Pestov 2009-05-16 09:34:42 -05:00
parent 93509cdcec
commit 90560d3959
4 changed files with 69 additions and 24 deletions

View File

@ -251,8 +251,15 @@ M: already-disposed summary drop "Attempting to operate on disposed object" ;
M: no-current-vocab summary M: no-current-vocab summary
drop "Not in a vocabulary; IN: form required" ; drop "Not in a vocabulary; IN: form required" ;
M: no-word-error error. M: no-word-error summary
"No word named ``" write name>> write "'' found in current vocabulary search path" print ; name>> "No word named ``" "'' found in current vocabulary search path" surround ;
M: no-word-error error. summary print ;
M: ambiguous-use-error summary
words>> first name>> "More than one vocabulary defines a word named ``" "''" surround ;
M: ambiguous-use-error error. summary print ;
M: staging-violation summary M: staging-violation summary
drop drop

View File

@ -55,7 +55,9 @@ M: vocab-completion (word-at-caret)
drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ; drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ;
M: word-completion (word-at-caret) M: word-completion (word-at-caret)
manifest>> dup [ search-manifest ] [ 2drop f ] if ; manifest>> dup [
'[ _ _ search-manifest ] [ drop f ] recover
] [ 2drop f ] if ;
M: char-completion (word-at-caret) M: char-completion (word-at-caret)
2drop f ; 2drop f ;

View File

@ -609,3 +609,15 @@ EXCLUDE: qualified.tests.bar => x ;
[ t ] [ [ t ] [
"z" "parser.tests.forward-ref-3" lookup def>> [ vocabulary>> ] map all-equal? "z" "parser.tests.forward-ref-3" lookup def>> [ vocabulary>> ] map all-equal?
] unit-test ] unit-test
[ [ dup ] ] [
"USE: kernel dup" <string-reader> "unuse-test" parse-stream
] unit-test
[
"dup" <string-reader> "unuse-test" parse-stream
] [ error>> error>> error>> no-word-error? ] must-fail-with
[
"USE: kernel UNUSE: kernel dup" <string-reader> "unuse-test" parse-stream
] [ error>> error>> error>> no-word-error? ] must-fail-with

View File

@ -8,8 +8,21 @@ IN: vocabs.parser
ERROR: no-word-error name ; ERROR: no-word-error name ;
: word-restarts ( possibilities -- restarts )
natural-sort
[ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc ;
: word-restarts-with-defer ( name possibilities -- restarts )
word-restarts
swap "Defer word in current vocabulary" swap 2array
suffix ;
: <no-word-error> ( name possibilities -- error restarts )
[ drop \ no-word-error boa ] [ word-restarts-with-defer ] 2bi ;
TUPLE: manifest TUPLE: manifest
current-vocab current-vocab
{ search-vocab-names hashtable }
{ search-vocabs vector } { search-vocabs vector }
{ qualified-vocabs vector } { qualified-vocabs vector }
{ extra-words vector } { extra-words vector }
@ -17,6 +30,7 @@ current-vocab
: <manifest> ( -- manifest ) : <manifest> ( -- manifest )
manifest new manifest new
H{ } clone >>search-vocab-names
V{ } clone >>search-vocabs V{ } clone >>search-vocabs
V{ } clone >>qualified-vocabs V{ } clone >>qualified-vocabs
V{ } clone >>extra-words V{ } clone >>extra-words
@ -24,6 +38,7 @@ current-vocab
M: manifest clone M: manifest clone
call-next-method call-next-method
[ clone ] change-search-vocab-names
[ clone ] change-search-vocabs [ clone ] change-search-vocabs
[ clone ] change-qualified-vocabs [ clone ] change-qualified-vocabs
[ clone ] change-extra-words [ clone ] change-extra-words
@ -40,12 +55,10 @@ C: <extra-words> extra-words
: clear-manifest ( -- ) : clear-manifest ( -- )
manifest get manifest get
[ search-vocab-names>> clear-assoc ]
[ search-vocabs>> delete-all ] [ search-vocabs>> delete-all ]
[ qualified-vocabs>> delete-all ] [ qualified-vocabs>> delete-all ]
bi ; tri ;
: (use-vocab) ( vocab -- vocab seq )
load-vocab manifest get search-vocabs>> ;
: (add-qualified) ( qualified -- ) : (add-qualified) ( qualified -- )
manifest get qualified-vocabs>> push ; manifest get qualified-vocabs>> push ;
@ -87,19 +100,33 @@ TUPLE: no-current-vocab ;
manifest get current-vocab>> vocab-name ".private" ?tail manifest get current-vocab>> vocab-name ".private" ?tail
[ set-current-vocab ] [ drop ] if ; [ set-current-vocab ] [ drop ] if ;
: use-vocab ( vocab -- ) (use-vocab) push ; : using-vocab? ( vocab -- ? )
vocab-name manifest get search-vocab-names>> key? ;
: use-vocab ( vocab -- )
dup using-vocab?
[ drop ] [
manifest get
[ [ vocab-name ] dip search-vocab-names>> conjoin ]
[ [ load-vocab ] dip search-vocabs>> push ]
2bi
] if ;
: auto-use-vocab ( vocab -- ) : auto-use-vocab ( vocab -- )
[ use-vocab ] [ manifest get auto-used>> push ] bi ; [ use-vocab ] [ manifest get auto-used>> push ] bi ;
: auto-used? ( -- ? ) manifest get auto-used>> length 0 > ; : auto-used? ( -- ? ) manifest get auto-used>> length 0 > ;
: unuse-vocab ( vocab -- ) (use-vocab) delq ; : unuse-vocab ( vocab -- )
dup using-vocab? [
manifest get
[ [ vocab-name ] dip search-vocab-names>> delete-at ]
[ [ load-vocab ] dip search-vocabs>> delq ]
2bi
] [ drop ] if ;
: only-use-vocabs ( vocabs -- ) : only-use-vocabs ( vocabs -- )
clear-manifest clear-manifest [ vocab ] filter [ use-vocab ] each ;
[ vocab ] V{ } map-as sift
manifest get search-vocabs>> push-all ;
TUPLE: qualified vocab prefix words ; TUPLE: qualified vocab prefix words ;
@ -141,7 +168,10 @@ TUPLE: rename word vocab words ;
: unuse-words ( assoc -- ) (use-words) delete ; : unuse-words ( assoc -- ) (use-words) delete ;
ERROR: ambiguous-use-error words ; TUPLE: ambiguous-use-error words ;
: <ambiguous-use-error> ( words -- error restarts )
[ \ ambiguous-use-error boa ] [ word-restarts ] bi ;
<PRIVATE <PRIVATE
@ -154,7 +184,10 @@ ERROR: ambiguous-use-error words ;
(vocab-search) { (vocab-search) {
{ 0 [ drop f ] } { 0 [ drop f ] }
{ 1 [ first ] } { 1 [ first ] }
[ drop ambiguous-use-error ] [
drop <ambiguous-use-error> throw-restarts
dup [ vocabulary>> ] [ name>> 1array ] bi add-words-from
]
} case ; } case ;
: qualified-search ( name manifest -- word/f ) : qualified-search ( name manifest -- word/f )
@ -168,12 +201,3 @@ PRIVATE>
: search ( name -- word/f ) : search ( name -- word/f )
manifest get search-manifest ; manifest get search-manifest ;
: word-restarts ( name possibilities -- restarts )
natural-sort
[ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc
swap "Defer word in current vocabulary" swap 2array
suffix ;
: <no-word-error> ( name possibilities -- error restarts )
[ drop \ no-word-error boa ] [ word-restarts ] 2bi ;