extra/lint/lint.factor

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