123 lines
3.4 KiB
Factor
123 lines
3.4 KiB
Factor
! Copyright (C) 2006 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
IN: gadgets-browser
|
|
USING: arrays gadgets gadgets-buttons gadgets-labels
|
|
gadgets-layouts gadgets-panes gadgets-scrolling gadgets-theme
|
|
generic hashtables help inspector kernel math namespaces
|
|
prettyprint sequences words ;
|
|
|
|
SYMBOL: components
|
|
|
|
H{ } clone components set-global
|
|
|
|
: get-components ( class -- assoc )
|
|
components get-global hash [
|
|
{ { "Slots" [ describe ] } }
|
|
] unless* ;
|
|
|
|
{
|
|
{ "Definition" [ help ] }
|
|
{ "Calls in" [ usage. ] }
|
|
{ "Calls out" [ uses. ] }
|
|
{ "Links in" [ links-in. ] }
|
|
{ "Links out" [ links-out. ] }
|
|
{ "Vocabulary" [ word-vocabulary words. ] }
|
|
{ "Properties" [ word-props describe ] }
|
|
} \ word components get-global set-hash
|
|
|
|
{
|
|
{ "Article" [ help ] }
|
|
{ "Links in" [ links-in. ] }
|
|
{ "Links out" [ links-out. ] }
|
|
} \ link components get-global set-hash
|
|
|
|
{
|
|
{ "Call stack" [ continuation-call callstack. ] }
|
|
{ "Data stack" [ continuation-data stack. ] }
|
|
{ "Retain stack" [ continuation-retain stack. ] }
|
|
{ "Name stack" [ continuation-name stack. ] }
|
|
{ "Catch stack" [ continuation-catch stack. ] }
|
|
} \ continuation components get-global set-hash
|
|
|
|
TUPLE: book page pages ;
|
|
|
|
: show-page ( key book -- )
|
|
dup book-page unparent
|
|
[ book-pages assoc ] keep
|
|
[ set-book-page ] 2keep
|
|
add-gadget ;
|
|
|
|
C: book ( pages -- book )
|
|
dup delegate>gadget
|
|
[ set-book-pages ] 2keep
|
|
[ >r first first r> show-page ] keep ;
|
|
|
|
M: book pref-dim* ( book -- dim ) book-page pref-dim ;
|
|
|
|
M: book layout* ( book -- )
|
|
dup rect-dim swap book-page set-gadget-dim ;
|
|
|
|
: component-pages ( obj -- assoc )
|
|
dup class get-components
|
|
[ first2 swapd make-pane <scroller> 2array ] map-with ;
|
|
|
|
: <tab> ( name book -- button )
|
|
dupd [ show-page drop ] curry curry
|
|
>r <label> r> <bevel-button> ;
|
|
|
|
: tabs ( assoc book gadget -- )
|
|
>r swap [ first swap <tab> ] map-with r> add-gadgets ;
|
|
|
|
TUPLE: browser object history tabs ;
|
|
|
|
: save-current ( browser -- )
|
|
dup browser-object swap browser-history push ;
|
|
|
|
: browse ( obj browser -- )
|
|
[ set-browser-object ] 2keep
|
|
dup browser-tabs clear-gadget
|
|
>r component-pages dup <book> r>
|
|
[ @center frame-add ] 2keep browser-tabs tabs ;
|
|
|
|
: find-browser [ browser? ] find-parent ;
|
|
|
|
: browse-back ( browser -- )
|
|
dup browser-history dup empty?
|
|
[ 2drop ] [ pop swap browse ] if ;
|
|
|
|
C: browser ( obj -- browser )
|
|
V{ } clone over set-browser-history
|
|
dup delegate>frame [
|
|
"<" <label> [ find-browser browse-back ] <bevel-button> ,
|
|
<shelf> dup pick set-browser-tabs ,
|
|
] { } make make-shelf dup highlight-theme
|
|
over @top frame-add
|
|
[ browse ] keep ;
|
|
|
|
TUPLE: browser-button object ;
|
|
|
|
: browser-window ( obj -- ) <browser> "Browser" open-window ;
|
|
|
|
: browser-button-action ( button -- )
|
|
[ browser-button-object ] keep find-browser [
|
|
find-browser dup save-current browse
|
|
] [
|
|
browser-window
|
|
] if* ;
|
|
|
|
: browser-button-gestures ( gadget -- )
|
|
[
|
|
[ browser-button-object browser-window ] if-clicked
|
|
] T{ button-up f 3 } set-action ;
|
|
|
|
C: browser-button ( gadget object -- button )
|
|
[ set-browser-button-object ] keep
|
|
[
|
|
>r [ browser-button-action ] <roll-button> r>
|
|
set-gadget-delegate
|
|
] keep
|
|
dup browser-button-gestures ;
|
|
|
|
M: browser-button gadget-help ( button -- string )
|
|
browser-button-object dup word? [ synopsis ] [ summary ] if ;
|