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 kernel namespaces parser prettyprint
   4 sequences words assocs definitions generic quotations effects
   5 slots continuations classes.tuple debugger combinators vocabs
   6 help.stylesheet help.topics help.crossref help.markup sorting
   7 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 swap 2array ,
  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 M: word article-content
  62     [
  63         \ $vocabulary over 2array ,
  64         dup word-help %
  65         \ $related over 2array ,
  66         dup get-global [ \ $value swap 2array , ] when*
  67         \ $definition swap 2array ,
  68     ] { } make ;
  69
  70 M: word article-parent "help-parent" word-prop ;
  71
  72 M: word set-article-parent swap "help-parent" set-word-prop ;
  73
  74 : $doc-path ( article -- )
  75     help-path dup empty? [
  76         drop
  77     ] [
  78         [
  79             help-path-style get [
  80                 "Parent topics: " write $links
  81             ] with-style
  82         ] ($block)
  83     ] if ;
  84
  85 : $title ( topic -- )
  86     title-style get [
  87         title-style get [
  88             dup [
  89                 dup article-title swap >link write-object
  90             ] ($block) $doc-path
  91         ] with-nesting
  92     ] with-style nl ;
  93
  94 : help ( topic -- )
  95     last-element off dup $title
  96     article-content print-content nl ;
  97
  98 : about ( vocab -- )
  99     dup require
 100     dup vocab [ ] [
 101         "No such vocabulary: " prepend throw
 102     ] ?if
 103     dup vocab-help [
 104         help
 105     ] [
 106         "The " write vocab-name write
 107         " vocabulary does not define a main help article." print
 108         "To define one, refer to \\ ABOUT: help" print
 109     ] ?if ;
 110
 111 : ($index) ( articles -- )
 112     sort-articles [ \ $subsection swap 2array ] map print-element ;
 113
 114 : $index ( element -- )
 115     first call dup empty?
 116     [ drop ] [ ($index) ] if ;
 117
 118 : $about ( element -- )
 119     first vocab-help [ 1array $subsection ] when* ;
 120
 121 : :help-debugger ( -- )
 122     nl
 123     "Debugger commands:" print
 124     nl
 125     ":s    - data stack at error time" print
 126     ":r    - retain stack at error time" print
 127     ":c    - call stack at error time" print
 128     ":edit - jump to source location (parse errors only)" print
 129
 130     ":get  ( var -- value ) accesses variables at time of the error" print
 131     ":vars - list all variables at error time" print ;
 132
 133 : :help ( -- )
 134     error get error-help [ help ] [ "No help for this error. " print ] if*
 135     :help-debugger ;
 136
 137 : remove-article ( name -- )
 138     dup articles get key? [
 139         dup unxref-article
 140         dup articles get delete-at
 141     ] when drop ;
 142
 143 : add-article ( article name -- )
 144     [ remove-article ] keep
 145     [ articles get set-at ] keep
 146     xref-article ;
 147
 148 : remove-word-help ( word -- )
 149     dup word-help [ dup unxref-article ] when
 150     f "help" set-word-prop ;
 151
 152 : set-word-help ( content word -- )
 153     [ remove-word-help ] keep
 154     [ swap "help" set-word-prop ] keep
 155     xref-article ;