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