-! Copyright (C) 2007, 2008 Doug Coleman.
+! Copyright (C) 2007, 2008, 2011 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien arrays assocs classes.tuple.private
-combinators.short-circuit fry hashtables io kernel
-locals.backend make math namespaces prettyprint quotations
-sequences sequences.deep shuffle slots.private vectors vocabs
-words xml.data words.alias ;
+USING: accessors arrays assocs assocs.extras classes
+classes.tuple.private combinators.short-circuit continuations io
+kernel kernel.private locals.backend make math math.private
+namespaces prettyprint quotations sequences sequences.deep
+shuffle slots.private splitting stack-checker vocabs words
+words.alias ;
IN: lint
<PRIVATE
{ rot [ [ swap ] dip swap ] }
{ rot [ swapd swap ] }
{ over [ dup swap ] }
- { tuck [ dup -rot ] }
{ swapd [ [ swap ] dip ] }
+ { 2swap [ -roll -roll ] }
{ 2nip [ nip nip ] }
+ { 3nip [ 2nip nip ] }
+ { 4nip [ 3nip nip ] }
{ 2drop [ drop drop ] }
{ 3drop [ drop drop drop ] }
{ pop* [ pop drop ] }
CONSTANT: trivial-defs
{
- [ drop t ] [ drop f ]
- [ 2drop t ] [ 2drop f ]
- [ 3drop t ] [ 3drop f ]
- [ ">" write ] [ "/>" write ]
- [ length 1 - ] [ length 1 = ] [ length 1 > ]
- [ drop f f ] [ 2drop f f ]
- [ drop f f f ]
- [ nip f f ]
+ [ ">" write ] [ "/>" write ] [ " " write ]
[ 0 or + ]
- [ dup 0 > ] [ dup 0 <= ]
- [ dup length iota ]
+ [ dup length <iota> ]
[ 0 swap copy ]
- [ dup 1 + ]
+ [ dup length ]
+ [ 0 swap ]
+ [ 2dup = ] [ 2dup eq? ]
+ [ = not ] [ eq? not ]
+ [ boa throw ]
+ [ with each ] [ with map ]
+ [ curry filter ]
+ [ compose compose ]
+ [ empty? ] [ empty? not ]
+ [ dup empty? ] [ dup empty? not ]
+ [ 2dup both-fixnums? ]
+ [ [ drop ] prepose ]
+ [ 1 0 ? ]
}
: lintable-word? ( word -- ? )
: ignore-def? ( def -- ? )
{
! Remove small defs
- [ length 2 <= ]
+ [ length 1 <= ]
! Remove trivial defs
[ trivial-defs member? ]
! Remove words with locals
[ [ \ load-locals = ] any? ]
+ ! Remove stuff with wrappers
+ [ [ wrapper? ] any? ]
+
+ ! Remove trivial math
+ [ [ { [ number? ] [ { + - / * /i /f >integer } member? ] } 1|| ] all? ]
+
+ ! Remove more trival defs
+ [
+ {
+ [ length 2 = ]
+ [ first2 [ word? ] either? ]
+ [ first2 [ { dip dup over swap drop } member? ] either? ]
+ } 1&&
+ ]
+
+ ! Remove [ V{ } clone ] and related
+ [
+ {
+ [ length 2 = ]
+ [ first { [ sequence? ] [ assoc? ] } 1|| ]
+ [ second { clone clone-like like assoc-like make } member? ]
+ } 1&&
+ ]
+
+ ! Remove [ foo get ] and related
+ [
+ {
+ [ length 2 = ]
+ [ first word? ]
+ [ second { get get-global , % } member? ]
+ } 1&&
+ ]
+
+ ! Remove [ first second ] and related
+ [
+ {
+ [ length 2 = ]
+ [ first { first second third } member? ]
+ [ second { first second third } member? ]
+ } 1&&
+ ]
+
+ ! Remove [ [ trivial ] if ] and related
+ [
+ {
+ [ length 2 = ]
+ [ first { [ quotation? ] [ ignore-def? ] } 1&& ]
+ [ second { if if* unless unless* when when* curry } member? ]
+ } 1&&
+ ]
+
+ ! Remove [ n - ] and related
+ [
+ {
+ [ length 2 = ]
+ [ first { [ number? ] [ boolean? ] } 1|| ]
+ [ second { + - / * < <= = >= > shift bitand bitor bitxor eq? } member? ]
+ } 1&&
+ ]
+
+ ! Remove [ dup 0 > ] and related
+ [
+ {
+ [ length 3 = ]
+ [ first { dup over } member? ]
+ [ second number? ]
+ [ third { + - / * < <= = >= > } member? ]
+ } 1&&
+ ]
+
+ ! Remove [ drop f f ] and related
+ [
+ {
+ [ length 4 <= ]
+ [ first { drop 2drop 3drop nip 2nip 3nip 4nip } member? ]
+ [ rest-slice [ boolean? ] all? ]
+ } 1&&
+ ]
+
+ ! Remove [ length 1 = ] and related
+ [
+ {
+ [ length 3 = ]
+ [ first \ length = ]
+ [ second number? ]
+ [ third { + - / * < <= = >= > } member? ]
+ } 1&&
+ ]
+
+ ! Remove [ dup length 1 = ] and related
+ [
+ {
+ [ length 4 = ]
+ [ first { dup over } member? ]
+ [ second \ length = ]
+ [ third number? ]
+ [ fourth { + - / * < <= = >= > } member? ]
+ } 1&&
+ ]
+
! Remove numbers/t/f only defs
[
- [ { [ number? ] [ t? ] [ f eq? ] } 1|| ] all?
+ [ { [ number? ] [ boolean? ] } 1|| ] all?
]
- ! Remove tag defs
+ ! Remove [ tag n eq? ]
[
{
[ length 3 = ]
} 1&&
]
+ ! Remove [ { foo } declare class-of ]
+ [
+ {
+ [ length 3 = ]
+ [ first { [ array? ] [ length 1 = ] } 1&& ]
+ [ second \ declare = ]
+ [ third \ class-of = ]
+ } 1&&
+ ]
+
! Remove [ m n shift ]
[
{
} 1|| ;
: all-callables ( def -- seq )
- [ callable? ] deep-filter ;
+ [ { [ callable? ] [ ignore-def? not ] } 1&& ] deep-filter ;
: (load-definitions) ( word def hash -- )
- [ all-callables ] dip '[ _ push-at ] with each ;
+ [ all-callables ] dip push-at-each ;
: load-definitions ( words -- hash )
H{ } clone [ '[ dup def>> _ (load-definitions) ] each ] keep ;
: 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
+ [ [ [ def>> ] [ 1quotation ] bi = ] reject ] assoc-map
! Add manual definitions
manual-substitutions over '[ _ push-at ] assoc-each
M: object lint ( obj -- seq ) drop f ;
M: callable lint ( quot -- seq )
- [ lint-definitions-keys get-global ] dip '[ _ subseq? ] filter ;
+ lint-definitions-keys get-global [ subseq-index? ] with filter ;
M: word lint ( word -- seq/f )
- def>> all-callables [ lint ] map concat ;
+ def>> [ callable? ] deep-filter [ lint ] map concat ;
: word-path. ( word -- )
[ vocabulary>> write ":" write ] [ . ] bi ;
] assoc-filter ;
M: sequence run-lint ( seq -- seq )
- [ dup lint ] { } map>assoc trim-self
- [ second empty? not ] filter filter-symbols ;
+ [ lint ] zip-with trim-self
+ [ second empty? ] reject filter-symbols ;
M: word run-lint ( word -- seq ) 1array run-lint ;
PRIVATE>
+: find-swap/swap ( word -- ? )
+ def>> [ callable? ] deep-filter
+ [
+ {
+ [ [ \ swap = ] count 2 >= ]
+ [
+ { swap } split rest but-last
+ [ [ infer ] [ 2drop ( -- ) ] recover ( x -- x ) = ] any?
+ ]
+ } 1&&
+ ] any? ;
+
+: find-redundant-word-props ( -- seq )
+ all-words [
+ {
+ [ { [ foldable? ] [ flushable? ] } 1|| ]
+ [ inline? ]
+ } 1&&
+ ] filter ;
+
: lint-all ( -- seq )
all-words run-lint dup lint. ;
: lint-vocab ( vocab -- seq )
- words run-lint dup lint. ;
+ vocab-words run-lint dup lint. ;
: lint-vocabs ( prefix -- seq )
- [ vocabs ] dip [ head? ] curry filter [ lint-vocab ] map ;
+ [ loaded-vocab-names ] dip [ head? ] curry filter [ lint-vocab ] map ;
: lint-word ( word -- seq )
1array run-lint dup lint. ;
projects / factor.git / blobdiff