extra/lint/lint.factor

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