1 ! Copyright (C) 2006, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: assocs classes combinators command-line continuations
4 help help.lint.checks help.topics io kernel listener namespaces
5 parser sequences source-files.errors system tools.errors vocabs
6 vocabs.hierarchy vocabs.hierarchy.private vocabs.loader words ;
11 lint-failures [ H{ } clone ] initialize
13 TUPLE: help-lint-error < source-file-error ;
15 SYMBOL: +help-lint-failure+
18 { type +help-lint-failure+ }
19 { word ":lint-failures" }
20 { plural "help lint failures" }
21 { icon "vocab:ui/tools/error-list/icons/help-lint-error.png" }
22 { quot [ lint-failures get values ] }
23 { forget-quot [ lint-failures get delete-at ] }
25 M: help-lint-error error-type drop +help-lint-failure+ ;
29 : <help-lint-error> ( error topic -- help-lint-error )
30 help-lint-error new-source-file-error ;
34 : notify-help-lint-error ( error topic -- )
35 lint-failures get pick
36 [ [ [ <help-lint-error> ] keep ] dip set-at ] [ delete-at drop ] if
37 notify-error-observers ;
41 :: check-something ( topic quot -- )
42 [ quot call( -- ) f ] [ ] recover
43 topic notify-help-lint-error ; inline
45 : check-word ( word -- )
46 [ with-file-vocabs ] vocabs-quot set
47 dup "help" word-prop [
49 _ dup "help" word-prop {
51 [ check-value-effects ]
52 [ check-class-description ]
53 [ nip check-see-also ]
59 : check-article ( article -- )
60 [ with-interactive-vocabs ] vocabs-quot set
63 [ check-article-title ]
64 [ article-content check-markup ] bi
67 : check-about ( vocab -- )
69 '[ _ vocab-help [ lookup-article drop ] when* ] check-something ;
71 : help-lint-vocab ( vocab -- )
72 "Checking " write dup vocab-name write "..." print flush
74 [ vocab-words [ check-word ] each ]
75 [ vocab-articles get at [ check-article ] each ]
78 : help-lint-vocabs ( vocabs -- )
81 group-articles vocab-articles set
82 [ help-lint-vocab ] each
87 : help-lint ( prefix -- )
88 loaded-child-vocab-names help-lint-vocabs ;
90 : help-lint-all ( -- ) "" help-lint ;
92 : :lint-failures ( -- ) lint-failures get values errors. ;
94 : unlinked-words ( vocab -- seq )
95 vocab-words all-word-help [ article-parent ] reject ;
97 : linked-undocumented-words ( -- seq )
100 [ article-parent ] filter
101 [ predicate? ] reject ;
103 : test-lint-main ( -- )
105 dup vocab-roots get member? [
106 "" vocabs-to-load [ require-all ] keep
108 [ load ] [ loaded-child-vocab-names ] bi
109 ] if help-lint-vocabs
111 lint-failures get assoc-empty?
112 [ [ "==== FAILING LINT" print :lint-failures flush ] unless ]