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 ;
  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 : check-values ( word element -- )
  46     {
  47         [ drop { [ symbol? ] [ macro? ] [ parsing-word? ] } 1|| ]
  48         [ drop "declared-effect" word-prop not ]
  49         [ nip contains-funky-elements? ]
  50         [
  51             [ effect-values >array ]
  52             [ extract-values >array ]
  53             bi* =
  54         ]
  55     } 2|| [ "$values don't match stack effect" throw ] unless ;
  56
  57 : check-see-also ( word element -- )
  58     nip \ $see-also swap elements [
  59         rest dup prune [ length ] bi@ assert=
  60     ] each ;
  61
  62 : vocab-exists? ( name -- ? )
  63     [ vocab ] [ "all-vocabs" get member? ] bi or ;
  64
  65 : check-modules ( element -- )
  66     \ $vocab-link swap elements [
  67         second
  68         vocab-exists? [ "$vocab-link to non-existent vocabulary" throw ] unless
  69     ] each ;
  70
  71 : check-rendering ( element -- )
  72     [ print-topic ] with-string-writer drop ;
  73
  74 : all-word-help ( words -- seq )
  75     [ word-help ] filter ;
  76
  77 TUPLE: help-error topic error ;
  78
  79 C: <help-error> help-error
  80
  81 M: help-error error.
  82     "In " write dup topic>> pprint nl
  83     error>> 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                 _ _ {
  93                     [ check-examples ]
  94                     [ check-values ]
  95                     [ check-see-also ]
  96                     [ [ check-rendering ] [ check-modules ] bi* ]
  97                 } 2cleave
  98             ] assert-depth
  99         ] check-something
 100     ] [ drop ] if ;
 101
 102 : check-words ( words -- ) [ check-word ] each ;
 103
 104 : check-article ( article -- )
 105     [
 106         dup article-content
 107         '[ _ check-rendering _ check-modules ]
 108         assert-depth
 109     ] check-something ;
 110
 111 : files>vocabs ( -- assoc )
 112     vocabs
 113     [ [ [ vocab-docs-path ] keep ] H{ } map>assoc ]
 114     [ [ [ vocab-source-path ] keep ] H{ } map>assoc ]
 115     bi assoc-union ;
 116
 117 : group-articles ( -- assoc )
 118     articles get keys
 119     files>vocabs
 120     H{ } clone [
 121         '[
 122             dup >link where dup
 123             [ first _ at _ push-at ] [ 2drop ] if
 124         ] each
 125     ] keep ;
 126
 127 : check-about ( vocab -- )
 128     [ vocab-help [ article drop ] when* ] check-something ;
 129
 130 : check-vocab ( vocab -- seq )
 131     "Checking " write dup write "..." print
 132     [
 133         [ check-about ]
 134         [ words [ check-word ] each ]
 135         [ "vocab-articles" get at [ check-article ] each ]
 136         tri
 137     ] { } make ;
 138
 139 : run-help-lint ( prefix -- alist )
 140     [
 141         all-vocabs-seq [ vocab-name ] map "all-vocabs" set
 142         group-articles "vocab-articles" set
 143         child-vocabs
 144         [ dup check-vocab ] { } map>assoc
 145         [ nip empty? not ] assoc-filter
 146     ] with-scope ;
 147
 148 : typos. ( assoc -- )
 149     [
 150         "==== ALL CHECKS PASSED" print
 151     ] [
 152         [
 153             swap vocab-heading.
 154             [ print-error nl ] each
 155         ] assoc-each
 156     ] if-empty ;
 157
 158 : help-lint ( prefix -- ) run-help-lint typos. ;
 159
 160 : help-lint-all ( -- ) "" help-lint ;
 161
 162 : unlinked-words ( words -- seq )
 163     all-word-help [ article-parent not ] filter ;
 164
 165 : linked-undocumented-words ( -- seq )
 166     all-words
 167     [ word-help not ] filter
 168     [ article-parent ] filter
 169     [ "predicating" word-prop not ] filter ;
 170
 171 MAIN: help-lint