steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

lint: cleanup, deep compare, print clickable words.

db4
John Benediktsson 2011-10-16 13:01:36 -07:00
parent 6f1c44b46d
commit ea4240cea0
2 changed files with 106 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
extra/lint/lint-tests.factor
View File

@ -1,4 +1,4 @@
USING: io lint kernel math tools.test ; USING: io lint kernel math sequences tools.test ;
IN: lint.tests IN: lint.tests
! Don't write code like this ! Don't write code like this
@ -6,6 +6,10 @@ IN: lint.tests
[ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test [ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test
: lint3 ( a b -- b a b ) dup -rot ; ! tuck : lint2 ( a b -- b a b ) dup -rot ; ! tuck
[ { { lint3 { [ dup -rot ] } } } ] [ \ lint3 lint-word ] unit-test [ { { lint2 { [ dup -rot ] } } } ] [ \ lint2 lint-word ] unit-test
: lint3 ( seq -- seq ) [ 0 swap nth 1 + ] map ;
[ { { lint3 { [ 0 swap nth ] } } } ] [ \ lint3 lint-word ] unit-test

187
extra/lint/lint.factor
View File

@ -1,19 +1,16 @@
! Copyright (C) 2007, 2008 Doug Coleman. ! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien arrays assocs combinators.short-circuit USING: accessors alien arrays assocs classes.tuple.private
fry hashtables io kernel math namespaces prettyprint quotations combinators.short-circuit fry hashtables io kernel
locals.backend make math namespaces prettyprint quotations
sequences sequences.deep shuffle slots.private vectors vocabs sequences sequences.deep shuffle slots.private vectors vocabs
words xml.data words.alias ; words xml.data words.alias ;
IN: lint IN: lint
SYMBOL: lint-definitions <PRIVATE
SYMBOL: lint-definitions-keys
: set-hash-vector ( val key hash -- ) CONSTANT: manual-substitutions
2dup at -rot [ ?push ] 2dip set-at ; H{
: manual-substitutions ( hash -- )
{
{ -rot [ swap [ swap ] dip ] } { -rot [ swap [ swap ] dip ] }
{ -rot [ swap swapd ] } { -rot [ swap swapd ] }
{ rot [ [ swap ] dip swap ] } { rot [ [ swap ] dip swap ] }
@ -27,91 +24,107 @@ SYMBOL: lint-definitions-keys
{ pop* [ pop drop ] } { pop* [ pop drop ] }
{ when [ [ ] if ] } { when [ [ ] if ] }
{ >boolean [ f = not ] } { >boolean [ f = not ] }
} swap '[ first2 _ set-hash-vector ] each ; }
CONSTANT: trivial-defs CONSTANT: trivial-defs
{ {
[ drop ] [ 2drop ] [ 2array ] [ drop t ] [ drop f ]
[ bitand ] [ 2drop t ] [ 2drop f ]
[ . ] [ 3drop t ] [ 3drop f ]
[ new ]
[ get ]
[ "" ]
[ t ] [ f ]
[ { } ]
[ drop t ] [ drop f ] [ 2drop t ] [ 2drop f ]
[ cdecl ]
[ first ] [ second ] [ third ] [ fourth ]
[ ">" write ] [ "/>" write ] [ ">" write ] [ "/>" write ]
[ length 1 - ] [ length 1 = ] [ length 1 > ]
[ drop f f ] [ 2drop f f ]
[ drop f f f ]
[ nip f f ]
[ 0 or + ]
[ dup 0 > ] [ dup 0 <= ]
[ dup length iota ]
[ 0 swap copy ]
[ dup 1 + ]
} }
! ! Add definitions : lintable-word? ( word -- ? )
H{ } clone lint-definitions set-global {
[ vocabulary>> "specialized-" head? ]
[ vocabulary>> "windows-messages" = ]
[ alias? ]
} 1|| not ;
all-words [ : lintable-words ( -- words )
dup def>> dup callable? all-words [ lintable-word? ] filter ;
[ lint-definitions get-global set-hash-vector ] [ drop ] if
] each
! ! Remove definitions : ignore-def? ( def -- ? )
{
! Remove small defs
[ length 2 <= ]
! Remove empty word defs ! Remove trivial defs
lint-definitions get-global [ drop empty? not ] assoc-filter [ trivial-defs member? ]
! Remove constants [ 1 ] ! Remove curry only defs
[ drop { [ length 1 = ] [ first number? ] } 1&& not ] assoc-filter [ [ \ curry = ] all? ]
! Remove words that are their own definition ! Remove words with locals
[ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map [ [ \ load-locals = ] any? ]
! Remove specialized* ! Remove numbers/t/f only defs
[ nip [ vocabulary>> "specialized-" head? ] any? not ] assoc-filter [
[ { [ number? ] [ t? ] [ f eq? ] } 1|| ] all?
]
[ nip [ vocabulary>> "windows.messages" = ] any? not ] assoc-filter ! Remove tag defs
[
[ nip [ alias? ] any? not ] assoc-filter {
! Remove trivial defs
[ drop trivial-defs member? not ] assoc-filter
! Remove numbers only defs
[ drop [ number? ] all? not ] assoc-filter
! Remove curry only defs
[ drop [ \ curry = ] all? not ] assoc-filter
! Remove tag defs
[
drop {
[ length 3 = ] [ length 3 = ]
[ first \ tag = ] [ second number? ] [ third \ eq? = ] [ first \ tag = ] [ second number? ] [ third \ eq? = ]
} 1&& not } 1&&
] assoc-filter ]
[ ! Remove [ m n shift ]
drop { [
[ [ wrapper? ] deep-any? ] {
[ [ hashtable? ] deep-any? ] [ length 3 = ]
} 1|| not [ first2 [ number? ] both? ] [ third \ shift = ]
] assoc-filter } 1&&
]
! Remove n m shift defs ! Remove [ layout-of n slot ]
[ [
drop dup length 3 = [ {
[ first2 [ number? ] both? ] [ length 3 = ]
[ third \ shift = ] bi and not [ first \ layout-of = ]
] [ drop t ] if [ second number? ]
] assoc-filter [ third \ slot = ]
} 1&&
]
} 1|| ;
! Remove [ n slot ] : all-callables ( def -- seq )
[ [ callable? ] deep-filter ;
drop dup length 2 =
[ first2 [ number? ] [ \ slot = ] bi* and not ] [ drop t ] if
] assoc-filter
dup manual-substitutions : (load-definitions) ( word def hash -- )
[ all-callables ] dip '[ _ push-at ] with each ;
[ lint-definitions set-global ] [ keys lint-definitions-keys set-global ] bi : load-definitions ( words -- hash )
H{ } clone [ '[ dup def>> _ (load-definitions) ] each ] keep ;
SYMBOL: lint-definitions
SYMBOL: lint-definitions-keys
: reload-definitions ( -- )
! Load lintable and non-ignored definitions
lintable-words load-definitions
[ drop ignore-def? not ] assoc-filter
! Remove words that are their own definition
[ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
! Add manual definitions
manual-substitutions over '[ _ push-at ] assoc-each
! Set globals to new values
[ lint-definitions set-global ]
[ keys lint-definitions-keys set-global ] bi ;
: find-duplicates ( -- seq ) : find-duplicates ( -- seq )
lint-definitions get-global [ nip length 1 > ] assoc-filter ; lint-definitions get-global [ nip length 1 > ] assoc-filter ;
@ -120,17 +133,14 @@ GENERIC: lint ( obj -- seq )
M: object lint ( obj -- seq ) drop f ; M: object lint ( obj -- seq ) drop f ;
: subseq/member? ( subseq/member seq -- ? )
{ [ start ] [ member? ] } 2|| ;
M: callable lint ( quot -- seq ) M: callable lint ( quot -- seq )
[ lint-definitions-keys get-global ] dip '[ _ subseq/member? ] filter ; [ lint-definitions-keys get-global ] dip '[ _ subseq? ] filter ;
M: word lint ( word -- seq ) M: word lint ( word -- seq/f )
def>> dup callable? [ lint ] [ drop f ] if ; def>> all-callables [ lint ] map concat ;
: word-path. ( word -- ) : word-path. ( word -- )
[ vocabulary>> ] [ name>> ] bi ":" glue print ; [ vocabulary>> write ":" write ] [ . ] bi ;
: 4bl ( -- ) bl bl bl bl ; : 4bl ( -- ) bl bl bl bl ;
@ -138,7 +148,7 @@ M: word lint ( word -- seq )
first2 [ word-path. ] dip [ first2 [ word-path. ] dip [
[ 4bl . "-----------------------------------" print ] [ 4bl . "-----------------------------------" print ]
[ lint-definitions get-global at [ 4bl word-path. ] each nl ] bi [ lint-definitions get-global at [ 4bl word-path. ] each nl ] bi
] each nl nl ; ] each nl ;
: lint. ( alist -- ) [ (lint.) ] each ; : lint. ( alist -- ) [ (lint.) ] each ;
@ -163,11 +173,18 @@ M: sequence run-lint ( seq -- seq )
M: word run-lint ( word -- seq ) 1array run-lint ; M: word run-lint ( word -- seq ) 1array run-lint ;
: lint-all ( -- seq ) all-words run-lint dup lint. ; PRIVATE>
: lint-vocab ( vocab -- seq ) words run-lint dup lint. ; : lint-all ( -- seq )
all-words run-lint dup lint. ;
: lint-vocab ( vocab -- seq )
words run-lint dup lint. ;
: lint-vocabs ( prefix -- seq ) : lint-vocabs ( prefix -- seq )
[ vocabs ] dip [ head? ] curry filter [ lint-vocab ] map ; [ vocabs ] dip [ head? ] curry filter [ lint-vocab ] map ;
: lint-word ( word -- seq ) 1array run-lint dup lint. ; : lint-word ( word -- seq )
1array run-lint dup lint. ;
reload-definitions