basis/help/help.factor

   1 ! Copyright (C) 2005, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays io io.styles kernel namespaces make
   4 parser prettyprint sequences words words.symbol assocs
   5 definitions generic quotations effects slots continuations
   6 classes.tuple debugger combinators vocabs help.stylesheet
   7 help.topics help.crossref help.markup sorting classes
   8 vocabs.loader ;
   9 IN: help
  10
  11 GENERIC: word-help* ( word -- content )
  12
  13 : word-help ( word -- content )
  14     dup "help" word-prop [ ] [
  15         dup word-help* dup
  16         [ swap 2array 1array ] [ 2drop f ] if
  17     ] ?if ;
  18
  19 : $predicate ( element -- )
  20     { { "object" object } { "?" "a boolean" } } $values
  21     [
  22         "Tests if the object is an instance of the " ,
  23         first "predicating" word-prop <$link> ,
  24         " class." ,
  25     ] { } make $description ;
  26
  27 M: word word-help* drop f ;
  28
  29 M: predicate word-help* drop \ $predicate ;
  30
  31 : all-articles ( -- seq )
  32     articles get keys
  33     all-words [ word-help ] filter append ;
  34
  35 : orphan-articles ( -- seq )
  36     articles get keys
  37     [ article-parent not ] filter ;
  38
  39 : xref-help ( -- )
  40     all-articles [ xref-article ] each ;
  41
  42 : error? ( word -- ? )
  43     \ $error-description swap word-help elements empty? not ;
  44
  45 : sort-articles ( seq -- newseq )
  46     [ dup article-title ] { } map>assoc sort-values keys ;
  47
  48 : all-errors ( -- seq )
  49     all-words [ error? ] filter sort-articles ;
  50
  51 M: word article-name name>> ;
  52
  53 M: word article-title
  54     dup [ parsing-word? ] [ symbol? ] bi or [
  55         name>>
  56     ] [
  57         [ name>> ]
  58         [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
  59         append
  60     ] if ;
  61
  62 <PRIVATE
  63
  64 : (word-help) ( word -- element )
  65     [
  66         {
  67             [ \ $vocabulary swap 2array , ]
  68             [ word-help % ]
  69             [ \ $related swap 2array , ]
  70             [ get-global [ \ $value swap 2array , ] when* ]
  71             [ \ $definition swap 2array , ]
  72         } cleave
  73     ] { } make ;
  74
  75 M: word article-content (word-help) ;
  76
  77 <PRIVATE
  78
  79 : word-with-methods ( word -- elements )
  80     [
  81         [ (word-help) % ]
  82         [ \ $methods swap 2array , ]
  83         bi
  84     ] { } make ;
  85
  86 PRIVATE>
  87
  88 M: generic article-content word-with-methods ;
  89
  90 M: class article-content word-with-methods ;
  91
  92 M: word article-parent "help-parent" word-prop ;
  93
  94 M: word set-article-parent swap "help-parent" set-word-prop ;
  95
  96 : ($title) ( topic -- )
  97     [ [ article-title ] [ >link ] bi write-object ] ($block) ;
  98
  99 : $navigation-row ( content element label -- )
 100     [ prefix 1array ] dip prefix , ;
 101
 102 : $navigation-table ( topic -- )
 103     [
 104         [ help-path [ \ $links "Up:" $navigation-row ] unless-empty ]
 105         [ prev-article [ 1array \ $long-link "Prev:" $navigation-row ] when* ]
 106         [ next-article [ 1array \ $long-link "Next:" $navigation-row ] when* ]
 107         tri
 108     ] { } make [ $table ] unless-empty ;
 109
 110 : $title ( topic -- )
 111     title-style get [
 112         title-style get [
 113             [ ($title) ]
 114             [ help-path-style get [ $navigation-table ] with-style ] bi
 115         ] with-nesting
 116     ] with-style nl ;
 117
 118 : print-topic ( topic -- )
 119     >link
 120     last-element off
 121     [ $title ] [ article-content print-content nl ] bi ;
 122
 123 SYMBOL: help-hook
 124
 125 help-hook [ [ print-topic ] ] initialize
 126
 127 : help ( topic -- )
 128     help-hook get call( topic -- ) ;
 129
 130 : about ( vocab -- )
 131     dup require
 132     dup vocab [ ] [ no-vocab ] ?if
 133     dup vocab-help [ help ] [
 134         "The " write vocab-name write
 135         " vocabulary does not define a main help article." print
 136         "To define one, refer to \\ ABOUT: help" print
 137     ] ?if ;
 138
 139 : ($index) ( articles -- )
 140     sort-articles [ \ $subsection swap 2array ] map print-element ;
 141
 142 : $index ( element -- )
 143     first call [ ($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     dup articles get key? [
 169         dup unxref-article
 170         dup articles get delete-at
 171     ] when drop ;
 172
 173 : add-article ( article name -- )
 174     [ remove-article ] keep
 175     [ articles get set-at ] keep
 176     xref-article ;
 177
 178 : remove-word-help ( word -- )
 179     dup word-help [ dup unxref-article ] when
 180     f "help" set-word-prop ;
 181
 182 : set-word-help ( content word -- )
 183     [ remove-word-help ] keep
 184     [ swap "help" set-word-prop ] keep
 185     xref-article ;