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         [ drop t ] [ drop f ]
  34         [ 2drop t ] [ 2drop f ]
  35         [ 3drop t ] [ 3drop f ]
  36         [ ">" write ] [ "/>" write ]
  37         [ length 1 - ] [ length 1 = ] [ length 1 > ]
  38         [ drop f f ] [ drop f t ] [ drop t f ] [ drop t t ]
  39         [ 2drop f f ] [ 2drop f t ] [ 2drop t f ] [ 2drop t t ]
  40         [ drop f f f ]
  41         [ nip f f ]
  42         [ 0 or + ]
  43         [ dup 0 > ] [ dup 0 <= ] [ dup 0 < ]
  44         [ over 0 > ] [ over 0 <= ] [ over 0 < ]
  45         [ dup length iota ]
  46         [ 0 swap copy ]
  47         [ dup 1 + ] [ drop 1 + ]
  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 2 <= ]
  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 numbers/t/f only defs
  75         [
  76             [ { [ number? ] [ t? ] [ f eq? ] } 1|| ] all?
  77         ]
  78
  79         ! Remove [ tag n eq? ]
  80         [
  81             {
  82                 [ length 3 = ]
  83                 [ first \ tag = ] [ second number? ] [ third \ eq? = ]
  84             } 1&&
  85         ]
  86
  87         ! Remove [ { foo } declare class ]
  88         [
  89             {
  90                 [ length 3 = ]
  91                 [ first { [ array? ] [ length 1 = ] } 1&& ]
  92                 [ second \ declare = ]
  93                 [ third \ class = ]
  94             } 1&&
  95         ]
  96
  97         ! Remove [ m n shift ]
  98         [
  99             {
 100                 [ length 3 = ]
 101                 [ first2 [ number? ] both? ] [ third \ shift = ]
 102             } 1&&
 103         ]
 104
 105         ! Remove [ layout-of n slot ]
 106         [
 107             {
 108                 [ length 3 = ]
 109                 [ first \ layout-of = ]
 110                 [ second number? ]
 111                 [ third \ slot = ]
 112             } 1&&
 113         ]
 114
 115         ! Remove [ ... \ cdecl ]
 116         [
 117             { [ length 3 = ] [ last \ cdecl = ] } 1&&
 118         ]
 119     } 1|| ;
 120
 121 : all-callables ( def -- seq )
 122     [ { [ callable? ] [ ignore-def? not ] } 1&& ] deep-filter ;
 123
 124 : (load-definitions) ( word def hash -- )
 125     [ all-callables ] dip '[ _ push-at ] with each ;
 126
 127 : load-definitions ( words -- hash )
 128     H{ } clone [ '[ dup def>> _ (load-definitions) ] each ] keep ;
 129
 130 SYMBOL: lint-definitions
 131 SYMBOL: lint-definitions-keys
 132
 133 : reload-definitions ( -- )
 134     ! Load lintable and non-ignored definitions
 135     lintable-words load-definitions
 136
 137     ! Remove words that are their own definition
 138     [ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
 139
 140     ! Add manual definitions
 141     manual-substitutions over '[ _ push-at ] assoc-each
 142
 143     ! Set globals to new values
 144     [ lint-definitions set-global ]
 145     [ keys lint-definitions-keys set-global ] bi ;
 146
 147 : find-duplicates ( -- seq )
 148     lint-definitions get-global [ nip length 1 > ] assoc-filter ;
 149
 150 GENERIC: lint ( obj -- seq )
 151
 152 M: object lint ( obj -- seq ) drop f ;
 153
 154 M: callable lint ( quot -- seq )
 155     [ lint-definitions-keys get-global ] dip '[ _ subseq? ] filter ;
 156
 157 M: word lint ( word -- seq/f )
 158     def>> all-callables [ lint ] map concat ;
 159
 160 : word-path. ( word -- )
 161     [ vocabulary>> write ":" write ] [ . ] bi ;
 162
 163 : 4bl ( -- ) bl bl bl bl ;
 164
 165 : (lint.) ( pair -- )
 166     first2 [ word-path. ] dip [
 167         [ 4bl .  "-----------------------------------" print ]
 168         [ lint-definitions get-global at [ 4bl word-path. ] each nl ] bi
 169     ] each nl ;
 170
 171 : lint. ( alist -- ) [ (lint.) ] each ;
 172
 173 GENERIC: run-lint ( obj -- obj )
 174
 175 : (trim-self) ( val key -- obj ? )
 176     lint-definitions get-global at*
 177     [ dupd remove empty? not ] [ drop f ] if ;
 178
 179 : trim-self ( seq -- newseq )
 180     [ [ (trim-self) ] filter ] assoc-map ;
 181
 182 : filter-symbols ( alist -- alist )
 183     [
 184         nip first dup lint-definitions get-global at
 185         [ first ] bi@ literalize = not
 186     ] assoc-filter ;
 187
 188 M: sequence run-lint ( seq -- seq )
 189     [ dup lint ] { } map>assoc trim-self
 190     [ second empty? not ] filter filter-symbols ;
 191
 192 M: word run-lint ( word -- seq ) 1array run-lint ;
 193
 194 PRIVATE>
 195
 196 : lint-all ( -- seq )
 197     all-words run-lint dup lint. ;
 198
 199 : lint-vocab ( vocab -- seq )
 200     words run-lint dup lint. ;
 201
 202 : lint-vocabs ( prefix -- seq )
 203     [ vocabs ] dip [ head? ] curry filter [ lint-vocab ] map ;
 204
 205 : lint-word ( word -- seq )
 206     1array run-lint dup lint. ;
 207
 208 reload-definitions