extra/lint/lint.factor

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