extra/lint/lint.factor

   1 ! Copyright (C) 2007, 2008, 2011 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: accessors alien arrays assocs classes
   5 classes.tuple.private combinators.short-circuit continuations
   6 fry hashtables io kernel kernel.private locals.backend make math
   7 math.private namespaces prettyprint quotations sequences
   8 sequences.deep shuffle slots.private splitting stack-checker
   9 vectors vocabs words words.alias ;
  10
  11 IN: lint
  12
  13 <PRIVATE
  14
  15 CONSTANT: manual-substitutions
  16     H{
  17         { -rot [ swap [ swap ] dip ] }
  18         { -rot [ swap swapd ] }
  19         { rot [ [ swap ] dip swap ] }
  20         { rot [ swapd swap ] }
  21         { over [ dup swap ] }
  22         { swapd [ [ swap ] dip ] }
  23         { 2nip [ nip nip ] }
  24         { 2drop [ drop drop ] }
  25         { 3drop [ drop drop drop ] }
  26         { pop* [ pop drop ] }
  27         { when [ [ ] if ] }
  28         { >boolean [ f = not ] }
  29     }
  30
  31 CONSTANT: trivial-defs
  32     {
  33         [ ">" write ] [ "/>" write ] [ " " write ]
  34         [ 0 or + ]
  35         [ dup length iota ]
  36         [ 0 swap copy ]
  37         [ dup length ]
  38         [ 0 swap ]
  39         [ 2dup = ] [ 2dup eq? ]
  40         [ = not ] [ eq? not ]
  41         [ boa throw ]
  42         [ with each ] [ with map ]
  43         [ curry filter ]
  44         [ compose compose ]
  45         [ empty? ] [ empty? not ]
  46         [ dup empty? ] [ dup empty? not ]
  47         [ 2dup both-fixnums? ]
  48         [ [ drop ] prepose ]
  49         [ 1 0 ? ]
  50     }
  51
  52 : lintable-word? ( word -- ? )
  53     {
  54         [ vocabulary>> "specialized-" head? ]
  55         [ vocabulary>> "windows-messages" = ]
  56         [ alias? ]
  57     } 1|| not ;
  58
  59 : lintable-words ( -- words )
  60     all-words [ lintable-word? ] filter ;
  61
  62 : ignore-def? ( def -- ? )
  63     {
  64         ! Remove small defs
  65         [ length 1 <= ]
  66
  67         ! Remove trivial defs
  68         [ trivial-defs member? ]
  69
  70         ! Remove curry only defs
  71         [ [ \ curry = ] all? ]
  72
  73         ! Remove words with locals
  74         [ [ \ load-locals = ] any? ]
  75
  76         ! Remove stuff with wrappers
  77         [ [ wrapper? ] any? ]
  78
  79         ! Remove trivial math
  80         [ [ { [ number? ] [ { + - / * /i /f >integer } member? ] } 1|| ] all? ]
  81
  82         ! Remove more trival defs
  83         [
  84             {
  85                 [ length 2 = ]
  86                 [ first2 [ word? ] either? ]
  87                 [ first2 [ { dip dup over swap drop } member? ] either? ]
  88             } 1&&
  89         ]
  90
  91         ! Remove [ V{ } clone ] and related
  92         [
  93             {
  94                 [ length 2 = ]
  95                 [ first { [ sequence? ] [ assoc? ] } 1|| ]
  96                 [ second { clone clone-like like assoc-like make } member? ]
  97             } 1&&
  98         ]
  99
 100         ! Remove [ foo get ] and related
 101         [
 102             {
 103                 [ length 2 = ]
 104                 [ first word? ]
 105                 [ second { get get-global , % } member? ]
 106             } 1&&
 107         ]
 108
 109         ! Remove [ first second ] and related
 110         [
 111             {
 112                 [ length 2 = ]
 113                 [ first { first second third } member? ]
 114                 [ second { first second third } member? ]
 115             } 1&&
 116         ]
 117
 118         ! Remove [ [ trivial ] if ] and related
 119         [
 120             {
 121                 [ length 2 = ]
 122                 [ first { [ quotation? ] [ ignore-def? ] } 1&& ]
 123                 [ second { if if* unless unless* when when* curry } member? ]
 124             } 1&&
 125         ]
 126
 127         ! Remove [ n - ] and related
 128         [
 129             {
 130                 [ length 2 = ]
 131                 [ first { [ number? ] [ boolean? ] } 1|| ]
 132                 [ second { + - / * < <= = >= > shift bitand bitor bitxor eq? } member? ]
 133             } 1&&
 134         ]
 135
 136         ! Remove [ dup 0 > ] and related
 137         [
 138             {
 139                 [ length 3 = ]
 140                 [ first { dup over } member? ]
 141                 [ second number? ]
 142                 [ third { + - / * < <= = >= > } member? ]
 143             } 1&&
 144         ]
 145
 146         ! Remove [ drop f f ] and related
 147         [
 148             {
 149                 [ length 4 <= ]
 150                 [ first { drop 2drop 3drop nip 2nip } member? ]
 151                 [ rest-slice [ boolean? ] all? ]
 152             } 1&&
 153         ]
 154
 155         ! Remove [ length 1 = ] and related
 156         [
 157             {
 158                 [ length 3 = ]
 159                 [ first \ length = ]
 160                 [ second number? ]
 161                 [ third { + - / * < <= = >= > } member? ]
 162             } 1&&
 163         ]
 164
 165         ! Remove [ dup length 1 = ] and related
 166         [
 167             {
 168                 [ length 4 = ]
 169                 [ first { dup over } member? ]
 170                 [ second \ length = ]
 171                 [ third number? ]
 172                 [ fourth { + - / * < <= = >= > } member? ]
 173             } 1&&
 174         ]
 175
 176         ! Remove numbers/t/f only defs
 177         [
 178             [ { [ number? ] [ boolean? ] } 1|| ] all?
 179         ]
 180
 181         ! Remove [ tag n eq? ]
 182         [
 183             {
 184                 [ length 3 = ]
 185                 [ first \ tag = ] [ second number? ] [ third \ eq? = ]
 186             } 1&&
 187         ]
 188
 189         ! Remove [ { foo } declare class-of ]
 190         [
 191             {
 192                 [ length 3 = ]
 193                 [ first { [ array? ] [ length 1 = ] } 1&& ]
 194                 [ second \ declare = ]
 195                 [ third \ class-of = ]
 196             } 1&&
 197         ]
 198
 199         ! Remove [ m n shift ]
 200         [
 201             {
 202                 [ length 3 = ]
 203                 [ first2 [ number? ] both? ] [ third \ shift = ]
 204             } 1&&
 205         ]
 206
 207         ! Remove [ layout-of n slot ]
 208         [
 209             {
 210                 [ length 3 = ]
 211                 [ first \ layout-of = ]
 212                 [ second number? ]
 213                 [ third \ slot = ]
 214             } 1&&
 215         ]
 216     } 1|| ;
 217
 218 : all-callables ( def -- seq )
 219     [ { [ callable? ] [ ignore-def? not ] } 1&& ] deep-filter ;
 220
 221 : (load-definitions) ( word def hash -- )
 222     [ all-callables ] dip '[ _ push-at ] with each ;
 223
 224 : load-definitions ( words -- hash )
 225     H{ } clone [ '[ dup def>> _ (load-definitions) ] each ] keep ;
 226
 227 SYMBOL: lint-definitions
 228 SYMBOL: lint-definitions-keys
 229
 230 : reload-definitions ( -- )
 231     ! Load lintable and non-ignored definitions
 232     lintable-words load-definitions
 233
 234     ! Remove words that are their own definition
 235     [ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
 236
 237     ! Add manual definitions
 238     manual-substitutions over '[ _ push-at ] assoc-each
 239
 240     ! Set globals to new values
 241     [ lint-definitions set-global ]
 242     [ keys lint-definitions-keys set-global ] bi ;
 243
 244 : find-duplicates ( -- seq )
 245     lint-definitions get-global [ nip length 1 > ] assoc-filter ;
 246
 247 GENERIC: lint ( obj -- seq )
 248
 249 M: object lint ( obj -- seq ) drop f ;
 250
 251 M: callable lint ( quot -- seq )
 252     [ lint-definitions-keys get-global ] dip '[ _ subseq? ] filter ;
 253
 254 M: word lint ( word -- seq/f )
 255     def>> [ callable? ] deep-filter [ lint ] map concat ;
 256
 257 : word-path. ( word -- )
 258     [ vocabulary>> write ":" write ] [ . ] bi ;
 259
 260 : 4bl ( -- ) bl bl bl bl ;
 261
 262 : (lint.) ( pair -- )
 263     first2 [ word-path. ] dip [
 264         [ 4bl .  "-----------------------------------" print ]
 265         [ lint-definitions get-global at [ 4bl word-path. ] each nl ] bi
 266     ] each nl ;
 267
 268 : lint. ( alist -- ) [ (lint.) ] each ;
 269
 270 GENERIC: run-lint ( obj -- obj )
 271
 272 : (trim-self) ( val key -- obj ? )
 273     lint-definitions get-global at*
 274     [ dupd remove empty? not ] [ drop f ] if ;
 275
 276 : trim-self ( seq -- newseq )
 277     [ [ (trim-self) ] filter ] assoc-map ;
 278
 279 : filter-symbols ( alist -- alist )
 280     [
 281         nip first dup lint-definitions get-global at
 282         [ first ] bi@ literalize = not
 283     ] assoc-filter ;
 284
 285 M: sequence run-lint ( seq -- seq )
 286     [ dup lint ] { } map>assoc trim-self
 287     [ second empty? not ] filter filter-symbols ;
 288
 289 M: word run-lint ( word -- seq ) 1array run-lint ;
 290
 291 PRIVATE>
 292
 293 : find-swap/swap ( word -- ? )
 294     def>> [ callable? ] deep-filter
 295     [
 296         {
 297             [ [ \ swap = ] count 2 >= ]
 298             [
 299                 { swap } split rest but-last
 300                 [ [ infer ] [ 2drop ( -- ) ] recover ( x -- x ) = ] any?
 301             ]
 302         } 1&&
 303     ] any? ;
 304
 305 : find-redundant-word-props ( -- seq )
 306     all-words [
 307         {
 308             [ { [ foldable? ] [ flushable? ] } 1|| ]
 309             [ inline? ]
 310         } 1&&
 311     ] filter ;
 312
 313 : lint-all ( -- seq )
 314     all-words run-lint dup lint. ;
 315
 316 : lint-vocab ( vocab -- seq )
 317     words run-lint dup lint. ;
 318
 319 : lint-vocabs ( prefix -- seq )
 320     [ vocabs ] dip [ head? ] curry filter [ lint-vocab ] map ;
 321
 322 : lint-word ( word -- seq )
 323     1array run-lint dup lint. ;
 324
 325 reload-definitions