basis/help/lint/checks/checks.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes classes.struct
   4 classes.tuple combinators combinators.short-circuit
   5 combinators.smart continuations debugger definitions effects
   6 eval formatting fry grouping help help.markup help.topics io
   7 io.streams.string kernel macros math math.statistics namespaces
   8 parser.notes prettyprint sequences sequences.deep sets splitting
   9 strings summary tools.destructors unicode vocabs vocabs.loader
  10 words words.constant words.symbol ;
  11 IN: help.lint.checks
  12
  13 ERROR: simple-lint-error message ;
  14
  15 M: simple-lint-error summary message>> ;
  16
  17 M: simple-lint-error error. summary print ;
  18
  19 SYMBOL: vocabs-quot
  20 SYMBOL: vocab-articles
  21
  22 : no-ui-disposables ( seq -- seq' )
  23     [
  24         class-of name>> {
  25             "single-texture" "multi-texture" ! opengl.textures
  26             "line" ! core-text
  27             "layout" ! ui.text.pango
  28             "script-string" ! windows.uniscribe
  29             "linux-monitor" ! github issue #2014, race condition in disposing of child monitors
  30             "event-stream"
  31             "macosx-monitor"
  32         } member?
  33     ] reject ;
  34
  35 : eval-with-stack ( str -- output )
  36     [
  37         [
  38             parser-quiet? on parse-string [
  39                 output>array [
  40                     nl "--- Data stack:" print stack.
  41                 ] unless-empty
  42             ] call( quot -- )
  43         ] [ nip print-error ] recover
  44     ] with-string-writer ;
  45
  46 : check-example ( element -- )
  47     [
  48         '[
  49             _ rest [
  50                 but-last "\n" join
  51                 eval-with-stack
  52                 "\n" ?tail drop
  53             ] keep
  54             last assert=
  55         ] vocabs-quot get call( quot -- )
  56     ] leaks members no-ui-disposables
  57     dup length 0 > [
  58        dup [ class-of ] histogram-by
  59        [ "Leaked resources: " write ... ] with-string-writer simple-lint-error
  60     ] [
  61         drop
  62     ] if ;
  63
  64 : check-examples ( element -- )
  65     \ $example swap elements [ check-example ] each ;
  66
  67 : extract-values ( element -- seq )
  68     \ $values swap elements
  69     [ f ] [ first rest keys ] if-empty ;
  70
  71 : extract-value-effects ( element -- seq )
  72     \ $values swap elements [ f ] [
  73         first rest [
  74             \ $quotation swap elements [ f ] [
  75                 first second dup effect? [ effect>string ] when
  76             ] if-empty
  77         ] map
  78     ] if-empty ;
  79
  80 : effect-values ( word -- seq )
  81     stack-effect
  82     [ in>> ] [ out>> ] bi append
  83     [ dup pair? [ first ] when effect>string ] map members ;
  84
  85 : effect-effects ( word -- seq )
  86     stack-effect in>> [
  87         dup pair?
  88         [ second dup effect? [ effect>string ] [ drop f ] if ]
  89         [ drop f ] if
  90     ] map ;
  91
  92 : contains-funky-elements? ( element -- ? )
  93     {
  94         $shuffle
  95         $complex-shuffle
  96         $values-x/y
  97         $predicate
  98         $class-description
  99         $error-description
 100     } swap '[ _ elements empty? not ] any? ;
 101
 102 : don't-check-word? ( word -- ? )
 103     {
 104         [ macro? ]
 105         [ symbol? ]
 106         [ parsing-word? ]
 107         [ "declared-effect" word-prop not ]
 108         [ constant? ]
 109         [ "help" word-prop not ]
 110     } 1|| ;
 111
 112 : skip-check-values? ( word element -- ? )
 113     [ don't-check-word? ] [ contains-funky-elements? ] bi* or ;
 114
 115 : check-values ( word element -- )
 116     2dup skip-check-values? [ 2drop ] [
 117         [ effect-values ] [ extract-values ] bi* 2dup
 118         sequence= [ 2drop ] [
 119             "$values don't match stack effect; expected %u, got %u" sprintf
 120             simple-lint-error
 121         ] if
 122     ] if ;
 123
 124 : check-value-effects ( word element -- )
 125     [ effect-effects ] [ extract-value-effects ] bi*
 126     [ 2dup and [ = ] [ 2drop t ] if ] 2all? [
 127         "$quotation stack effects in $values don't match"
 128         simple-lint-error
 129     ] unless ;
 130
 131 : check-nulls ( element -- )
 132     \ $values swap elements
 133     null swap deep-member?
 134     [ "$values should not contain null" simple-lint-error ] when ;
 135
 136 : check-see-also ( element -- )
 137     \ $see-also swap elements [ rest all-unique? ] all?
 138     [ "$see-also are not unique" simple-lint-error ] unless ;
 139
 140 : check-modules ( element -- )
 141     \ $vocab-link swap elements [
 142         second
 143         vocab-exists? [
 144             "$vocab-link to non-existent vocabulary"
 145             simple-lint-error
 146         ] unless
 147     ] each ;
 148
 149 : check-slots-tables ( element -- )
 150     \ $slots swap elements [ rest [ length 2 = ] all?  ] all?
 151     [ "$slots have too many values in at least one row" simple-lint-error ] unless ;
 152
 153 : check-rendering ( element -- )
 154     [ print-content ] with-string-writer drop ;
 155
 156 : check-strings ( str -- )
 157     [
 158         "\n\t" intersects? [
 159             "Paragraph text should not contain \\n or \\t"
 160             simple-lint-error
 161         ] when
 162     ] [
 163         "  " swap subseq? [
 164             "Paragraph text should not contain double spaces"
 165             simple-lint-error
 166         ] when
 167     ] bi ;
 168
 169 : check-whitespace ( str1 str2 -- )
 170     [ " " tail? ] [ " " head? ] bi* or
 171     [ "Missing whitespace between strings" simple-lint-error ] unless ;
 172
 173 : check-bogus-nl ( element -- )
 174     { { $nl } { { $nl } } } [ head? ] with any? [
 175         "Simple element should not begin with a paragraph break"
 176         simple-lint-error
 177     ] when ;
 178
 179 : extract-slots ( elements -- seq )
 180     [ dup pair? [ first \ $slot = ] [ drop f ] if ] deep-filter
 181     [ second ] map ;
 182
 183 : check-class-description ( word element -- )
 184     \ $class-description swap elements over class? [
 185         [
 186             dup struct-class? [ struct-slots ] [ all-slots ] if
 187             [ name>> ] map
 188         ] [ extract-slots ] bi*
 189         [ swap member? ] with reject [
 190             ", " join "Described $slot does not exist: " prepend
 191             simple-lint-error
 192         ] unless-empty
 193     ] [
 194         nip empty? not [
 195             "A word that is not a class has a $class-description"
 196             simple-lint-error
 197         ] when
 198     ] if ;
 199
 200 : check-article-title ( article -- )
 201     article-title first LETTER?
 202     [ "Article title must begin with a capital letter" simple-lint-error ] unless ;
 203
 204 : check-elements ( element -- )
 205     {
 206         [ check-bogus-nl ]
 207         [ [ string? ] filter [ check-strings ] each ]
 208         [ [ simple-element? ] filter [ check-elements ] each ]
 209         [ 2 <clumps> [ [ string? ] all? ] filter [ first2 check-whitespace ] each ]
 210     } cleave ;
 211
 212 : check-descriptions ( element -- )
 213     { $description $class-description $var-description }
 214     swap '[
 215         _ elements [
 216             rest { { } { "" } } member?
 217             [ "Empty $description" simple-lint-error ] when
 218         ] each
 219     ] each ;
 220
 221 : check-markup ( element -- )
 222     {
 223         [ check-elements ]
 224         [ check-rendering ]
 225         [ check-examples ]
 226         [ check-modules ]
 227         [ check-descriptions ]
 228         [ check-slots-tables ]
 229     } cleave ;
 230
 231 : files>vocabs ( -- assoc )
 232     loaded-vocab-names
 233     [ [ [ vocab-docs-path ] keep ] H{ } map>assoc ]
 234     [ [ [ vocab-source-path ] keep ] H{ } map>assoc ]
 235     bi assoc-union ;
 236
 237 : group-articles ( -- assoc )
 238     articles get keys
 239     files>vocabs
 240     H{ } clone [
 241         '[
 242             dup >link where dup
 243             [ first _ at _ push-at ] [ 2drop ] if
 244         ] each
 245     ] keep ;
 246
 247 : all-word-help ( words -- seq )
 248     [ word-help ] filter ;