Paste: tool to trim using lists
Author: | erg |
Mode: | factor |
Date: | Thu, 20 Jan 2022 01:35:52 |
Plain Text |
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
natural-sort [
[ vocabulary>> "Use the " " vocabulary" surround ] keep
] { } map>assoc ;
: word-restarts-with-defer
word-restarts
"Defer word in current vocabulary" rot 2array
suffix ;
: <no-word-error>
[ drop \ no-word-error boa ] [ word-restarts-with-defer ] 2bi ;
TUPLE: manifest
current-vocab
{ search-vocab-names hash-set }
{ search-vocabs vector }
{ qualified-vocabs vector }
{ auto-used vector }
{ actually-used-vocab-names hash-set }
final-vocab-names ;
: <manifest>
manifest new
HS{ } clone >>search-vocab-names
V{ } clone >>search-vocabs
V{ } clone >>qualified-vocabs
V{ } clone >>auto-used
HS{ } clone >>actually-used-vocab-names
V{ } clone >>final-vocab-names ;
M: manifest clone
call-next-method
[ clone ] change-search-vocab-names
[ clone ] change-search-vocabs
[ clone ] change-qualified-vocabs
[ clone ] change-auto-used
[ clone ] change-actually-used-vocab-names
[ clone ] change-final-vocab-names ;
TUPLE: extra-words words ;
M: extra-words equal?
over extra-words? [ [ words>> ] bi@ eq? ] [ 2drop f ] if ;
C: <extra-words> extra-words
ERROR: no-word-in-vocab word vocab ;
<PRIVATE
: (from)
2dup swap load-vocab ;
: extract-words
[ words>> extract-keys dup ] [ name>> ] bi
[ swap [ 2drop ] [ no-word-in-vocab ] if ] curry assoc-each ;
: excluding-words
[ nip words>> ] [ extract-words ] 2bi assoc-diff ;
: qualified-words
words>> swap [ swap [ swap ":" glue ] dip ] curry assoc-map ;
: (lookup)
at* [ dup forward-reference? [ drop f ] when ] when ;
PRIVATE>
: qualified-vocabs
manifest get qualified-vocabs>> ;
: set-current-vocab
create-vocab
[ manifest get current-vocab<< ]
[ qualified-vocabs push ] bi ;
: with-current-vocab
manifest get clone manifest [
[ set-current-vocab ] dip call
] with-variable ; inline
TUPLE: no-current-vocab-error ;
: no-current-vocab
no-current-vocab-error boa
{ { "Define words in scratchpad vocabulary" "scratchpad" } }
throw-restarts dup set-current-vocab ;
: current-vocab
manifest get current-vocab>> [ no-current-vocab ] unless* ;
ERROR: unbalanced-private-declaration vocab ;
: begin-private
current-vocab name>> ".private" ?tail
[ unbalanced-private-declaration ]
[ ".private" append set-current-vocab ] if ;
: end-private
current-vocab name>> ".private" ?tail
[ set-current-vocab ]
[ unbalanced-private-declaration ] if ;
: using-vocab?
vocab-name manifest get search-vocab-names>> in? ;
: use-vocab
dup using-vocab? [
vocab-name "Already using ``" "'' vocabulary" surround note.
] [
manifest get
[ [ ?load-vocab ] dip search-vocabs>> push ]
[ [ vocab-name ] dip search-vocab-names>> adjoin ]
2bi
] if ;
: auto-use-vocab
[ use-vocab ] [ manifest get auto-used>> push ] bi ;
: auto-used?
manifest get auto-used>> length 0 > ;
: unuse-vocab
dup using-vocab? [
manifest get
[ [ load-vocab ] dip search-vocabs>> remove-eq! drop ]
[ [ vocab-name ] dip search-vocab-names>> delete ]
[
[ vocab-name ] dip qualified-vocabs>> [
dup extra-words? [ 2drop f ] [
dup vocab? [ vocab>> ] unless vocab-name =
] if
] with reject! drop
] 2tri
] [ drop ] if ;
TUPLE: qualified vocab prefix words ;
: <qualified>
(from) qualified-words qualified boa ;
: add-qualified
<qualified> qualified-vocabs push ;
TUPLE: from vocab names words ;
: <from>
(from) extract-words from boa ;
: add-words-from
<from> qualified-vocabs push ;
TUPLE: exclude vocab names words ;
: <exclude>
(from) excluding-words exclude boa ;
: add-words-excluding
<exclude> qualified-vocabs push ;
TUPLE: rename word vocab words ;
: <rename>
[
2dup load-vocab words>> dupd at
[ ] [ swap no-word-in-vocab ] ?if
] dip associate rename boa ;
: add-renamed-word
<rename> qualified-vocabs push ;
: use-words
<extra-words> qualified-vocabs push ;
: unuse-words
<extra-words> qualified-vocabs remove! drop ;
DEFER: with-words
<PRIVATE
: ?restart-with-words
dup condition? [
[ error>> ]
[ restarts>> rethrow-restarts ]
[ continuation>> '[ _ _ continue-with ] with-words ] tri
] [ nip rethrow ] if ;
PRIVATE>
: with-words
[ over '[ _ use-words @ _ unuse-words ] ]
[ drop dup '[ _ unuse-words _ swap ?restart-with-words ] ]
2bi recover ; inline
TUPLE: ambiguous-use-error name words ;
: <ambiguous-use-error>
[ ambiguous-use-error boa ] [ word-restarts ] bi ;
<PRIVATE
: (lookup-word)
words>> (lookup) [ suffix! ] when* ; inline
: (vocab-search)
[ V{ } clone ] 2dip [ (lookup-word) ] with each ;
: (vocab-search-qualified)
[ ":" split1 swap ] dip pick [
[ name>> = ] with find nip [ (lookup-word) ] with when*
] [
3drop
] if ;
: (vocab-search-full)
[ (vocab-search) ] [ (vocab-search-qualified) ] 2bi ;
: vocab-search
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
qualified-vocabs>> (vocab-search) ?last ;
PRIVATE>
: search-manifest
[ 2dup qualified-search [ 2nip ] [ vocab-search ] if* ]
keep over [ vocabulary>> swap actually-used-vocab-names>> adjoin ] [ drop ] if* ;
: search
manifest get search-manifest ;
<PRIVATE
GENERIC: update
: trim-forgotten
[ [ 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
[ dup [ name>> lookup-vocab ] when ] change-current-vocab ; inline
: compute-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
dup compute-search-vocabs
[ >>search-vocab-names ] [ >>search-vocabs ] bi* ; inline
: update-qualified-vocabs
dup qualified-vocabs>> [ update ] filter! drop ; inline
: update-manifest
update-current-vocab
update-search-vocabs
update-qualified-vocabs ; inline
M: manifest definitions-changed
nip update-manifest drop ;
PRIVATE>
SYMBOL: print-use-hook
print-use-hook [ [ ] ] initialize
USE: io
USE: prettyprint
: (with-manifest)
manifest [
[ call ] [
[ manifest get add-definition-observer call ]
[ manifest get remove-definition-observer ]
finally
] if-bootstrapping
manifest get actually-used-vocab-names>>
manifest get current-vocab>> [ name>> over delete ] when*
manifest get current-vocab>> [ name>> ".private" append over delete ] when*
manifest get auto-used>> over adjoin-all
members "syntax" swap remove f swap remove manifest get final-vocab-names<<
manifest get [ search-vocab-names>> ] [ actually-used-vocab-names>> ] bi diff
manifest get auto-used>> diff
f over delete
"syntax" over delete
manifest get current-vocab>> [ name>> over delete ] when*
manifest get current-vocab>> [ name>> ".private" append over delete ] when*
dup cardinality 0 =
[
drop
auto-used? [
print-use-hook get call
] when
] [
manifest get current-vocab>> name>>
"Vocab " " did not use: " surround write ...
print-use-hook get call
] if
] with-variable ; inline
: with-manifest
<manifest> (with-manifest) ; inline
: with-current-manifest
manifest get (with-manifest) ; inline
Author: | erg |
Mode: | factor |
Date: | Thu, 20 Jan 2022 02:02:54 |
Plain Text |
: (pprint-manifest
[
[ final-vocab-names>> [ '[ _ pprint-using ] , ] unless-empty ]
[ qualified-vocabs>> filter-interesting [ '[ _ pprint-qualified ] , ] each ]
[ current-vocab>> [ '[ _ pprint-in ] , ] when* ]
tri
] { } make ;
New Annotation