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 ] subset 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? ] subset sort-articles ;
  45
  46 M: word article-name word-name ;
  47
  48 M: word article-title
  49     dup parsing? over symbol? or [
  50         word-name
  51     ] [
  52         dup word-name
  53         swap stack-effect
  54         [ effect>string " " swap 3append ] when*
  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-multi)
 118     "This error has multiple delegates:" print
 119     ($index) nl
 120     "Use \\ ... help to get help about a specific delegate." print ;
 121
 122 : (:help-none)
 123     drop "No help for this error. " print ;
 124
 125 : (:help-debugger)
 126     nl
 127     "Debugger commands:" print
 128     nl
 129     ":s    - data stack at error time" print
 130     ":r    - retain stack at error time" print
 131     ":c    - call stack at error time" print
 132     ":edit - jump to source location (parse errors only)" print
 133
 134     ":get  ( var -- value ) accesses variables at time of the error" print
 135     ":vars - list all variables at error time" print ;
 136
 137 : :help ( -- )
 138     error get delegates [ error-help ] map [ ] subset
 139     {
 140         { [ dup empty? ] [ (:help-none) ] }
 141         { [ dup length 1 = ] [ first help ] }
 142         [ (:help-multi) ]
 143     } cond (:help-debugger) ;
 144
 145 : remove-article ( name -- )
 146     dup articles get key? [
 147         dup unxref-article
 148         dup articles get delete-at
 149     ] when drop ;
 150
 151 : add-article ( article name -- )
 152     [ remove-article ] keep
 153     [ articles get set-at ] keep
 154     xref-article ;
 155
 156 : remove-word-help ( word -- )
 157     dup word-help [ dup unxref-article ] when
 158     f "help" set-word-prop ;
 159
 160 : set-word-help ( content word -- )
 161     [ remove-word-help ] keep
 162     [ swap "help" set-word-prop ] keep
 163     xref-article ;