extra/help/lint/lint.factor

   1 ! Copyright (C) 2006, 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: sequences parser kernel help help.markup help.topics
   4 words strings classes tools.vocabs namespaces io
   5 io.streams.string prettyprint definitions arrays vectors
   6 combinators splitting debugger hashtables sorting effects vocabs
   7 vocabs.loader assocs editors continuations classes.predicate
   8 macros math sets ;
   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 dup effect-in swap effect-out append [
  31         {
  32             { [ dup word? ] [ word-name ] }
  33             { [ dup integer? ] [ drop "object" ] }
  34             { [ dup string? ] [ ] }
  35         } cond
  36     ] map prune natural-sort ;
  37
  38 : contains-funky-elements? ( element -- ? )
  39     {
  40         $shuffle
  41         $values-x/y
  42         $predicate
  43         $class-description
  44         $error-description
  45     } swap [ elements f like ] curry contains? ;
  46
  47 : check-values ( word element -- )
  48     {
  49         { [ over "declared-effect" word-prop ] [ 2drop ] }
  50         { [ dup contains-funky-elements? not ] [ 2drop ] }
  51         { [ over macro? not ] [ 2drop ] }
  52         [
  53             [ effect-values >array ]
  54             [ extract-values >array ]
  55             bi* assert=
  56         ]
  57     } cond ;
  58
  59 : check-see-also ( word element -- )
  60     nip \ $see-also swap elements [
  61         rest dup prune [ length ] bi@ assert=
  62     ] each ;
  63
  64 : vocab-exists? ( name -- ? )
  65     dup vocab swap "all-vocabs" get member? or ;
  66
  67 : check-modules ( word element -- )
  68     nip \ $vocab-link swap elements [
  69         second
  70         vocab-exists? [ "Missing vocabulary" throw ] unless
  71     ] each ;
  72
  73 : check-rendering ( word element -- )
  74     [ help ] with-string-writer drop ;
  75
  76 : all-word-help ( words -- seq )
  77     [ word-help ] filter ;
  78
  79 TUPLE: help-error topic ;
  80
  81 : <help-error> ( topic delegate -- error )
  82     { set-help-error-topic set-delegate } help-error construct ;
  83
  84 M: help-error error.
  85     "In " write dup help-error-topic ($link) nl
  86     delegate error. ;
  87
  88 : check-something ( obj quot -- )
  89     flush [ <help-error> , ] recover ; inline
  90
  91 : check-word ( word -- )
  92     dup word-help [
  93         [
  94             dup word-help [
  95                 2dup check-examples
  96                 2dup check-values
  97                 2dup check-see-also
  98                 2dup check-modules
  99                 2dup drop check-rendering
 100             ] assert-depth 2drop
 101         ] check-something
 102     ] [ drop ] if ;
 103
 104 : check-words ( words -- ) [ check-word ] each ;
 105
 106 : check-article ( article -- )
 107     [
 108         [ dup check-rendering ] assert-depth drop
 109     ] check-something ;
 110
 111 : group-articles ( -- assoc )
 112     articles get keys
 113     vocabs [ dup vocab-docs-path swap ] H{ } map>assoc
 114     H{ } clone [
 115         [
 116             >r >r dup >link where dup
 117             [ first r> at r> push-at ]
 118             [ r> r> 2drop 2drop ]
 119             if
 120         ] 2curry each
 121     ] keep ;
 122
 123 : check-vocab ( vocab -- seq )
 124     "Checking " write dup write "..." print
 125     [
 126         dup words [ check-word ] each
 127         "vocab-articles" get at [ check-article ] each
 128     ] { } make ;
 129
 130 : run-help-lint ( prefix -- alist )
 131     [
 132         all-vocabs-seq [ vocab-name ] map "all-vocabs" set
 133         articles get keys "group-articles" set
 134         child-vocabs
 135         [ dup check-vocab ] { } map>assoc
 136         [ nip empty? not ] assoc-filter
 137     ] with-scope ;
 138
 139 : typos. ( assoc -- )
 140     dup empty? [
 141         drop
 142         "==== ALL CHECKS PASSED" print
 143     ] [
 144         [
 145             swap vocab-heading.
 146             [ error. nl ] each
 147         ] assoc-each
 148     ] if ;
 149
 150 : help-lint ( prefix -- ) run-help-lint typos. ;
 151
 152 : help-lint-all ( -- ) "" help-lint ;
 153
 154 : unlinked-words ( words -- seq )
 155     all-word-help [ article-parent not ] filter ;
 156
 157 : linked-undocumented-words ( -- seq )
 158     all-words
 159     [ word-help not ] filter
 160     [ article-parent ] filter
 161     [ "predicating" word-prop not ] filter ;
 162
 163 MAIN: help-lint