extra/help/help.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays io kernel namespaces parser prettyprint sequences
   4 words assocs definitions generic quotations effects slots
   5 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 : xref-help ( -- )
  35     all-articles [ xref-article ] each ;
  36
  37 : error? ( word -- ? )
  38     \ $error-description swap word-help elements empty? not ;
  39
  40 : sort-articles ( seq -- newseq )
  41     [ dup article-title ] { } map>assoc sort-values keys ;
  42
  43 : all-errors ( -- seq )
  44     all-words [ error? ] filter sort-articles ;
  45
  46 M: word article-name word-name ;
  47
  48 M: word article-title
  49     dup [ parsing-word? ] [ symbol? ] bi or [
  50         word-name
  51     ] [
  52         [ word-name ]
  53         [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
  54         append
  55     ] if ;
  56
  57 M: word article-content
  58     [
  59         \ $vocabulary over 2array ,
  60         dup word-help %
  61         \ $related over 2array ,
  62         dup get-global [ \ $value swap 2array , ] when*
  63         \ $definition swap 2array ,
  64     ] { } make ;
  65
  66 M: word article-parent "help-parent" word-prop ;
  67
  68 M: word set-article-parent swap "help-parent" set-word-prop ;
  69
  70 : $doc-path ( article -- )
  71     help-path dup empty? [
  72         drop
  73     ] [
  74         [
  75             help-path-style get [
  76                 "Parent topics: " write $links
  77             ] with-style
  78         ] ($block)
  79     ] if ;
  80
  81 : $title ( topic -- )
  82     title-style get [
  83         title-style get [
  84             dup [
  85                 dup article-title swap >link write-object
  86             ] ($block) $doc-path
  87         ] with-nesting
  88     ] with-style nl ;
  89
  90 : help ( topic -- )
  91     last-element off dup $title
  92     article-content print-content nl ;
  93
  94 : about ( vocab -- )
  95     dup require
  96     dup vocab [ ] [
  97         "No such vocabulary: " prepend throw
  98     ] ?if
  99     dup vocab-help [
 100         help
 101     ] [
 102         "The " write vocab-name write
 103         " vocabulary does not define a main help article." print
 104         "To define one, refer to \\ ABOUT: help" print
 105     ] ?if ;
 106
 107 : ($index) ( articles -- )
 108     sort-articles [ \ $subsection swap 2array ] map print-element ;
 109
 110 : $index ( element -- )
 111     first call dup empty?
 112     [ drop ] [ [ ($index) ] ($block) ] if ;
 113
 114 : $about ( element -- )
 115     first vocab-help [ 1array $subsection ] when* ;
 116
 117 : :help-debugger ( -- )
 118     nl
 119     "Debugger commands:" print
 120     nl
 121     ":s    - data stack at error time" print
 122     ":r    - retain stack at error time" print
 123     ":c    - call stack at error time" print
 124     ":edit - jump to source location (parse errors only)" print
 125
 126     ":get  ( var -- value ) accesses variables at time of the error" print
 127     ":vars - list all variables at error time" print ;
 128
 129 : :help ( -- )
 130     error get error-help [ help ] [ "No help for this error. " print ] if*
 131     :help-debugger ;
 132
 133 : remove-article ( name -- )
 134     dup articles get key? [
 135         dup unxref-article
 136         dup articles get delete-at
 137     ] when drop ;
 138
 139 : add-article ( article name -- )
 140     [ remove-article ] keep
 141     [ articles get set-at ] keep
 142     xref-article ;
 143
 144 : remove-word-help ( word -- )
 145     dup word-help [ dup unxref-article ] when
 146     f "help" set-word-prop ;
 147
 148 : set-word-help ( content word -- )
 149     [ remove-word-help ] keep
 150     [ swap "help" set-word-prop ] keep
 151     xref-article ;