! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.

USING: accessors alien arrays assocs classes
classes.tuple.private combinators.short-circuit fry hashtables
io kernel kernel.private locals.backend make math namespaces
prettyprint quotations sequences sequences.deep shuffle
slots.private vectors vocabs words words.alias ;

IN: lint

<PRIVATE

CONSTANT: manual-substitutions
    H{
        { -rot [ swap [ swap ] dip ] }
        { -rot [ swap swapd ] }
        { rot [ [ swap ] dip swap ] }
        { rot [ swapd swap ] }
        { over [ dup swap ] }
        { tuck [ dup -rot ] }
        { swapd [ [ swap ] dip ] }
        { 2nip [ nip nip ] }
        { 2drop [ drop drop ] }
        { 3drop [ drop drop drop ] }
        { pop* [ pop drop ] }
        { when [ [ ] if ] }
        { >boolean [ f = not ] }
    }

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 ] [ drop f t ] [ drop t f ] [ drop t t ]
        [ 2drop f f ] [ 2drop f t ] [ 2drop t f ] [ 2drop t t ]
        [ drop f f f ]
        [ nip f f ]
        [ 0 or + ]
        [ dup 0 > ] [ dup 0 <= ] [ dup 0 < ]
        [ over 0 > ] [ over 0 <= ] [ over 0 < ]
        [ dup length iota ]
        [ 0 swap copy ]
        [ dup 1 + ] [ drop 1 + ]
    }

: lintable-word? ( word -- ? )
    {
        [ vocabulary>> "specialized-" head? ]
        [ vocabulary>> "windows-messages" = ]
        [ alias? ]
    } 1|| not ;

: lintable-words ( -- words )
    all-words [ lintable-word? ] filter ;

: ignore-def? ( def -- ? )
    {
        ! Remove small defs
        [ length 2 <= ]

        ! Remove trivial defs
        [ trivial-defs member? ]

        ! Remove curry only defs
        [ [ \ curry = ] all? ]

        ! Remove words with locals
        [ [ \ load-locals = ] any? ]

        ! Remove numbers/t/f only defs
        [
            [ { [ number? ] [ t? ] [ f eq? ] } 1|| ] all?
        ]

        ! Remove [ tag n eq? ]
        [
            {
                [ length 3 = ]
                [ first \ tag = ] [ second number? ] [ third \ eq? = ]
            } 1&&
        ]

        ! Remove [ { foo } declare class ]
        [
            {
                [ length 3 = ]
                [ first { [ array? ] [ length 1 = ] } 1&& ]
                [ second \ declare = ]
                [ third \ class = ]
            } 1&&
        ]

        ! Remove [ m n shift ]
        [
            {
                [ length 3 = ]
                [ first2 [ number? ] both? ] [ third \ shift = ]
            } 1&&
        ]

        ! Remove [ layout-of n slot ]
        [
            {
                [ length 3 = ]
                [ first \ layout-of = ]
                [ second number? ]
                [ third \ slot = ]
            } 1&&
        ]

        ! Remove [ ... \ cdecl ]
        [
            { [ length 3 = ] [ last \ cdecl = ] } 1&&
        ]
    } 1|| ;

: all-callables ( def -- seq )
    [ { [ callable? ] [ ignore-def? not ] } 1&& ] deep-filter ;

: (load-definitions) ( word def hash -- )
    [ all-callables ] dip '[ _ push-at ] with each ;

: 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

    ! 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 )
    lint-definitions get-global [ nip length 1 > ] assoc-filter ;

GENERIC: lint ( obj -- seq )

M: object lint ( obj -- seq ) drop f ;

M: callable lint ( quot -- seq )
    [ lint-definitions-keys get-global ] dip '[ _ subseq? ] filter ;

M: word lint ( word -- seq/f )
    def>> all-callables [ lint ] map concat ;

: word-path. ( word -- )
    [ vocabulary>> write ":" write ] [ . ] bi ;

: 4bl ( -- ) bl bl bl bl ;

: (lint.) ( pair -- )
    first2 [ word-path. ] dip [
        [ 4bl .  "-----------------------------------" print ]
        [ lint-definitions get-global at [ 4bl word-path. ] each nl ] bi
    ] each nl ;

: lint. ( alist -- ) [ (lint.) ] each ;

GENERIC: run-lint ( obj -- obj )

: (trim-self) ( val key -- obj ? )
    lint-definitions get-global at*
    [ dupd remove empty? not ] [ drop f ] if ;

: trim-self ( seq -- newseq )
    [ [ (trim-self) ] filter ] assoc-map ;

: filter-symbols ( alist -- alist )
    [
        nip first dup lint-definitions get-global at
        [ first ] bi@ literalize = not
    ] assoc-filter ;

M: sequence run-lint ( seq -- seq )
    [ dup lint ] { } map>assoc trim-self
    [ second empty? not ] filter filter-symbols ;

M: word run-lint ( word -- seq ) 1array run-lint ;

PRIVATE>

: lint-all ( -- seq )
    all-words run-lint dup lint. ;

: lint-vocab ( vocab -- seq )
    words run-lint dup lint. ;

: lint-vocabs ( prefix -- seq )
    [ vocabs ] dip [ head? ] curry filter [ lint-vocab ] map ;

: lint-word ( word -- seq )
    1array run-lint dup lint. ;

reload-definitions