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 assocs definitions generic
   5 quotations effects slots continuations classes.tuple debugger
   6 combinators vocabs help.stylesheet help.topics help.crossref
   7 help.markup sorting classes vocabs.loader ;
   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 } { "?" "a 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     \ $error-description swap word-help elements empty? not ;
  43
  44 : sort-articles ( seq -- newseq )
  45     [ dup article-title ] { } map>assoc sort-values keys ;
  46
  47 : all-errors ( -- seq )
  48     all-words [ error? ] filter sort-articles ;
  49
  50 M: word article-name name>> ;
  51
  52 M: word article-title
  53     dup [ parsing-word? ] [ symbol? ] bi or [
  54         name>>
  55     ] [
  56         [ name>> ]
  57         [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
  58         append
  59     ] if ;
  60
  61 <PRIVATE
  62
  63 : (word-help) ( word -- element )
  64     [
  65         {
  66             [ \ $vocabulary swap 2array , ]
  67             [ word-help % ]
  68             [ \ $related swap 2array , ]
  69             [ get-global [ \ $value swap 2array , ] when* ]
  70             [ \ $definition swap 2array , ]
  71         } cleave
  72     ] { } make ;
  73
  74 M: word article-content (word-help) ;
  75
  76 <PRIVATE
  77
  78 : word-with-methods ( word -- elements )
  79     [
  80         [ (word-help) % ]
  81         [ \ $methods swap 2array , ]
  82         bi
  83     ] { } make ;
  84
  85 PRIVATE>
  86
  87 M: generic article-content word-with-methods ;
  88
  89 M: class article-content word-with-methods ;
  90
  91 M: word article-parent "help-parent" word-prop ;
  92
  93 M: word set-article-parent swap "help-parent" set-word-prop ;
  94
  95 : $doc-path ( article -- )
  96     help-path [
  97         [
  98             help-path-style get [
  99                 "Parent topics: " write $links
 100             ] with-style
 101         ] ($block)
 102     ] unless-empty ;
 103
 104 : $title ( topic -- )
 105     title-style get [
 106         title-style get [
 107             dup [
 108                 dup article-title swap >link write-object
 109             ] ($block) $doc-path
 110         ] with-nesting
 111     ] with-style nl ;
 112
 113 : print-topic ( topic -- )
 114     last-element off dup $title
 115     article-content print-content nl ;
 116
 117 SYMBOL: help-hook
 118
 119 help-hook global [ [ print-topic ] or ] change-at
 120
 121 : help ( topic -- )
 122     help-hook get call ;
 123
 124 : about ( vocab -- )
 125     dup require
 126     dup vocab [ ] [
 127         "No such vocabulary: " prepend throw
 128     ] ?if
 129     dup vocab-help [
 130         help
 131     ] [
 132         "The " write vocab-name write
 133         " vocabulary does not define a main help article." print
 134         "To define one, refer to \\ ABOUT: help" print
 135     ] ?if ;
 136
 137 : ($index) ( articles -- )
 138     sort-articles [ \ $subsection swap 2array ] map print-element ;
 139
 140 : $index ( element -- )
 141     first call [ ($index) ] unless-empty ;
 142
 143 : $about ( element -- )
 144     first vocab-help [ 1array $subsection ] when* ;
 145
 146 : :help-debugger ( -- )
 147     nl
 148     "Debugger commands:" print
 149     nl
 150     ":s    - data stack at error time" print
 151     ":r    - retain stack at error time" print
 152     ":c    - call stack at error time" print
 153     ":edit - jump to source location (parse errors only)" print
 154
 155     ":get  ( var -- value ) accesses variables at time of the error" print
 156     ":vars - list all variables at error time" print ;
 157
 158 : (:help) ( error -- )
 159     error-help [ help ] [ "No help for this error. " print ] if*
 160     :help-debugger ;
 161
 162 : :help ( -- )
 163     error get (:help) ;
 164
 165 : remove-article ( name -- )
 166     dup articles get key? [
 167         dup unxref-article
 168         dup articles get delete-at
 169     ] when drop ;
 170
 171 : add-article ( article name -- )
 172     [ remove-article ] keep
 173     [ articles get set-at ] keep
 174     xref-article ;
 175
 176 : remove-word-help ( word -- )
 177     dup word-help [ dup unxref-article ] when
 178     f "help" set-word-prop ;
 179
 180 : set-word-help ( content word -- )
 181     [ remove-word-help ] keep
 182     [ swap "help" set-word-prop ] keep
 183     xref-article ;