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 call ;
  11 IN: help.lint
  12
  13 SYMBOL: vocabs-quot
  14
  15 : check-example ( element -- )
  16     [
  17         rest [
  18             but-last "\n" join
  19             [ (eval>string) ] call( code -- output )
  20             "\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 ] any? ;
  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 any?
 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-descriptions ( element -- )
 118     { $description $class-description $var-description }
 119     swap '[
 120         _ elements [
 121             rest { { } { "" } } member?
 122             [ "Empty description" throw ] when
 123         ] each
 124     ] each ;
 125
 126 : check-markup ( element -- )
 127     {
 128         [ check-elements ]
 129         [ check-rendering ]
 130         [ check-examples ]
 131         [ check-modules ]
 132         [ check-descriptions ]
 133     } cleave ;
 134
 135 : check-class-description ( word element -- )
 136     [ class? not ]
 137     [ { $class-description } swap elements empty? not ] bi* and
 138     [ "A word that is not a class has a $class-description" throw ] when ;
 139
 140 : all-word-help ( words -- seq )
 141     [ word-help ] filter ;
 142
 143 TUPLE: help-error error topic ;
 144
 145 C: <help-error> help-error
 146
 147 M: help-error error.
 148     [ "In " write topic>> pprint nl ]
 149     [ error>> error. ]
 150     bi ;
 151
 152 : check-something ( obj quot -- )
 153     flush '[ _ call( -- ) ] swap '[ _ <help-error> , ] recover ; inline
 154
 155 : check-word ( word -- )
 156     [ with-file-vocabs ] vocabs-quot set
 157     dup word-help [
 158         dup '[
 159             _ dup word-help
 160             [ check-values ]
 161             [ check-class-description ]
 162             [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2tri
 163         ] check-something
 164     ] [ drop ] if ;
 165
 166 : check-words ( words -- ) [ check-word ] each ;
 167
 168 : check-article-title ( article -- )
 169     article-title first LETTER?
 170     [ "Article title must begin with a capital letter" throw ] unless ;
 171
 172 : check-article ( article -- )
 173     [ with-interactive-vocabs ] vocabs-quot set
 174     dup '[
 175         _
 176         [ check-article-title ]
 177         [ article-content check-markup ] bi
 178     ] check-something ;
 179
 180 : files>vocabs ( -- assoc )
 181     vocabs
 182     [ [ [ vocab-docs-path ] keep ] H{ } map>assoc ]
 183     [ [ [ vocab-source-path ] keep ] H{ } map>assoc ]
 184     bi assoc-union ;
 185
 186 : group-articles ( -- assoc )
 187     articles get keys
 188     files>vocabs
 189     H{ } clone [
 190         '[
 191             dup >link where dup
 192             [ first _ at _ push-at ] [ 2drop ] if
 193         ] each
 194     ] keep ;
 195
 196 : check-about ( vocab -- )
 197     dup '[ _ vocab-help [ article drop ] when* ] check-something ;
 198
 199 : check-vocab ( vocab -- seq )
 200     "Checking " write dup write "..." print
 201     [
 202         [ check-about ]
 203         [ words [ check-word ] each ]
 204         [ "vocab-articles" get at [ check-article ] each ]
 205         tri
 206     ] { } make ;
 207
 208 : run-help-lint ( prefix -- alist )
 209     [
 210         all-vocabs-seq [ vocab-name ] map "all-vocabs" set
 211         group-articles "vocab-articles" set
 212         child-vocabs
 213         [ dup check-vocab ] { } map>assoc
 214         [ nip empty? not ] assoc-filter
 215     ] with-scope ;
 216
 217 : typos. ( assoc -- )
 218     [
 219         "==== ALL CHECKS PASSED" print
 220     ] [
 221         [
 222             swap vocab-heading.
 223             [ print-error nl ] each
 224         ] assoc-each
 225     ] if-empty ;
 226
 227 : help-lint ( prefix -- ) run-help-lint typos. ;
 228
 229 : help-lint-all ( -- ) "" help-lint ;
 230
 231 : unlinked-words ( words -- seq )
 232     all-word-help [ article-parent not ] filter ;
 233
 234 : linked-undocumented-words ( -- seq )
 235     all-words
 236     [ word-help not ] filter
 237     [ article-parent ] filter
 238     [ "predicating" word-prop not ] filter ;
 239
 240 MAIN: help-lint