basis/help/help.factor

   1 ! Copyright (C) 2005, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes classes.error combinators
   4 combinators.short-circuit continuations debugger effects fry
   5 generic help.crossref help.markup help.stylesheet help.topics io
   6 io.styles kernel make namespaces prettyprint sequences sets
   7 sorting vocabs words words.alias words.symbol ;
   8 IN: help
   9
  10 GENERIC: word-help* ( word -- content )
  11
  12 <PRIVATE
  13
  14 : inputs-and-outputs ( content word -- content' word )
  15    over [ dup array? [ { $values } head? ] [ drop f ] if ] find drop [
  16         '[ _ cut unclip rest ] dip [
  17             stack-effect [ in>> ] [ out>> ] bi
  18             [ [ dup pair? [ first ] when ] map ] bi@
  19             [ '[ ?first _ member? ] filter ] bi-curry@
  20             \ $inputs \ $outputs
  21             [ '[ @ _ prefix ] ] bi-curry@ bi* bi
  22             2array glue
  23         ] keep
  24     ] when* ;
  25
  26 : fix-shuffle ( content word -- content' word )
  27     over [ { $shuffle $complex-shuffle } member? ] find drop [
  28         '[ _ cut unclip ] dip [
  29             stack-effect 2array 1array glue
  30         ] keep
  31     ] when* ;
  32
  33 PRIVATE>
  34
  35 : word-help ( word -- content )
  36     [ dup "help" word-prop [ ] [ word-help* ] ?if ] keep
  37     inputs-and-outputs fix-shuffle drop ;
  38
  39 : effect-help ( effect -- content )
  40     [ in>> ] [ out>> ] bi [
  41         [
  42             dup pair? [
  43                 first2 dup effect? [ \ $quotation swap 2array ] when
  44             ] [
  45                 object
  46             ] if [ effect>string ] dip
  47         ] { } map>assoc
  48     ] bi@ \ $inputs \ $outputs [ prefix ] bi-curry@ bi* 2array ;
  49
  50 M: word word-help* stack-effect effect-help ;
  51
  52 : $predicate ( element -- )
  53     { { "object" object } { "?" boolean } } $values
  54     [
  55         "Tests if the object is an instance of the " ,
  56         first "predicating" word-prop <$link> ,
  57         " class." ,
  58     ] { } make $description ;
  59
  60 M: predicate word-help* \ $predicate swap 2array 1array ;
  61
  62 M: class word-help* drop f ;
  63
  64 M: alias word-help*
  65     [
  66         \ $description ,
  67         "An alias for " , def>> first <$link> , "." ,
  68     ] { } make 1array ;
  69
  70 : all-articles ( -- seq )
  71     articles get keys
  72     all-words [ word-help ] filter append ;
  73
  74 : orphan-articles ( -- seq )
  75     articles get keys [ article-parent ] reject
  76     { "help.home" "handbook" } diff ;
  77
  78 : xref-help ( -- )
  79     all-articles [ xref-article ] each ;
  80
  81 : error? ( word -- ? )
  82     {
  83         [ error-class? ]
  84         [ \ $error-description swap word-help elements empty? not ]
  85     } 1|| ;
  86
  87 : sort-articles ( seq -- newseq )
  88     [ article-title ] zip-with sort-values keys ;
  89
  90 : all-errors ( -- seq )
  91     all-words [ error? ] filter sort-articles ;
  92
  93 M: word valid-article? drop t ;
  94
  95 M: word article-name name>> ;
  96
  97 M: word article-title
  98     dup [ parsing-word? ] [ symbol? ] bi or [
  99         name>>
 100     ] [
 101         [ unparse ]
 102         [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
 103         append
 104     ] if ;
 105
 106 <PRIVATE
 107
 108 : (word-help) ( word -- element )
 109     [
 110         {
 111             [ \ $vocabulary swap 2array , ]
 112             [ word-help % ]
 113             [ \ $related swap 2array , ]
 114             [ dup global at [ get-global \ $value swap 2array , ] [ drop ] if ]
 115             [ \ $definition swap 2array , ]
 116         } cleave
 117     ] { } make ;
 118
 119 M: word article-content (word-help) ;
 120
 121 : word-with-methods ( word -- elements )
 122     [
 123         [ (word-help) % ]
 124         [ \ $methods swap 2array , ]
 125         bi
 126     ] { } make ;
 127
 128 PRIVATE>
 129
 130 M: generic article-content word-with-methods ;
 131
 132 M: class article-content word-with-methods ;
 133
 134 M: word article-parent "help-parent" word-prop ;
 135
 136 M: word set-article-parent swap "help-parent" set-word-prop ;
 137
 138 : ($title) ( topic -- )
 139     [ [ article-title ] [ >link ] bi write-object ] ($block) ;
 140
 141 : ($navigation-table) ( element -- )
 142     help-path-style get dup [
 143         table-style [ $table ] with-variable
 144     ] with-style ;
 145
 146 : ($navigation-path) ( topic -- )
 147     help-path-style get [
 148        help-path [ reverse $breadcrumbs ] unless-empty
 149     ] with-style ;
 150
 151 : ($navigation-link) ( content element label -- )
 152     [ prefix 1array ] dip prefix , ;
 153
 154 : ($navigation-links) ( topic -- )
 155     [
 156         [ prev-article [ 1array \ $long-link "Prev:" ($navigation-link) ] when* ]
 157         [ next-article [ 1array \ $long-link "Next:" ($navigation-link) ] when* ]
 158         bi
 159     ] { } make [ ($navigation-table) ] unless-empty ;
 160
 161 : $title ( topic -- )
 162     title-style get [
 163         [ ($title) ]
 164         [ ($navigation-path) ]
 165         [ ($navigation-links) ] tri
 166     ] with-nesting ;
 167
 168 : print-topic ( topic -- )
 169     >link
 170     last-element off
 171     [ $title ($blank-line) ]
 172     [ article-content print-content nl ] bi ;
 173
 174 SYMBOL: help-hook
 175
 176 help-hook [ [ print-topic ] ] initialize
 177
 178 : help ( topic -- )
 179     help-hook get call( topic -- ) ;
 180
 181 : ($index) ( articles -- )
 182     sort-articles [ \ $subsection swap 2array ] map print-element ;
 183
 184 : $index ( element -- )
 185     first call( -- seq ) [ ($index) ] unless-empty ;
 186
 187 : $about ( element -- )
 188     first vocab-help [ 1array $subsection ] when* ;
 189
 190 : :help-debugger ( -- )
 191     nl
 192     "Debugger commands:" print
 193     nl
 194     ":s    - data stack at error time" print
 195     ":r    - retain stack at error time" print
 196     ":c    - call stack at error time" print
 197     ":edit - jump to source location (parse errors only)" print
 198
 199     ":get  ( var -- value ) accesses variables at time of the error" print
 200     ":vars - list all variables at error time" print ;
 201
 202 : (:help) ( error -- )
 203     error-help [ help ] [ "No help for this error. " print ] if*
 204     :help-debugger ;
 205
 206 : :help ( -- )
 207     error get (:help) ;
 208
 209 : remove-article ( name -- )
 210     articles get delete-at ;
 211
 212 : add-article ( article name -- )
 213     [ articles get set-at ] keep xref-article ;
 214
 215 : remove-word-help ( word -- )
 216     "help" remove-word-prop ;
 217
 218 : set-word-help ( content word -- )
 219     [ swap "help" set-word-prop ] keep xref-article ;