extra/help/lint/coverage/coverage.factor

   1 USING: accessors arrays classes classes.error combinators
   2 continuations english formatting generic help help.lint.checks
   3 help.markup io io.streams.string io.styles kernel math
   4 namespaces parser sequences sequences.deep sets sorting
   5 splitting strings summary vocabs vocabs.parser words words.alias ;
   6 FROM: namespaces => set ;
   7 IN: help.lint.coverage
   8
   9 TUPLE: word-help-coverage
  10     { word-name word initial: POSTPONE: f }
  11     { omitted-sections sequence initial: { } }
  12     { empty-examples? boolean initial: f }
  13     { 100%-coverage? boolean initial: f } ;
  14
  15 <PRIVATE
  16 ERROR: unloaded-vocab spec ;
  17
  18 M: unloaded-vocab summary
  19     drop "Not a loaded vocabulary" ;
  20
  21 CONSTANT: ignored-words {
  22     $low-level-note
  23     $prettyprinting-note
  24     $values-x/y
  25     $parsing-note
  26     $io-error
  27     $shuffle
  28     $complex-shuffle
  29     $nl
  30 }
  31
  32 : (word-help) ( word -- content )
  33     dup "help" word-prop [ ] [ word-help* ] ?if ;
  34
  35 GENERIC: write-object* ( object -- )
  36 M: string write-object* write ;
  37 M: pair write-object* first2 write-object ;
  38
  39 : write-object-seq ( object-seq -- )
  40     [ dup array? [
  41             dup ?first array? [
  42                 [ write-object* ] each
  43             ] [ write-object* ] if
  44         ] [ write ] if
  45     ] each ; inline
  46
  47 : (assemble-word-metadata) ( vec word -- vec )
  48     [
  49         [ "[" ] dip vocabulary>> dup lookup-vocab 2array "] "
  50             3array over push-all
  51     ] [
  52         [ name>> ] keep 2array ": "
  53         2array over push-all
  54     ] bi ; inline
  55
  56 : (assemble-empty-examples) ( vec coverage -- vec )
  57     empty-examples?>> [ "empty " \ $examples [ name>> ] keep 2array "; "
  58         3array over push-all
  59     ] when ;
  60
  61 : (assemble-omitted-sections) ( vec coverage -- vec )
  62     omitted-sections>> [
  63         length "section" ?pluralize ": " append
  64     ] [
  65         [ [ name>> ] keep 2array ] map "and" comma-list
  66     ] bi
  67     [ "needs help " ] 2dip
  68     3array over push-all ;
  69
  70 : (assemble-full-coverage) ( vec coverage -- vec )
  71     drop "full help coverage" over push ;
  72
  73 : (present-coverage) ( coverage-report -- )
  74     [ V{ } clone ] dip
  75     [ word-name>> (assemble-word-metadata) ] keep
  76     dup 100%-coverage?>>
  77     [ (assemble-full-coverage) ] [
  78         [ (assemble-empty-examples) ]
  79         [ (assemble-omitted-sections) ] bi
  80     ] if "\n" over push write-object-seq ;
  81
  82 M: word-help-coverage summary
  83     [ (present-coverage) ] with-string-writer ; inline
  84
  85 : find-word ( name -- word/f )
  86     dup words-named dup length {
  87         { 0 [ 2drop f ] }
  88         { 1 [ first nip ] }
  89         [ drop <ambiguous-use-error> throw-restarts ]
  90     } case ;
  91
  92 : sorted-loaded-child-vocabs ( prefix -- assoc )
  93     loaded-child-vocab-names natural-sort ; inline
  94
  95 : filter-private ( seq -- no-private )
  96     [ ".private" ?tail nip ] reject ; inline
  97
  98 : ?remove-$values ( word spec -- spec )
  99     \ $values over member? [
 100         swap "declared-effect" word-prop [
 101             [ in>> ] [ out>> ] bi append [
 102                 \ $values swap remove
 103             ] [ drop ] if-empty
 104     ] when* ] [ nip ] if ;
 105
 106 : should-define ( word -- spec )
 107     dup {
 108         ! predicates have generated docs
 109         { [ dup predicate? ]   [ drop { } ] }
 110         { [ dup primitive? ]   [ drop { $description } ] }
 111         ! aliases should describe why they exist but ideally $values should be
 112         ! automatically inherited from the aliased word's docs
 113         { [ dup alias? ]       [ drop { $values $description } ] }
 114         { [ dup error-class? ] [ drop { $values $description $error-description } ] }
 115         { [ dup class? ]       [ drop { $class-description } ] }
 116         { [ dup generic? ]     [ drop { $values $contract $examples } ] }
 117         { [ dup word? ]        [ drop { $values $description $examples } ] }
 118     } cond ?remove-$values ;
 119
 120 : word-defines-sections ( word -- seq )
 121     (word-help) [ ignored-words member? ] reject [ ?first ] map ;
 122
 123 ! only words that need examples, need to have them nonempty
 124 ! not defining examples is not the same as an empty { $examples }
 125 : empty-examples? ( word -- ? )
 126     (word-help) \ $examples swap elements [ f ] [ first rest empty? ] if-empty ;
 127
 128 : missing-sections ( word -- missing )
 129     [ should-define ] [ word-defines-sections ] bi diff ;
 130
 131 GENERIC: loaded-vocab? ( vocab-spec -- ? )
 132 M: string loaded-vocab? lookup-vocab >boolean ;
 133 M: vocab loaded-vocab? source-loaded?>> +done+ = ;
 134 PRIVATE>
 135
 136 GENERIC: <word-help-coverage> ( word -- coverage )
 137 M: word <word-help-coverage>
 138     dup [ missing-sections ] [ empty-examples? ] bi
 139     2dup [ empty? ] both? word-help-coverage boa ; inline
 140
 141 M: string <word-help-coverage>
 142     find-word <word-help-coverage> ; inline
 143
 144 : <vocab-help-coverage> ( vocab-spec -- coverage )
 145     dup loaded-vocab? [
 146         [ auto-use? off vocab-words natural-sort [ <word-help-coverage> ] map ] with-scope
 147     ] [
 148         unloaded-vocab
 149     ] if ;
 150
 151 : <prefix-help-coverage> ( prefix private? -- coverage )
 152     over loaded-vocab? [
 153             [ auto-use? off group-articles vocab-articles set
 154             [ sorted-loaded-child-vocabs ] dip not
 155             [ filter-private ] when
 156             [ <vocab-help-coverage> ] map flatten
 157         ] with-scope
 158     ] [
 159         drop unloaded-vocab
 160     ] if ;
 161
 162 GENERIC: help-coverage. ( coverage -- )
 163 M: sequence help-coverage.
 164     [
 165         [ help-coverage. ] each
 166     ] [
 167         [ [ 100%-coverage?>> ] count ] [ length ] bi /f
 168         100 *
 169         "\n%3.1f%% of words have complete documentation\n"
 170         printf
 171     ] bi ; recursive
 172
 173 M: word-help-coverage help-coverage.
 174     (present-coverage) ;
 175
 176 : word-help-coverage. ( word-spec -- ) <word-help-coverage> help-coverage. ;
 177 : vocab-help-coverage. ( vocab-spec -- ) <vocab-help-coverage> help-coverage. ;
 178 : prefix-help-coverage. ( prefix-spec private? -- ) <prefix-help-coverage> help-coverage. ;