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 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 [
  76         [
  77             help-path-style get [
  78                 "Parent topics: " write $links
  79             ] with-style
  80         ] ($block)
  81     ] unless-empty ;
  82
  83 : $title ( topic -- )
  84     title-style get [
  85         title-style get [
  86             dup [
  87                 dup article-title swap >link write-object
  88             ] ($block) $doc-path
  89         ] with-nesting
  90     ] with-style nl ;
  91
  92 : help ( topic -- )
  93     last-element off dup $title
  94     article-content print-content nl ;
  95
  96 : about ( vocab -- )
  97     dup require
  98     dup vocab [ ] [
  99         "No such vocabulary: " prepend throw
 100     ] ?if
 101     dup vocab-help [
 102         help
 103     ] [
 104         "The " write vocab-name write
 105         " vocabulary does not define a main help article." print
 106         "To define one, refer to \\ ABOUT: help" print
 107     ] ?if ;
 108
 109 : ($index) ( articles -- )
 110     sort-articles [ \ $subsection swap 2array ] map print-element ;
 111
 112 : $index ( element -- )
 113     first call [ ($index) ] unless-empty ;
 114
 115 : $about ( element -- )
 116     first vocab-help [ 1array $subsection ] when* ;
 117
 118 : :help-debugger ( -- )
 119     nl
 120     "Debugger commands:" print
 121     nl
 122     ":s    - data stack at error time" print
 123     ":r    - retain stack at error time" print
 124     ":c    - call stack at error time" print
 125     ":edit - jump to source location (parse errors only)" print
 126
 127     ":get  ( var -- value ) accesses variables at time of the error" print
 128     ":vars - list all variables at error time" print ;
 129
 130 : :help ( -- )
 131     error get error-help [ help ] [ "No help for this error. " print ] if*
 132     :help-debugger ;
 133
 134 : remove-article ( name -- )
 135     dup articles get key? [
 136         dup unxref-article
 137         dup articles get delete-at
 138     ] when drop ;
 139
 140 : add-article ( article name -- )
 141     [ remove-article ] keep
 142     [ articles get set-at ] keep
 143     xref-article ;
 144
 145 : remove-word-help ( word -- )
 146     dup word-help [ dup unxref-article ] when
 147     f "help" set-word-prop ;
 148
 149 : set-word-help ( content word -- )
 150     [ remove-word-help ] keep
 151     [ swap "help" set-word-prop ] keep
 152     xref-article ;