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