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     >link
 116     last-element off dup $title
 117     article-content print-content nl ;
 118
 119 SYMBOL: help-hook
 120
 121 help-hook global [ [ print-topic ] or ] change-at
 122
 123 : help ( topic -- )
 124     help-hook get call ;
 125
 126 : about ( vocab -- )
 127     dup require
 128     dup vocab [ ] [
 129         "No such vocabulary: " prepend throw
 130     ] ?if
 131     dup vocab-help [
 132         help
 133     ] [
 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 ;