basis/help/lint/lint.factor

   1 ! Copyright (C) 2006, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: fry accessors sequences parser kernel help help.markup
   4 help.topics words strings classes tools.vocabs namespaces make
   5 io io.streams.string prettyprint definitions arrays vectors
   6 combinators combinators.short-circuit splitting debugger
   7 hashtables sorting effects vocabs vocabs.loader assocs editors
   8 continuations classes.predicate macros math sets eval
   9 vocabs.parser words.symbol values grouping unicode.categories
  10 sequences.deep ;
  11 IN: help.lint
  12
  13 SYMBOL: vocabs-quot
  14
  15 : check-example ( element -- )
  16     [
  17         rest [
  18             but-last "\n" join 1vector
  19             [ (eval>string) ] with-datastack
  20             peek "\n" ?tail drop
  21         ] keep
  22         peek assert=
  23     ] vocabs-quot get call ;
  24
  25 : check-examples ( element -- )
  26     \ $example swap elements [ check-example ] each ;
  27
  28 : extract-values ( element -- seq )
  29     \ $values swap elements dup empty? [
  30         first rest [ first ] map prune natural-sort
  31     ] unless ;
  32
  33 : effect-values ( word -- seq )
  34     stack-effect
  35     [ in>> ] [ out>> ] bi append
  36     [ dup pair? [ first ] when effect>string ] map
  37     prune natural-sort ;
  38
  39 : contains-funky-elements? ( element -- ? )
  40     {
  41         $shuffle
  42         $values-x/y
  43         $predicate
  44         $class-description
  45         $error-description
  46     } swap '[ _ elements empty? not ] contains? ;
  47
  48 : don't-check-word? ( word -- ? )
  49     {
  50         [ macro? ]
  51         [ symbol? ]
  52         [ value-word? ]
  53         [ parsing-word? ]
  54         [ "declared-effect" word-prop not ]
  55     } 1|| ;
  56
  57 : check-values ( word element -- )
  58     {
  59         [
  60             [ don't-check-word? ]
  61             [ contains-funky-elements? ]
  62             bi* or
  63         ] [
  64             [ effect-values ]
  65             [ extract-values ]
  66             bi* sequence=
  67         ]
  68     } 2|| [ "$values don't match stack effect" throw ] unless ;
  69
  70 : check-nulls ( element -- )
  71     \ $values swap elements
  72     null swap deep-member?
  73     [ "$values should not contain null" throw ] when ;
  74
  75 : check-see-also ( element -- )
  76     \ $see-also swap elements [
  77         rest dup prune [ length ] bi@ assert=
  78     ] each ;
  79
  80 : vocab-exists? ( name -- ? )
  81     [ vocab ] [ "all-vocabs" get member? ] bi or ;
  82
  83 : check-modules ( element -- )
  84     \ $vocab-link swap elements [
  85         second
  86         vocab-exists? [ "$vocab-link to non-existent vocabulary" throw ] unless
  87     ] each ;
  88
  89 : check-rendering ( element -- )
  90     [ print-content ] with-string-writer drop ;
  91
  92 : check-strings ( str -- )
  93     [
  94         "\n\t" intersects?
  95         [ "Paragraph text should not contain \\n or \\t" throw ] when
  96     ] [
  97         "  " swap subseq?
  98         [ "Paragraph text should not contain double spaces" throw ] when
  99     ] bi ;
 100
 101 : check-whitespace ( str1 str2 -- )
 102     [ " " tail? ] [ " " head? ] bi* or
 103     [ "Missing whitespace between strings" throw ] unless ;
 104
 105 : check-bogus-nl ( element -- )
 106     { { $nl } { { $nl } } } [ head? ] with contains?
 107     [ "Simple element should not begin with a paragraph break" throw ] when ;
 108
 109 : check-elements ( element -- )
 110     {
 111         [ check-bogus-nl ]
 112         [ [ string? ] filter [ check-strings ] each ]
 113         [ [ simple-element? ] filter [ check-elements ] each ]
 114         [ 2 <clumps> [ [ string? ] all? ] filter [ first2 check-whitespace ] each ]
 115     } cleave ;
 116
 117 : check-markup ( element -- )
 118     {
 119         [ check-elements ]
 120         [ check-rendering ]
 121         [ check-examples ]
 122         [ check-modules ]
 123     } cleave ;
 124
 125 : all-word-help ( words -- seq )
 126     [ word-help ] filter ;
 127
 128 TUPLE: help-error error topic ;
 129
 130 C: <help-error> help-error
 131
 132 M: help-error error.
 133     [ "In " write topic>> pprint nl ]
 134     [ error>> error. ]
 135     bi ;
 136
 137 : check-something ( obj quot -- )
 138     flush '[ _ assert-depth ] swap '[ _ <help-error> , ] recover ; inline
 139
 140 : check-word ( word -- )
 141     [ with-file-vocabs ] vocabs-quot set
 142     dup word-help [
 143         dup '[
 144             _ dup word-help
 145             [ check-values ]
 146             [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2bi
 147         ] check-something
 148     ] [ drop ] if ;
 149
 150 : check-words ( words -- ) [ check-word ] each ;
 151
 152 : check-article-title ( article -- )
 153     article-title first LETTER?
 154     [ "Article title must begin with a capital letter" throw ] unless ;
 155
 156 : check-article ( article -- )
 157     [ with-interactive-vocabs ] vocabs-quot set
 158     dup '[
 159         _
 160         [ check-article-title ]
 161         [ article-content check-markup ] bi
 162     ] check-something ;
 163
 164 : files>vocabs ( -- assoc )
 165     vocabs
 166     [ [ [ vocab-docs-path ] keep ] H{ } map>assoc ]
 167     [ [ [ vocab-source-path ] keep ] H{ } map>assoc ]
 168     bi assoc-union ;
 169
 170 : group-articles ( -- assoc )
 171     articles get keys
 172     files>vocabs
 173     H{ } clone [
 174         '[
 175             dup >link where dup
 176             [ first _ at _ push-at ] [ 2drop ] if
 177         ] each
 178     ] keep ;
 179
 180 : check-about ( vocab -- )
 181     dup '[ _ vocab-help [ article drop ] when* ] check-something ;
 182
 183 : check-vocab ( vocab -- seq )
 184     "Checking " write dup write "..." print
 185     [
 186         [ check-about ]
 187         [ words [ check-word ] each ]
 188         [ "vocab-articles" get at [ check-article ] each ]
 189         tri
 190     ] { } make ;
 191
 192 : run-help-lint ( prefix -- alist )
 193     [
 194         all-vocabs-seq [ vocab-name ] map "all-vocabs" set
 195         group-articles "vocab-articles" set
 196         child-vocabs
 197         [ dup check-vocab ] { } map>assoc
 198         [ nip empty? not ] assoc-filter
 199     ] with-scope ;
 200
 201 : typos. ( assoc -- )
 202     [
 203         "==== ALL CHECKS PASSED" print
 204     ] [
 205         [
 206             swap vocab-heading.
 207             [ print-error nl ] each
 208         ] assoc-each
 209     ] if-empty ;
 210
 211 : help-lint ( prefix -- ) run-help-lint typos. ;
 212
 213 : help-lint-all ( -- ) "" help-lint ;
 214
 215 : unlinked-words ( words -- seq )
 216     all-word-help [ article-parent not ] filter ;
 217
 218 : linked-undocumented-words ( -- seq )
 219     all-words
 220     [ word-help not ] filter
 221     [ article-parent ] filter
 222     [ "predicating" word-prop not ] filter ;
 223
 224 MAIN: help-lint