basis/help/help.factor

   1 ! Copyright (C) 2005, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes classes.tuple
   4 combinators combinators.short-circuit continuations debugger
   5 effects generic help.crossref help.markup help.stylesheet
   6 help.topics io io.styles kernel make namespaces prettyprint
   7 sequences sorting vocabs words words.symbol ;
   8 IN: help
   9
  10 GENERIC: word-help* ( word -- content )
  11
  12 : word-help ( word -- content )
  13     dup "help" word-prop [ ] [
  14         dup word-help* dup
  15         [ swap 2array 1array ] [ 2drop f ] if
  16     ] ?if ;
  17
  18 : $predicate ( element -- )
  19     { { "object" object } { "?" boolean } } $values
  20     [
  21         "Tests if the object is an instance of the " ,
  22         first "predicating" word-prop <$link> ,
  23         " class." ,
  24     ] { } make $description ;
  25
  26 M: word word-help* drop f ;
  27
  28 M: predicate word-help* drop \ $predicate ;
  29
  30 : all-articles ( -- seq )
  31     articles get keys
  32     all-words [ word-help ] filter append ;
  33
  34 : orphan-articles ( -- seq )
  35     articles get keys
  36     [ article-parent not ] filter ;
  37
  38 : xref-help ( -- )
  39     all-articles [ xref-article ] each ;
  40
  41 : error? ( word -- ? )
  42     {
  43         [ error-class? ]
  44         [ \ $error-description swap word-help elements empty? not ]
  45     } 1|| ;
  46
  47 : sort-articles ( seq -- newseq )
  48     [ dup article-title ] { } map>assoc sort-values keys ;
  49
  50 : all-errors ( -- seq )
  51     all-words [ error? ] filter sort-articles ;
  52
  53 M: word valid-article? drop t ;
  54
  55 M: word article-name name>> ;
  56
  57 M: word article-title
  58     dup [ parsing-word? ] [ symbol? ] bi or [
  59         name>>
  60     ] [
  61         [ unparse ]
  62         [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
  63         append
  64     ] if ;
  65
  66 <PRIVATE
  67
  68 : (word-help) ( word -- element )
  69     [
  70         {
  71             [ \ $vocabulary swap 2array , ]
  72             [ word-help % ]
  73             [ \ $related swap 2array , ]
  74             [ dup is-global [ get-global \ $value swap 2array , ] [ drop ] if ]
  75             [ \ $definition swap 2array , ]
  76         } cleave
  77     ] { } make ;
  78
  79 M: word article-content (word-help) ;
  80
  81 : word-with-methods ( word -- elements )
  82     [
  83         [ (word-help) % ]
  84         [ \ $methods swap 2array , ]
  85         bi
  86     ] { } make ;
  87
  88 PRIVATE>
  89
  90 M: generic article-content word-with-methods ;
  91
  92 M: class article-content word-with-methods ;
  93
  94 M: word article-parent "help-parent" word-prop ;
  95
  96 M: word set-article-parent swap "help-parent" set-word-prop ;
  97
  98 : ($title) ( topic -- )
  99     [ [ article-title ] [ >link ] bi write-object ] ($block) ;
 100
 101 : $navigation-row ( content element label -- )
 102     [ prefix 1array ] dip prefix , ;
 103
 104 : ($navigation-table) ( element -- )
 105     help-path-style get table-style [ $table ] with-variable ;
 106
 107 : $navigation-table ( topic -- )
 108     [
 109         [ prev-article [ 1array \ $long-link "Prev:" $navigation-row ] when* ]
 110         [ next-article [ 1array \ $long-link "Next:" $navigation-row ] when* ]
 111         bi
 112     ] { } make [ ($navigation-table) ] unless-empty ;
 113
 114 : ($navigation) ( topic -- )
 115     help-path-style get [
 116         [ help-path [ reverse $breadcrumbs ] unless-empty ]
 117         [ $navigation-table ] bi
 118     ] with-style ;
 119
 120 : $title ( topic -- )
 121     title-style get [
 122         title-style get [
 123             [ ($title) ] [ ($navigation) ] bi
 124         ] with-nesting
 125     ] with-style ;
 126
 127 : print-topic ( topic -- )
 128     >link
 129     last-element off
 130     [ $title ] [ ($blank-line) article-content print-content nl ] bi ;
 131
 132 SYMBOL: help-hook
 133
 134 help-hook [ [ print-topic ] ] initialize
 135
 136 : help ( topic -- )
 137     help-hook get call( topic -- ) ;
 138
 139 : ($index) ( articles -- )
 140     sort-articles [ \ $subsection swap 2array ] map print-element ;
 141
 142 : $index ( element -- )
 143     first call( -- seq ) [ ($index) ] unless-empty ;
 144
 145 : $about ( element -- )
 146     first vocab-help [ 1array $subsection ] when* ;
 147
 148 : :help-debugger ( -- )
 149     nl
 150     "Debugger commands:" print
 151     nl
 152     ":s    - data stack at error time" print
 153     ":r    - retain stack at error time" print
 154     ":c    - call stack at error time" print
 155     ":edit - jump to source location (parse errors only)" print
 156
 157     ":get  ( var -- value ) accesses variables at time of the error" print
 158     ":vars - list all variables at error time" print ;
 159
 160 : (:help) ( error -- )
 161     error-help [ help ] [ "No help for this error. " print ] if*
 162     :help-debugger ;
 163
 164 : :help ( -- )
 165     error get (:help) ;
 166
 167 : remove-article ( name -- )
 168     articles get delete-at ;
 169
 170 : add-article ( article name -- )
 171     [ remove-article ] keep
 172     [ articles get set-at ] keep
 173     xref-article ;
 174
 175 : remove-word-help ( word -- )
 176     f "help" set-word-prop ;
 177
 178 : set-word-help ( content word -- )
 179     [ remove-word-help ] keep
 180     [ swap "help" set-word-prop ] keep
 181     xref-article ;