basis/help/help.factor

   1 ! Copyright (C) 2005, 2008 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 : $doc-path ( article -- )
  97     help-path [
  98         [
  99             help-path-style get [
 100                 "Parent topics: " write $links
 101             ] with-style
 102         ] ($block)
 103     ] unless-empty ;
 104
 105 : $title ( topic -- )
 106     title-style get [
 107         title-style get [
 108             dup [
 109                 dup article-title swap >link write-object
 110             ] ($block) $doc-path
 111         ] with-nesting
 112     ] with-style nl ;
 113
 114 : print-topic ( topic -- )
 115     last-element off dup $title
 116     article-content print-content nl ;
 117
 118 SYMBOL: help-hook
 119
 120 help-hook global [ [ print-topic ] or ] change-at
 121
 122 : help ( topic -- )
 123     help-hook get call ;
 124
 125 : about ( vocab -- )
 126     dup require
 127     dup vocab [ ] [
 128         "No such vocabulary: " prepend throw
 129     ] ?if
 130     dup vocab-help [
 131         help
 132     ] [
 133         "The " write vocab-name write
 134         " vocabulary does not define a main help article." print
 135         "To define one, refer to \\ ABOUT: help" print
 136     ] ?if ;
 137
 138 : ($index) ( articles -- )
 139     sort-articles [ \ $subsection swap 2array ] map print-element ;
 140
 141 : $index ( element -- )
 142     first call [ ($index) ] unless-empty ;
 143
 144 : $about ( element -- )
 145     first vocab-help [ 1array $subsection ] when* ;
 146
 147 : :help-debugger ( -- )
 148     nl
 149     "Debugger commands:" print
 150     nl
 151     ":s    - data stack at error time" print
 152     ":r    - retain stack at error time" print
 153     ":c    - call stack at error time" print
 154     ":edit - jump to source location (parse errors only)" print
 155
 156     ":get  ( var -- value ) accesses variables at time of the error" print
 157     ":vars - list all variables at error time" print ;
 158
 159 : (:help) ( error -- )
 160     error-help [ help ] [ "No help for this error. " print ] if*
 161     :help-debugger ;
 162
 163 : :help ( -- )
 164     error get (:help) ;
 165
 166 : remove-article ( name -- )
 167     dup articles get key? [
 168         dup unxref-article
 169         dup articles get delete-at
 170     ] when drop ;
 171
 172 : add-article ( article name -- )
 173     [ remove-article ] keep
 174     [ articles get set-at ] keep
 175     xref-article ;
 176
 177 : remove-word-help ( word -- )
 178     dup word-help [ dup unxref-article ] when
 179     f "help" set-word-prop ;
 180
 181 : set-word-help ( content word -- )
 182     [ remove-word-help ] keep
 183     [ swap "help" set-word-prop ] keep
 184     xref-article ;