basis/help/help.factor

   1 ! Copyright (C) 2005, 2009 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 words.symbol assocs
   5 definitions generic quotations effects slots continuations
   6 classes.tuple debugger combinators vocabs help.stylesheet
   7 help.topics help.crossref help.markup sorting classes
   8 vocabs.loader ;
   9 IN: help
  10
  11 GENERIC: word-help* ( word -- content )
  12
  13 : word-help ( word -- content )
  14     dup "help" word-prop [ ] [
  15         dup word-help* dup
  16         [ swap 2array 1array ] [ 2drop f ] if
  17     ] ?if ;
  18
  19 : $predicate ( element -- )
  20     { { "object" object } { "?" "a boolean" } } $values
  21     [
  22         "Tests if the object is an instance of the " ,
  23         first "predicating" word-prop <$link> ,
  24         " class." ,
  25     ] { } make $description ;
  26
  27 M: word word-help* drop f ;
  28
  29 M: predicate word-help* drop \ $predicate ;
  30
  31 : all-articles ( -- seq )
  32     articles get keys
  33     all-words [ word-help ] filter append ;
  34
  35 : orphan-articles ( -- seq )
  36     articles get keys
  37     [ article-parent not ] filter ;
  38
  39 : xref-help ( -- )
  40     all-articles [ xref-article ] each ;
  41
  42 : error? ( word -- ? )
  43     \ $error-description swap word-help elements empty? not ;
  44
  45 : sort-articles ( seq -- newseq )
  46     [ dup article-title ] { } map>assoc sort-values keys ;
  47
  48 : all-errors ( -- seq )
  49     all-words [ error? ] filter sort-articles ;
  50
  51 M: word article-name name>> ;
  52
  53 M: word article-title
  54     dup [ parsing-word? ] [ symbol? ] bi or [
  55         name>>
  56     ] [
  57         [ unparse ]
  58         [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
  59         append
  60     ] if ;
  61
  62 <PRIVATE
  63
  64 : (word-help) ( word -- element )
  65     [
  66         {
  67             [ \ $vocabulary swap 2array , ]
  68             [ word-help % ]
  69             [ \ $related swap 2array , ]
  70             [ get-global [ \ $value swap 2array , ] when* ]
  71             [ \ $definition swap 2array , ]
  72         } cleave
  73     ] { } make ;
  74
  75 M: word article-content (word-help) ;
  76
  77 <PRIVATE
  78
  79 : word-with-methods ( word -- elements )
  80     [
  81         [ (word-help) % ]
  82         [ \ $methods swap 2array , ]
  83         bi
  84     ] { } make ;
  85
  86 PRIVATE>
  87
  88 M: generic article-content word-with-methods ;
  89
  90 M: class article-content word-with-methods ;
  91
  92 M: word article-parent "help-parent" word-prop ;
  93
  94 M: word set-article-parent swap "help-parent" set-word-prop ;
  95
  96 : ($title) ( topic -- )
  97     [ [ article-title ] [ >link ] bi write-object ] ($block) ;
  98
  99 : $navigation-row ( content element label -- )
 100     [ prefix 1array ] dip prefix , ;
 101
 102 : ($navigation-table) ( element -- )
 103     help-path-style get table-style set [ $table ] with-scope ;
 104
 105 : $navigation-table ( topic -- )
 106     [
 107         [ prev-article [ 1array \ $long-link "Prev:" $navigation-row ] when* ]
 108         [ next-article [ 1array \ $long-link "Next:" $navigation-row ] when* ]
 109         bi
 110     ] { } make [ ($navigation-table) ] unless-empty ;
 111
 112 : ($navigation) ( topic -- )
 113     help-path-style get [
 114         [ help-path [ reverse $breadcrumbs ] unless-empty ]
 115         [ $navigation-table ] bi
 116     ] with-style ;
 117
 118 : $title ( topic -- )
 119     title-style get [
 120         title-style get [
 121             [ ($title) ] [ ($navigation) ] bi
 122         ] with-nesting
 123     ] with-style ;
 124
 125 : print-topic ( topic -- )
 126     >link
 127     last-element off
 128     [ $title ] [ ($blank-line) article-content print-content ] bi ;
 129
 130 SYMBOL: help-hook
 131
 132 help-hook [ [ print-topic ] ] initialize
 133
 134 : help ( topic -- )
 135     help-hook get call( topic -- ) ;
 136
 137 : ($index) ( articles -- )
 138     sort-articles [ \ $subsection swap 2array ] map print-element ;
 139
 140 : $index ( element -- )
 141     first call( -- seq ) [ ($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     articles get delete-at ;
 167
 168 : add-article ( article name -- )
 169     [ remove-article ] keep
 170     [ articles get set-at ] keep
 171     xref-article ;
 172
 173 : remove-word-help ( word -- )
 174     f "help" set-word-prop ;
 175
 176 : set-word-help ( content word -- )
 177     [ remove-word-help ] keep
 178     [ swap "help" set-word-prop ] keep
 179     xref-article ;