basis/help/lint/lint.factor

   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 ;
   7 IN: help.lint
   8
   9 SYMBOL: lint-failures
  10
  11 lint-failures [ H{ } clone ] initialize
  12
  13 TUPLE: help-lint-error < source-file-error ;
  14
  15 SYMBOL: +help-lint-failure+
  16
  17 T{ error-type-holder
  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 ] }
  24 } define-error-type
  25 M: help-lint-error error-type drop +help-lint-failure+ ;
  26
  27 <PRIVATE
  28
  29 : <help-lint-error> ( error topic -- help-lint-error )
  30     help-lint-error new-source-file-error ;
  31
  32 PRIVATE>
  33
  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 ;
  38
  39 <PRIVATE
  40
  41 :: check-something ( topic quot -- )
  42     [ quot call( -- ) f ] [ ] recover
  43     topic notify-help-lint-error ; inline
  44
  45 : check-word ( word -- )
  46     [ with-file-vocabs ] vocabs-quot set
  47     dup "help" word-prop [
  48         [ >link ] keep '[
  49             _ dup "help" word-prop {
  50                 [ check-values ]
  51                 [ check-value-effects ]
  52                 [ check-class-description ]
  53                 [ nip check-nulls ]
  54                 [ nip check-see-also ]
  55                 [ nip check-markup ]
  56             } 2cleave
  57         ] check-something
  58     ] [ drop ] if ;
  59
  60 : check-article ( article -- )
  61     [ with-interactive-vocabs ] vocabs-quot set
  62     >link dup '[
  63         _
  64         [ check-article-title ]
  65         [ article-content check-markup ] bi
  66     ] check-something ;
  67
  68 : check-about ( vocab -- )
  69     <vocab-link> dup
  70     '[ _ vocab-help [ lookup-article drop ] when* ] check-something ;
  71
  72 : help-lint-vocab ( vocab -- )
  73     "Checking " write dup vocab-name write "..." print flush
  74     [ check-about ]
  75     [ vocab-words [ check-word ] each ]
  76     [ vocab-articles get at [ check-article ] each ]
  77     tri ;
  78
  79 : help-lint-vocabs ( vocabs -- )
  80     [
  81         auto-use? off
  82         group-articles vocab-articles set
  83         [ help-lint-vocab ] each
  84     ] with-scope ;
  85
  86 PRIVATE>
  87
  88 : help-lint ( prefix -- )
  89     loaded-child-vocab-names help-lint-vocabs ;
  90
  91 : help-lint-all ( -- ) "" help-lint ;
  92
  93 : :lint-failures ( -- ) lint-failures get values errors. ;
  94
  95 : unlinked-words ( vocab -- seq )
  96     vocab-words all-word-help [ article-parent ] reject ;
  97
  98 : linked-undocumented-words ( -- seq )
  99     all-words
 100     [ word-help ] reject
 101     [ article-parent ] filter
 102     [ predicate? ] reject ;
 103
 104 : test-lint-main ( -- )
 105     command-line get [
 106         dup vocab-roots get member? [
 107             "" vocabs-to-load [ require-all ] keep
 108         ] [
 109             [ load ] [ loaded-child-vocab-names ] bi
 110         ] if help-lint-vocabs
 111     ] each
 112     lint-failures get assoc-empty?
 113     [ [ "==== FAILING LINT" print :lint-failures flush ] unless ]
 114     [ 0 1 ? exit ] bi ;
 115
 116 MAIN: test-lint-main