extra/lint/lint.factor

   1 ! Copyright (C) 2007, 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien arrays assocs classes.tuple.private
   4 combinators.short-circuit fry hashtables io kernel
   5 locals.backend make math namespaces prettyprint quotations
   6 sequences sequences.deep shuffle slots.private vectors vocabs
   7 words xml.data words.alias ;
   8 IN: lint
   9
  10 <PRIVATE
  11
  12 CONSTANT: manual-substitutions
  13     H{
  14         { -rot [ swap [ swap ] dip ] }
  15         { -rot [ swap swapd ] }
  16         { rot [ [ swap ] dip swap ] }
  17         { rot [ swapd swap ] }
  18         { over [ dup swap ] }
  19         { tuck [ dup -rot ] }
  20         { swapd [ [ swap ] dip ] }
  21         { 2nip [ nip nip ] }
  22         { 2drop [ drop drop ] }
  23         { 3drop [ drop drop drop ] }
  24         { pop* [ pop drop ] }
  25         { when [ [ ] if ] }
  26         { >boolean [ f = not ] }
  27     }
  28
  29 CONSTANT: trivial-defs
  30     {
  31         [ drop t ] [ drop f ]
  32         [ 2drop t ] [ 2drop f ]
  33         [ 3drop t ] [ 3drop f ]
  34         [ ">" write ] [ "/>" write ]
  35         [ length 1 - ] [ length 1 = ] [ length 1 > ]
  36         [ drop f f ] [ 2drop f f ]
  37         [ drop f f f ]
  38         [ nip f f ]
  39         [ 0 or + ]
  40         [ dup 0 > ] [ dup 0 <= ]
  41         [ dup length iota ]
  42         [ 0 swap copy ]
  43         [ dup 1 + ]
  44     }
  45
  46 : lintable-word? ( word -- ? )
  47     {
  48         [ vocabulary>> "specialized-" head? ]
  49         [ vocabulary>> "windows-messages" = ]
  50         [ alias? ]
  51     } 1|| not ;
  52
  53 : lintable-words ( -- words )
  54     all-words [ lintable-word? ] filter ;
  55
  56 : ignore-def? ( def -- ? )
  57     {
  58         ! Remove small defs
  59         [ length 2 <= ]
  60
  61         ! Remove trivial defs
  62         [ trivial-defs member? ]
  63
  64         ! Remove curry only defs
  65         [ [ \ curry = ] all? ]
  66
  67         ! Remove words with locals
  68         [ [ \ load-locals = ] any? ]
  69
  70         ! Remove numbers/t/f only defs
  71         [
  72             [ { [ number? ] [ t? ] [ f eq? ] } 1|| ] all?
  73         ]
  74
  75         ! Remove tag defs
  76         [
  77             {
  78                 [ length 3 = ]
  79                 [ first \ tag = ] [ second number? ] [ third \ eq? = ]
  80             } 1&&
  81         ]
  82
  83         ! Remove [ m n shift ]
  84         [
  85             {
  86                 [ length 3 = ]
  87                 [ first2 [ number? ] both? ] [ third \ shift = ]
  88             } 1&&
  89         ]
  90
  91         ! Remove [ layout-of n slot ]
  92         [
  93             {
  94                 [ length 3 = ]
  95                 [ first \ layout-of = ]
  96                 [ second number? ]
  97                 [ third \ slot = ]
  98             } 1&&
  99         ]
 100     } 1|| ;
 101
 102 : all-callables ( def -- seq )
 103     [ callable? ] deep-filter ;
 104
 105 : (load-definitions) ( word def hash -- )
 106     [ all-callables ] dip '[ _ push-at ] with each ;
 107
 108 : load-definitions ( words -- hash )
 109     H{ } clone [ '[ dup def>> _ (load-definitions) ] each ] keep ;
 110
 111 SYMBOL: lint-definitions
 112 SYMBOL: lint-definitions-keys
 113
 114 : reload-definitions ( -- )
 115     ! Load lintable and non-ignored definitions
 116     lintable-words load-definitions
 117     [ drop ignore-def? not ] assoc-filter
 118
 119     ! Remove words that are their own definition
 120     [ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
 121
 122     ! Add manual definitions
 123     manual-substitutions over '[ _ push-at ] assoc-each
 124
 125     ! Set globals to new values
 126     [ lint-definitions set-global ]
 127     [ keys lint-definitions-keys set-global ] bi ;
 128
 129 : find-duplicates ( -- seq )
 130     lint-definitions get-global [ nip length 1 > ] assoc-filter ;
 131
 132 GENERIC: lint ( obj -- seq )
 133
 134 M: object lint ( obj -- seq ) drop f ;
 135
 136 M: callable lint ( quot -- seq )
 137     [ lint-definitions-keys get-global ] dip '[ _ subseq? ] filter ;
 138
 139 M: word lint ( word -- seq/f )
 140     def>> all-callables [ lint ] map concat ;
 141
 142 : word-path. ( word -- )
 143     [ vocabulary>> write ":" write ] [ . ] bi ;
 144
 145 : 4bl ( -- ) bl bl bl bl ;
 146
 147 : (lint.) ( pair -- )
 148     first2 [ word-path. ] dip [
 149         [ 4bl .  "-----------------------------------" print ]
 150         [ lint-definitions get-global at [ 4bl word-path. ] each nl ] bi
 151     ] each nl ;
 152
 153 : lint. ( alist -- ) [ (lint.) ] each ;
 154
 155 GENERIC: run-lint ( obj -- obj )
 156
 157 : (trim-self) ( val key -- obj ? )
 158     lint-definitions get-global at*
 159     [ dupd remove empty? not ] [ drop f ] if ;
 160
 161 : trim-self ( seq -- newseq )
 162     [ [ (trim-self) ] filter ] assoc-map ;
 163
 164 : filter-symbols ( alist -- alist )
 165     [
 166         nip first dup lint-definitions get-global at
 167         [ first ] bi@ literalize = not
 168     ] assoc-filter ;
 169
 170 M: sequence run-lint ( seq -- seq )
 171     [ dup lint ] { } map>assoc trim-self
 172     [ second empty? not ] filter filter-symbols ;
 173
 174 M: word run-lint ( word -- seq ) 1array run-lint ;
 175
 176 PRIVATE>
 177
 178 : lint-all ( -- seq )
 179     all-words run-lint dup lint. ;
 180
 181 : lint-vocab ( vocab -- seq )
 182     words run-lint dup lint. ;
 183
 184 : lint-vocabs ( prefix -- seq )
 185     [ vocabs ] dip [ head? ] curry filter [ lint-vocab ] map ;
 186
 187 : lint-word ( word -- seq )
 188     1array run-lint dup lint. ;
 189
 190 reload-definitions