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