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