Fix a smudging bug

db4
Slava Pestov 2008-02-23 22:29:29 -06:00
parent 564594c222
commit b44b334a02
10 changed files with 78 additions and 36 deletions

View File

@ -43,7 +43,7 @@ M: object uses drop f ;
: xref ( defspec -- ) dup uses crossref get add-vertex ;
: usage ( defspec -- seq ) crossref get at keys ;
: usage ( defspec -- seq ) \ f or crossref get at keys ;
GENERIC: redefined* ( defspec -- )

View File

@ -102,11 +102,13 @@ M: method-body stack-effect
! Definition protocol
M: method-spec where
dup first2 method [ method-loc ] [ second where ] ?if ;
dup first2 method [ method-word ] [ second ] ?if where ;
M: method-spec set-where first2 method set-method-loc ;
M: method-spec set-where
first2 method method-word set-where ;
M: method-spec definer drop \ M: \ ; ;
M: method-spec definer
drop \ M: \ ; ;
M: method-spec definition
first2 method dup [ method-def ] when ;
@ -116,7 +118,19 @@ M: method-spec definition
[ delete-at* ] with-methods
[ method-word forget ] [ drop ] if ;
M: method-spec forget* first2 forget-method ;
M: method-spec forget*
first2 forget-method ;
M: method-body definer
drop \ M: \ ; ;
M: method-body definition
"method" word-prop method-def ;
M: method-body forget*
"method" word-prop
{ method-specializer method-generic } get-slots
forget-method ;
: implementors* ( classes -- words )
all-words [

View File

@ -351,13 +351,18 @@ IN: temporary
<< file get parsed >> file set
: ~a ;
: ~b ~a ;
DEFER: ~b
"IN: temporary : ~b ~a ;" <string-reader>
"smudgy" parse-stream drop
: ~c ;
: ~d ;
{ H{ { ~a ~a } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
{ H{ { ~a ~a } { ~b ~b } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
{ H{ { ~d ~d } } H{ } } new-definitions set
{ H{ { ~b ~b } { ~d ~d } } H{ } } new-definitions set
[ V{ ~b } { ~a } { ~a ~c } ] [
smudged-usage
@ -365,6 +370,24 @@ IN: temporary
] unit-test
] with-scope
[
<< file get parsed >> file set
GENERIC: ~e
: ~f ~e ;
: ~g ;
{ H{ { ~e ~e } { ~f ~f } { ~g ~g } } H{ } } old-definitions set
{ H{ { ~g ~g } } H{ } } new-definitions set
[ V{ } { } { ~e ~f } ]
[ smudged-usage natural-sort ]
unit-test
] with-scope
[ ] [
"IN: temporary USE: kernel PREDICATE: object foo ( x -- y ) ;" eval
] unit-test

View File

@ -439,11 +439,12 @@ SYMBOL: interactive-vocabs
"Warning: the following definitions were removed from sources," print
"but are still referenced from other definitions:" print
nl
dup stack.
dup sorted-definitions.
nl
"The following definitions need to be updated:" print
nl
over stack.
over sorted-definitions.
nl
] when 2drop ;
: filter-moved ( assoc -- newassoc )

View File

@ -174,6 +174,12 @@ M: hook-generic synopsis*
M: method-spec synopsis*
dup definer. [ pprint-word ] each ;
M: method-body synopsis*
dup definer.
"method" word-prop dup
method-specializer pprint*
method-generic pprint* ;
M: mixin-instance synopsis*
dup definer.
dup mixin-instance-class pprint-word
@ -188,6 +194,15 @@ M: pathname synopsis* pprint* ;
[ synopsis* ] with-in
] with-string-writer ;
: synopsis-alist ( definitions -- alist )
[ dup synopsis swap ] { } map>assoc ;
: definitions. ( alist -- )
[ write-object nl ] assoc-each ;
: sorted-definitions. ( definitions -- )
synopsis-alist sort-keys definitions. ;
GENERIC: declarations. ( obj -- )
M: object declarations. drop ;
@ -253,7 +268,9 @@ M: builtin-class see-class*
natural-sort [ nl see ] each ;
: see-implementors ( class -- seq )
dup implementors [ 2array ] with map ;
dup implementors
[ method method-word ] with map
natural-sort ;
: see-class ( class -- )
dup class? [
@ -263,8 +280,9 @@ M: builtin-class see-class*
] when drop ;
: see-methods ( generic -- seq )
[ "methods" word-prop keys natural-sort ] keep
[ 2array ] curry map ;
"methods" word-prop
[ nip method-word ] { } assoc>map
natural-sort ;
M: word see
dup see-class

View File

@ -97,16 +97,8 @@ SYMBOL: file
[ ] [ file get rollback-source-file ] cleanup
] with-scope ; inline
: smart-usage ( word -- definitions )
\ f or usage [
dup method-body? [
"method" word-prop
{ method-specializer method-generic } get-slots
2array
] when
] map ;
: outside-usages ( seq -- usages )
dup [
over smart-usage [ pathname? not ] subset seq-diff
over usage
[ dup pathname? not swap where and ] subset seq-diff
] curry { } map>assoc ;

2
extra/editors/editors.factor Normal file → Executable file
View File

@ -43,7 +43,7 @@ SYMBOL: edit-hook
: fix ( word -- )
"Fixing " write dup pprint " and all usages..." print nl
dup smart-usage swap add* [
dup usage swap add* [
"Editing " write dup .
"RETURN moves on to the next usage, C+d stops." print
flush

4
extra/tools/crossref/crossref-tests.factor Normal file → Executable file
View File

@ -8,5 +8,5 @@ M: integer foo + ;
"resource:extra/tools/test/foo.factor" run-file
[ t ] [ { integer foo } \ + smart-usage member? ] unit-test
[ t ] [ \ foo smart-usage [ pathname? ] contains? ] unit-test
[ t ] [ integer \ foo method method-word \ + usage member? ] unit-test
[ t ] [ \ foo usage [ pathname? ] contains? ] unit-test

View File

@ -6,14 +6,8 @@ generic tools.completion quotations parser inspector
sorting hashtables vocabs parser source-files ;
IN: tools.crossref
: synopsis-alist ( definitions -- alist )
[ dup synopsis swap ] { } map>assoc ;
: definitions. ( alist -- )
[ write-object nl ] assoc-each ;
: usage. ( word -- )
smart-usage synopsis-alist sort-keys definitions. ;
usage sorted-definitions. ;
: words-matching ( str -- seq )
all-words [ dup word-name ] { } map>assoc completions ;

View File

@ -3,8 +3,8 @@
USING: assocs ui.tools.interactor ui.tools.listener
ui.tools.workspace help help.topics io.files io.styles kernel
models namespaces prettyprint quotations sequences sorting
source-files strings tools.completion tools.crossref tuples
ui.commands ui.gadgets ui.gadgets.editors
source-files definitions strings tools.completion tools.crossref
tuples ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
ui.gestures ui.operations vocabs words vocabs.loader
tools.browser unicode.case calendar ;
@ -93,7 +93,7 @@ M: live-search pref-dim* drop { 400 200 } ;
"Words in " rot vocab-name append show-titled-popup ;
: show-word-usage ( workspace word -- )
"" over smart-usage f <definition-search>
"" over usage f <definition-search>
"Words and methods using " rot word-name append
show-titled-popup ;