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