-! 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
-parser.notes ;
+USING: accessors arrays assocs combinators compiler.units
+continuations hash-sets hashtables kernel math namespaces
+parser.notes sequences sets sorting splitting vectors vocabs
+words ;
IN: vocabs.parser
-
+
ERROR: no-word-error name ;
: word-restarts ( possibilities -- restarts )
- natural-sort
- [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc ;
+ 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
+ "Defer word in current vocabulary" rot 2array
suffix ;
-
+
: <no-word-error> ( name possibilities -- error restarts )
[ drop \ no-word-error boa ] [ word-restarts-with-defer ] 2bi ;
TUPLE: manifest
current-vocab
-{ search-vocab-names hashtable }
+{ search-vocab-names hash-set }
{ search-vocabs vector }
{ qualified-vocabs vector }
-{ extra-words vector }
{ auto-used vector } ;
: <manifest> ( -- manifest )
manifest new
- H{ } clone >>search-vocab-names
+ HS{ } 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 ;
C: <extra-words> extra-words
+ERROR: no-word-in-vocab word vocab ;
+
<PRIVATE
-: clear-manifest ( -- )
- manifest get
- [ search-vocab-names>> clear-assoc ]
- [ search-vocabs>> delete-all ]
- [ qualified-vocabs>> delete-all ]
- tri ;
+: (from) ( vocab words -- vocab words words' vocab )
+ 2dup swap load-vocab ;
-: (add-qualified) ( qualified -- )
- manifest get qualified-vocabs>> push ;
+: extract-words ( seq vocab -- assoc )
+ [ words>> extract-keys dup ] [ name>> ] bi
+ [ swap [ 2drop ] [ no-word-in-vocab ] if ] curry assoc-each ;
-: (from) ( vocab words -- vocab words words' assoc )
- 2dup swap load-vocab words>> ;
+: excluding-words ( seq vocab -- assoc )
+ [ nip words>> ] [ extract-words ] 2bi assoc-diff ;
-: extract-words ( seq assoc -- assoc' )
- extract-keys dup [ [ drop ] [ no-word-error ] if ] assoc-each ;
+: 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 ;
-
-: (use-words) ( assoc -- extra-words seq )
- <extra-words> manifest get qualified-vocabs>> ;
+ at* [ dup forward-reference? [ drop f ] when ] when ;
PRIVATE>
+: qualified-vocabs ( -- qualified-vocabs )
+ manifest get qualified-vocabs>> ;
+
: set-current-vocab ( name -- )
create-vocab
- [ manifest get (>>current-vocab) ]
- [ words>> <extra-words> (add-qualified) ] bi ;
+ [ manifest get current-vocab<< ]
+ [ qualified-vocabs push ] bi ;
+
+: with-current-vocab ( name quot -- )
+ manifest get clone manifest [
+ [ set-current-vocab ] dip call
+ ] with-variable ; inline
-TUPLE: no-current-vocab ;
+TUPLE: no-current-vocab-error ;
: no-current-vocab ( -- vocab )
- \ no-current-vocab boa
+ no-current-vocab-error boa
{ { "Define words in scratchpad vocabulary" "scratchpad" } }
throw-restarts dup set-current-vocab ;
: current-vocab ( -- vocab )
manifest get current-vocab>> [ no-current-vocab ] unless* ;
+ERROR: unbalanced-private-declaration vocab ;
+
: begin-private ( -- )
- manifest get current-vocab>> vocab-name ".private" ?tail
- [ drop ] [ ".private" append set-current-vocab ] if ;
+ current-vocab name>> ".private" ?tail
+ [ unbalanced-private-declaration ]
+ [ ".private" append set-current-vocab ] if ;
: end-private ( -- )
- manifest get current-vocab>> vocab-name ".private" ?tail
- [ set-current-vocab ] [ drop ] if ;
+ current-vocab name>> ".private" ?tail
+ [ set-current-vocab ]
+ [ unbalanced-private-declaration ] if ;
: using-vocab? ( vocab -- ? )
- vocab-name manifest get search-vocab-names>> key? ;
+ vocab-name manifest get search-vocab-names>> in? ;
: use-vocab ( vocab -- )
- dup using-vocab?
- [ vocab-name "Already using ``" "'' vocabulary" surround note. ] [
+ dup using-vocab? [
+ vocab-name "Already using ``" "'' vocabulary" surround note.
+ ] [
manifest get
- [ [ load-vocab ] dip search-vocabs>> push ]
- [ [ vocab-name ] dip search-vocab-names>> conjoin ]
+ [ [ ?load-vocab ] dip search-vocabs>> push ]
+ [ [ vocab-name ] dip search-vocab-names>> adjoin ]
2bi
] if ;
: auto-use-vocab ( vocab -- )
[ 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 -- )
dup using-vocab? [
manifest get
- [ [ load-vocab ] dip search-vocabs>> delq ]
- [ [ vocab-name ] dip search-vocab-names>> delete-at ]
+ [ [ load-vocab ] dip search-vocabs>> remove-eq! drop ]
+ [ [ vocab-name ] dip search-vocab-names>> delete ]
2bi
] [ drop ] if ;
-: only-use-vocabs ( vocabs -- )
- clear-manifest [ vocab ] filter [ use-vocab ] each ;
-
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) ;
+ <qualified> qualified-vocabs push ;
TUPLE: from vocab names words ;
(from) extract-words from boa ;
: add-words-from ( vocab words -- )
- <from> (add-qualified) ;
+ <from> qualified-vocabs push ;
TUPLE: exclude vocab names words ;
: <exclude> ( vocab words -- from )
- (from) [ nip ] [ extract-words ] 2bi assoc-diff exclude boa ;
+ (from) excluding-words exclude boa ;
: add-words-excluding ( vocab words -- )
- <exclude> (add-qualified) ;
+ <exclude> qualified-vocabs push ;
TUPLE: rename word vocab words ;
: <rename> ( word vocab new-name -- rename )
- [ 2dup load-vocab words>> dupd at [ ] [ no-word-error ] ?if ] dip
- associate rename boa ;
+ [
+ 2dup load-vocab words>> dupd at
+ [ ] [ swap no-word-in-vocab ] ?if
+ ] dip associate rename boa ;
: add-renamed-word ( word vocab new-name -- )
- <rename> (add-qualified) ;
+ <rename> qualified-vocabs push ;
+
+: use-words ( assoc -- )
+ <extra-words> qualified-vocabs push ;
-: use-words ( assoc -- ) (use-words) push ;
+: unuse-words ( assoc -- )
+ <extra-words> qualified-vocabs remove! drop ;
-: unuse-words ( assoc -- ) (use-words) delete ;
+: with-words ( assoc quot -- )
+ '[ use-words @ ] over '[ _ unuse-words ] finally ; inline
-TUPLE: ambiguous-use-error words ;
+TUPLE: ambiguous-use-error name words ;
-: <ambiguous-use-error> ( words -- error restarts )
- [ \ ambiguous-use-error boa ] [ word-restarts ] bi ;
+: <ambiguous-use-error> ( name words -- error restarts )
+ [ ambiguous-use-error boa ] [ word-restarts ] bi ;
<PRIVATE
-: (vocab-search) ( name assocs -- words n )
- [ words>> (lookup) ] with map
- sift dup length ;
+: (lookup-word) ( words name vocab -- words )
+ words>> (lookup) [ suffix! ] when* ; inline
+
+: (vocab-search) ( name assocs -- words )
+ [ V{ } clone ] 2dip [ (lookup-word) ] with each ;
+
+: (vocab-search-qualified) ( words name assocs -- words )
+ [ ":" split1 swap ] dip pick [
+ [ name>> = ] with find nip [ (lookup-word) ] with when*
+ ] [
+ 3drop
+ ] if ;
+
+: (vocab-search-full) ( name assocs -- words )
+ [ (vocab-search) ] [ (vocab-search-qualified) ] 2bi ;
: vocab-search ( name manifest -- word/f )
- search-vocabs>>
- (vocab-search) {
- { 0 [ drop f ] }
- { 1 [ first ] }
+ dupd search-vocabs>> (vocab-search-full) dup length {
+ { 0 [ 2drop f ] }
+ { 1 [ first nip ] }
[
drop <ambiguous-use-error> throw-restarts
dup [ vocabulary>> ] [ name>> 1array ] bi add-words-from
} case ;
: qualified-search ( name manifest -- word/f )
- qualified-vocabs>>
- (vocab-search) 0 = [ drop f ] [ last ] if ;
+ qualified-vocabs>> (vocab-search) ?last ;
PRIVATE>
: search-manifest ( name manifest -- word/f )
- 2dup qualified-search dup [ 2nip ] [ drop vocab-search ] if ;
+ 2dup qualified-search [ 2nip ] [ vocab-search ] if* ;
: search ( name -- word/f )
- manifest get search-manifest ;
\ No newline at end of file
+ manifest get search-manifest ;
+
+<PRIVATE
+
+GENERIC: update ( search-path-elt -- valid? )
+
+: trim-forgotten ( qualified-vocab -- valid? )
+ [ [ nip "forgotten" word-prop ] assoc-reject ] 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>> lookup-vocab [
+ dup [ prefix>> ] [ vocab>> load-vocab ] bi qualified-words
+ >>words
+ ] [ drop f ] if ;
+
+M: vocab update dup name>> lookup-vocab eq? ;
+
+: update-current-vocab ( manifest -- manifest )
+ [ dup [ name>> lookup-vocab ] when ] change-current-vocab ; inline
+
+: compute-search-vocabs ( manifest -- search-vocab-names search-vocabs )
+ search-vocab-names>> members dup length <vector> [
+ [ push ] curry [ when* ] curry
+ [ lookup-vocab dup ] prepose filter fast-set
+ ] keep ; inline
+
+: update-search-vocabs ( manifest -- manifest )
+ dup compute-search-vocabs
+ [ >>search-vocab-names ] [ >>search-vocabs ] bi* ; inline
+
+: update-qualified-vocabs ( manifest -- manifest )
+ dup qualified-vocabs>> [ update ] filter! drop ; inline
+
+: update-manifest ( manifest -- manifest )
+ update-current-vocab
+ update-search-vocabs
+ update-qualified-vocabs ; inline
+
+M: manifest definitions-changed
+ nip update-manifest drop ;
+
+PRIVATE>
+
+: with-manifest ( quot -- )
+ <manifest> manifest [
+ [ call ] [
+ [ manifest get add-definition-observer call ]
+ [ manifest get remove-definition-observer ]
+ finally
+ ] if-bootstrapping
+ ] with-variable ; inline
projects / factor.git / blobdiff