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 ( element -- )
  65     \ $vocab-link swap elements [
  66         second
  67         vocab-exists? [ "$vocab-link to non-existent 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 nip 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 article-content [
 105             2dup check-modules check-rendering
 106         ] assert-depth 2drop
 107     ] check-something ;
 108
 109 : files>vocabs ( -- assoc )
 110     vocabs
 111     [ [ [ vocab-docs-path ] keep ] H{ } map>assoc ]
 112     [ [ [ vocab-source-path ] keep ] H{ } map>assoc ]
 113     bi assoc-union ;
 114
 115 : group-articles ( -- assoc )
 116     articles get keys
 117     files>vocabs
 118     H{ } clone [
 119         '[
 120             dup >link where dup
 121             [ first _ at _ push-at ] [ 2drop ] if
 122         ] each
 123     ] keep ;
 124
 125 : check-about ( vocab -- )
 126     [ vocab-help [ article drop ] when* ] check-something ;
 127
 128 : check-vocab ( vocab -- seq )
 129     "Checking " write dup write "..." print
 130     [
 131         [ check-about ]
 132         [ words [ check-word ] each ]
 133         [ "vocab-articles" get at [ check-article ] each ]
 134         tri
 135     ] { } make ;
 136
 137 : run-help-lint ( prefix -- alist )
 138     [
 139         all-vocabs-seq [ vocab-name ] map "all-vocabs" set
 140         group-articles "vocab-articles" set
 141         child-vocabs
 142         [ dup check-vocab ] { } map>assoc
 143         [ nip empty? not ] assoc-filter
 144     ] with-scope ;
 145
 146 : typos. ( assoc -- )
 147     [
 148         "==== ALL CHECKS PASSED" print
 149     ] [
 150         [
 151             swap vocab-heading.
 152             [ error. nl ] each
 153         ] assoc-each
 154     ] if-empty ;
 155
 156 : help-lint ( prefix -- ) run-help-lint typos. ;
 157
 158 : help-lint-all ( -- ) "" help-lint ;
 159
 160 : unlinked-words ( words -- seq )
 161     all-word-help [ article-parent not ] filter ;
 162
 163 : linked-undocumented-words ( -- seq )
 164     all-words
 165     [ word-help not ] filter
 166     [ article-parent ] filter
 167     [ "predicating" word-prop not ] filter ;
 168
 169 MAIN: help-lint