factor/basis/help/help.factor

184 lines
4.5 KiB
Factor

! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays io io.styles kernel namespaces make
parser prettyprint sequences words assocs definitions generic
quotations effects slots continuations classes.tuple debugger
combinators vocabs help.stylesheet help.topics help.crossref
help.markup sorting classes vocabs.loader ;
IN: help
GENERIC: word-help* ( word -- content )
: word-help ( word -- content )
dup "help" word-prop [ ] [
dup word-help* dup
[ swap 2array 1array ] [ 2drop f ] if
] ?if ;
: $predicate ( element -- )
{ { "object" object } { "?" "a boolean" } } $values
[
"Tests if the object is an instance of the " ,
first "predicating" word-prop <$link> ,
" class." ,
] { } make $description ;
M: word word-help* drop f ;
M: predicate word-help* drop \ $predicate ;
: all-articles ( -- seq )
articles get keys
all-words [ word-help ] filter append ;
: orphan-articles ( -- seq )
articles get keys
[ article-parent not ] filter ;
: xref-help ( -- )
all-articles [ xref-article ] each ;
: error? ( word -- ? )
\ $error-description swap word-help elements empty? not ;
: sort-articles ( seq -- newseq )
[ dup article-title ] { } map>assoc sort-values keys ;
: all-errors ( -- seq )
all-words [ error? ] filter sort-articles ;
M: word article-name name>> ;
M: word article-title
dup [ parsing-word? ] [ symbol? ] bi or [
name>>
] [
[ name>> ]
[ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
append
] if ;
<PRIVATE
: (word-help) ( word -- element )
[
{
[ \ $vocabulary swap 2array , ]
[ word-help % ]
[ \ $related swap 2array , ]
[ get-global [ \ $value swap 2array , ] when* ]
[ \ $definition swap 2array , ]
} cleave
] { } make ;
M: word article-content (word-help) ;
<PRIVATE
: word-with-methods ( word -- elements )
[
[ (word-help) % ]
[ \ $methods swap 2array , ]
bi
] { } make ;
PRIVATE>
M: generic article-content word-with-methods ;
M: class article-content word-with-methods ;
M: word article-parent "help-parent" word-prop ;
M: word set-article-parent swap "help-parent" set-word-prop ;
: $doc-path ( article -- )
help-path [
[
help-path-style get [
"Parent topics: " write $links
] with-style
] ($block)
] unless-empty ;
: $title ( topic -- )
title-style get [
title-style get [
dup [
dup article-title swap >link write-object
] ($block) $doc-path
] with-nesting
] with-style nl ;
: print-topic ( topic -- )
last-element off dup $title
article-content print-content nl ;
SYMBOL: help-hook
help-hook global [ [ print-topic ] or ] change-at
: help ( topic -- )
help-hook get call ;
: about ( vocab -- )
dup require
dup vocab [ ] [
"No such vocabulary: " prepend throw
] ?if
dup vocab-help [
help
] [
"The " write vocab-name write
" vocabulary does not define a main help article." print
"To define one, refer to \\ ABOUT: help" print
] ?if ;
: ($index) ( articles -- )
sort-articles [ \ $subsection swap 2array ] map print-element ;
: $index ( element -- )
first call [ ($index) ] unless-empty ;
: $about ( element -- )
first vocab-help [ 1array $subsection ] when* ;
: :help-debugger ( -- )
nl
"Debugger commands:" print
nl
":s - data stack at error time" print
":r - retain stack at error time" print
":c - call stack at error time" print
":edit - jump to source location (parse errors only)" print
":get ( var -- value ) accesses variables at time of the error" print
":vars - list all variables at error time" print ;
: (:help) ( error -- )
error-help [ help ] [ "No help for this error. " print ] if*
:help-debugger ;
: :help ( -- )
error get (:help) ;
: remove-article ( name -- )
dup articles get key? [
dup unxref-article
dup articles get delete-at
] when drop ;
: add-article ( article name -- )
[ remove-article ] keep
[ articles get set-at ] keep
xref-article ;
: remove-word-help ( word -- )
dup word-help [ dup unxref-article ] when
f "help" set-word-prop ;
: set-word-help ( content word -- )
[ remove-word-help ] keep
[ swap "help" set-word-prop ] keep
xref-article ;