extra/help/lint/lint.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors sequences parser kernel help help.markup
   4 help.topics 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
  31     [ in>> ] [ out>> ] bi append
  32     [ (stack-picture) ] 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 f like ] curry contains? ;
  43
  44 : check-values ( word element -- )
  45     {
  46         { [ over "declared-effect" word-prop ] [ 2drop ] }
  47         { [ dup contains-funky-elements? not ] [ 2drop ] }
  48         { [ over macro? not ] [ 2drop ] }
  49         [
  50             [ effect-values >array ]
  51             [ extract-values >array ]
  52             bi* assert=
  53         ]
  54     } cond ;
  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 ;
  77
  78 : <help-error> ( topic delegate -- error )
  79     { set-help-error-topic set-delegate } help-error construct ;
  80
  81 M: help-error error.
  82     "In " write dup help-error-topic ($link) nl
  83     delegate error. ;
  84
  85 : check-something ( obj quot -- )
  86     flush [ <help-error> , ] recover ; inline
  87
  88 : check-word ( word -- )
  89     dup word-help [
  90         [
  91             dup word-help [
  92                 2dup check-examples
  93                 2dup check-values
  94                 2dup check-see-also
  95                 2dup check-modules
  96                 2dup drop check-rendering
  97             ] assert-depth 2drop
  98         ] check-something
  99     ] [ drop ] if ;
 100
 101 : check-words ( words -- ) [ check-word ] each ;
 102
 103 : check-article ( article -- )
 104     [
 105         [ dup check-rendering ] assert-depth drop
 106     ] check-something ;
 107
 108 : group-articles ( -- assoc )
 109     articles get keys
 110     vocabs [ dup vocab-docs-path swap ] H{ } map>assoc
 111     H{ } clone [
 112         [
 113             >r >r dup >link where dup
 114             [ first r> at r> push-at ]
 115             [ r> r> 2drop 2drop ]
 116             if
 117         ] 2curry each
 118     ] keep ;
 119
 120 : check-vocab ( vocab -- seq )
 121     "Checking " write dup write "..." print
 122     [
 123         dup words [ check-word ] each
 124         "vocab-articles" get at [ check-article ] each
 125     ] { } make ;
 126
 127 : run-help-lint ( prefix -- alist )
 128     [
 129         all-vocabs-seq [ vocab-name ] map "all-vocabs" set
 130         articles get keys "group-articles" set
 131         child-vocabs
 132         [ dup check-vocab ] { } map>assoc
 133         [ nip empty? not ] assoc-filter
 134     ] with-scope ;
 135
 136 : typos. ( assoc -- )
 137     dup empty? [
 138         drop
 139         "==== ALL CHECKS PASSED" print
 140     ] [
 141         [
 142             swap vocab-heading.
 143             [ error. nl ] each
 144         ] assoc-each
 145     ] if ;
 146
 147 : help-lint ( prefix -- ) run-help-lint typos. ;
 148
 149 : help-lint-all ( -- ) "" help-lint ;
 150
 151 : unlinked-words ( words -- seq )
 152     all-word-help [ article-parent not ] filter ;
 153
 154 : linked-undocumented-words ( -- seq )
 155     all-words
 156     [ word-help not ] filter
 157     [ article-parent ] filter
 158     [ "predicating" word-prop not ] filter ;
 159
 160 MAIN: help-lint