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