extra/lint/lint.factor

   1 ! Copyright (C) 2007, 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien arrays assocs combinators.short-circuit
   4 fry hashtables io kernel math namespaces prettyprint quotations
   5 sequences sequences.deep shuffle slots.private vectors vocabs
   6 words xml.data words.alias ;
   7 IN: lint
   8
   9 SYMBOL: lint-definitions
  10 SYMBOL: lint-definitions-keys
  11
  12 : set-hash-vector ( val key hash -- )
  13     2dup at -rot [ ?push ] 2dip set-at ;
  14
  15 : manual-substitutions ( hash -- )
  16     {
  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     } swap '[ first2 _ set-hash-vector ] each ;
  31
  32 CONSTANT: trivial-defs
  33     {
  34         [ drop ] [ 2drop ] [ 2array ]
  35         [ bitand ]
  36         [ . ]
  37         [ new ]
  38         [ get ]
  39         [ "" ]
  40         [ t ] [ f ]
  41         [ { } ]
  42         [ drop t ] [ drop f ] [ 2drop t ] [ 2drop f ]
  43         [ cdecl ]
  44         [ first ] [ second ] [ third ] [ fourth ]
  45         [ ">" write ] [ "/>" write ]
  46     }
  47
  48 ! ! Add definitions
  49 H{ } clone lint-definitions set-global
  50
  51 all-words [
  52     dup def>> dup callable?
  53     [ lint-definitions get-global set-hash-vector ] [ drop ] if
  54 ] each
  55
  56 ! ! Remove definitions
  57
  58 ! Remove empty word defs
  59 lint-definitions get-global [ drop empty? not ] assoc-filter
  60
  61 ! Remove constants [ 1 ]
  62 [ drop { [ length 1 = ] [ first number? ] } 1&& not ] assoc-filter
  63
  64 ! Remove words that are their own definition
  65 [ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
  66
  67 ! Remove specialized*
  68  [ nip [ vocabulary>> "specialized-" head? ] any? not ] assoc-filter
  69
  70  [ nip [ vocabulary>> "windows.messages" = ] any? not ] assoc-filter
  71
  72  [ nip [ alias? ] any? not ] assoc-filter
  73
  74 ! Remove trivial defs
  75 [ drop trivial-defs member? not ] assoc-filter
  76
  77 ! Remove numbers only defs
  78 [ drop [ number? ] all? not ] assoc-filter
  79
  80 ! Remove curry only defs
  81 [ drop [ \ curry = ] all? not ] assoc-filter
  82
  83 ! Remove tag defs
  84 [
  85     drop {
  86             [ length 3 = ]
  87             [ first \ tag = ] [ second number? ] [ third \ eq? = ]
  88     } 1&& not
  89 ] assoc-filter
  90
  91 [
  92     drop {
  93         [ [ wrapper? ] deep-any? ]
  94         [ [ hashtable? ] deep-any? ]
  95     } 1|| not
  96 ] assoc-filter
  97
  98 ! Remove n m shift defs
  99 [
 100     drop dup length 3 = [
 101         [ first2 [ number? ] both? ]
 102         [ third \ shift = ] bi and not
 103     ] [ drop t ] if
 104 ] assoc-filter
 105
 106 ! Remove [ n slot ]
 107 [
 108     drop dup length 2 =
 109     [ first2 [ number? ] [ \ slot = ] bi* and not ] [ drop t ] if
 110 ] assoc-filter
 111
 112 dup manual-substitutions
 113
 114 [ lint-definitions set-global ] [ keys lint-definitions-keys set-global ] bi
 115
 116 : find-duplicates ( -- seq )
 117     lint-definitions get-global [ nip length 1 > ] assoc-filter ;
 118
 119 GENERIC: lint ( obj -- seq )
 120
 121 M: object lint ( obj -- seq ) drop f ;
 122
 123 : subseq/member? ( subseq/member seq -- ? )
 124     { [ start ] [ member? ] } 2|| ;
 125
 126 M: callable lint ( quot -- seq )
 127     [ lint-definitions-keys get-global ] dip '[ _ subseq/member? ] filter ;
 128
 129 M: word lint ( word -- seq )
 130     def>> dup callable? [ lint ] [ drop f ] if ;
 131
 132 : word-path. ( word -- )
 133     [ vocabulary>> ] [ name>> ] bi ":" glue print ;
 134
 135 : 4bl ( -- ) bl bl bl bl ;
 136
 137 : (lint.) ( pair -- )
 138     first2 [ word-path. ] dip [
 139         [ 4bl .  "-----------------------------------" print ]
 140         [ lint-definitions get-global at [ 4bl word-path. ] each nl ] bi
 141     ] each nl nl ;
 142
 143 : lint. ( alist -- ) [ (lint.) ] each ;
 144
 145 GENERIC: run-lint ( obj -- obj )
 146
 147 : (trim-self) ( val key -- obj ? )
 148     lint-definitions get-global at*
 149     [ dupd remove empty? not ] [ drop f ] if ;
 150
 151 : trim-self ( seq -- newseq )
 152     [ [ (trim-self) ] filter ] assoc-map ;
 153
 154 : filter-symbols ( alist -- alist )
 155     [
 156         nip first dup lint-definitions get-global at
 157         [ first ] bi@ literalize = not
 158     ] assoc-filter ;
 159
 160 M: sequence run-lint ( seq -- seq )
 161     [ dup lint ] { } map>assoc trim-self
 162     [ second empty? not ] filter filter-symbols ;
 163
 164 M: word run-lint ( word -- seq ) 1array run-lint ;
 165
 166 : lint-all ( -- seq ) all-words run-lint dup lint. ;
 167
 168 : lint-vocab ( vocab -- seq ) words run-lint dup lint. ;
 169
 170 : lint-vocabs ( prefix -- seq )
 171     [ vocabs ] dip [ head? ] curry filter [ lint-vocab ] map ;
 172
 173 : lint-word ( word -- seq ) 1array run-lint dup lint. ;