basis/help/lint/lint.factor

   1 ! Copyright (C) 2006, 2008 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 ;
  10 IN: help.lint
  11
  12 : check-example ( element -- )
  13     rest [
  14         but-last "\n" join 1vector
  15         [
  16             use [ clone ] change
  17             [ eval>string ] with-datastack
  18         ] with-scope peek "\n" ?tail drop
  19     ] keep
  20     peek assert= ;
  21
  22 : check-examples ( word element -- )
  23     nip \ $example swap elements [ check-example ] each ;
  24
  25 : extract-values ( element -- seq )
  26     \ $values swap elements dup empty? [
  27         first rest [ first ] map prune natural-sort
  28     ] unless ;
  29
  30 : effect-values ( word -- seq )
  31     stack-effect
  32     [ in>> ] [ out>> ] bi append
  33     [ dup pair? [ first ] when effect>string ] map
  34     prune natural-sort ;
  35
  36 : contains-funky-elements? ( element -- ? )
  37     {
  38         $shuffle
  39         $values-x/y
  40         $predicate
  41         $class-description
  42         $error-description
  43     } swap '[ _ elements empty? not ] contains? ;
  44
  45 : don't-check-word? ( word -- ? )
  46     {
  47         [ macro? ]
  48         [ symbol? ]
  49         [ value-word? ]
  50         [ parsing-word? ]
  51         [ "declared-effect" word-prop not ]
  52     } 1|| ;
  53
  54 : check-values ( word element -- )
  55     {
  56         [
  57             [ don't-check-word? ]
  58             [ contains-funky-elements? ]
  59             bi* or
  60         ] [
  61             [ effect-values ]
  62             [ extract-values ]
  63             bi* sequence=
  64         ]
  65     } 2|| [ "$values don't match stack effect" throw ] unless ;
  66
  67 : check-see-also ( word element -- )
  68     nip \ $see-also swap elements [
  69         rest dup prune [ length ] bi@ assert=
  70     ] each ;
  71
  72 : vocab-exists? ( name -- ? )
  73     [ vocab ] [ "all-vocabs" get member? ] bi or ;
  74
  75 : check-modules ( element -- )
  76     \ $vocab-link swap elements [
  77         second
  78         vocab-exists? [ "$vocab-link to non-existent vocabulary" throw ] unless
  79     ] each ;
  80
  81 : check-rendering ( element -- )
  82     [ print-topic ] with-string-writer drop ;
  83
  84 : all-word-help ( words -- seq )
  85     [ word-help ] filter ;
  86
  87 TUPLE: help-error topic error ;
  88
  89 C: <help-error> help-error
  90
  91 M: help-error error.
  92     "In " write dup topic>> pprint nl
  93     error>> error. ;
  94
  95 : check-something ( obj quot -- )
  96     flush [ <help-error> , ] recover ; inline
  97
  98 : check-word ( word -- )
  99     dup word-help [
 100         [
 101             dup word-help '[
 102                 _ _ {
 103                     [ check-examples ]
 104                     [ check-values ]
 105                     [ check-see-also ]
 106                     [ [ check-rendering ] [ check-modules ] bi* ]
 107                 } 2cleave
 108             ] assert-depth
 109         ] check-something
 110     ] [ drop ] if ;
 111
 112 : check-words ( words -- ) [ check-word ] each ;
 113
 114 : check-article ( article -- )
 115     [
 116         dup article-content
 117         '[ _ check-rendering _ check-modules ]
 118         assert-depth
 119     ] check-something ;
 120
 121 : files>vocabs ( -- assoc )
 122     vocabs
 123     [ [ [ vocab-docs-path ] keep ] H{ } map>assoc ]
 124     [ [ [ vocab-source-path ] keep ] H{ } map>assoc ]
 125     bi assoc-union ;
 126
 127 : group-articles ( -- assoc )
 128     articles get keys
 129     files>vocabs
 130     H{ } clone [
 131         '[
 132             dup >link where dup
 133             [ first _ at _ push-at ] [ 2drop ] if
 134         ] each
 135     ] keep ;
 136
 137 : check-about ( vocab -- )
 138     [ vocab-help [ article drop ] when* ] check-something ;
 139
 140 : check-vocab ( vocab -- seq )
 141     "Checking " write dup write "..." print
 142     [
 143         [ check-about ]
 144         [ words [ check-word ] each ]
 145         [ "vocab-articles" get at [ check-article ] each ]
 146         tri
 147     ] { } make ;
 148
 149 : run-help-lint ( prefix -- alist )
 150     [
 151         all-vocabs-seq [ vocab-name ] map "all-vocabs" set
 152         group-articles "vocab-articles" set
 153         child-vocabs
 154         [ dup check-vocab ] { } map>assoc
 155         [ nip empty? not ] assoc-filter
 156     ] with-scope ;
 157
 158 : typos. ( assoc -- )
 159     [
 160         "==== ALL CHECKS PASSED" print
 161     ] [
 162         [
 163             swap vocab-heading.
 164             [ print-error nl ] each
 165         ] assoc-each
 166     ] if-empty ;
 167
 168 : help-lint ( prefix -- ) run-help-lint typos. ;
 169
 170 : help-lint-all ( -- ) "" help-lint ;
 171
 172 : unlinked-words ( words -- seq )
 173     all-word-help [ article-parent not ] filter ;
 174
 175 : linked-undocumented-words ( -- seq )
 176     all-words
 177     [ word-help not ] filter
 178     [ article-parent ] filter
 179     [ "predicating" word-prop not ] filter ;
 180
 181 MAIN: help-lint