111 lines
3.6 KiB
Factor
111 lines
3.6 KiB
Factor
! Copyright (C) 2005 Slava Pestov.
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
IN: gadgets-presentations
|
|
USING: arrays compiler gadgets gadgets-borders gadgets-buttons
|
|
gadgets-labels gadgets-layouts gadgets-menus gadgets-outliner
|
|
gadgets-panes gadgets-theme generic hashtables inference
|
|
inspector io jedit kernel lists memory namespaces parser
|
|
prettyprint sequences strings styles words ;
|
|
|
|
SYMBOL: commands
|
|
|
|
V{ } clone commands global set-hash
|
|
|
|
: forget-command ( name -- )
|
|
commands [ [ second = not ] subset-with ] change ;
|
|
|
|
: define-command ( class name quot -- )
|
|
over forget-command 3array commands get push ;
|
|
|
|
: applicable ( object -- seq )
|
|
commands get [ first call ] subset-with ;
|
|
|
|
: command-quot ( presented quot -- quot )
|
|
[ \ drop , curry , [ pane get pane-call ] % ] [ ] make ;
|
|
|
|
TUPLE: command-button object ;
|
|
|
|
: command-menu ( command-button -- )
|
|
command-button-object dup applicable
|
|
[ [ third command-quot ] keep second swons ] map-with
|
|
<menu> show-hand-menu ;
|
|
|
|
C: command-button ( gadget object -- button )
|
|
[
|
|
set-command-button-object
|
|
[ command-menu ] <roll-button>
|
|
] keep
|
|
[ set-gadget-delegate ] keep
|
|
dup menu-button-actions ;
|
|
|
|
M: command-button gadget-help ( button -- string )
|
|
command-button-object dup word? [ synopsis ] [ summary ] if ;
|
|
|
|
: init-commands ( style gadget -- gadget )
|
|
presented rot hash [ <command-button> ] when* ;
|
|
|
|
: style-font ( style -- font )
|
|
[ font swap hash [ "Monospaced" ] unless* ] keep
|
|
[ font-style swap hash [ plain ] unless* ] keep
|
|
font-size swap hash [ 12 ] unless* 3array ;
|
|
|
|
: <styled-label> ( style text -- label )
|
|
<label> foreground pick hash [ over set-label-color ] when*
|
|
swap style-font over set-label-font ;
|
|
|
|
: <presentation> ( style text -- presentation )
|
|
gadget pick hash
|
|
[ ] [ >r dup dup r> <styled-label> init-commands ] ?if
|
|
outline rot hash [ <outliner> ] when* ;
|
|
|
|
: gadget. ( gadget -- )
|
|
gadget associate
|
|
"This stream does not support live gadgets"
|
|
swap format terpri ;
|
|
|
|
UNION: gadget-stream pack paragraph ;
|
|
|
|
M: gadget-stream stream-write ( string stream -- )
|
|
over empty? [ 2drop ] [ >r <label> r> add-gadget ] if ;
|
|
|
|
M: gadget-stream stream-write1 ( char stream -- )
|
|
>r ch>string r> stream-write ;
|
|
|
|
M: gadget-stream stream-format ( string style stream -- )
|
|
pick empty? pick hash-empty? and [
|
|
3drop
|
|
] [
|
|
>r swap <presentation> r> add-gadget
|
|
] if ;
|
|
|
|
M: gadget-stream stream-break ( stream -- )
|
|
<break> swap add-gadget ;
|
|
|
|
M: gadget-stream stream-close ( stream -- ) drop ;
|
|
|
|
: paragraph-style ( pane style -- pane )
|
|
border-width over hash [ >r <border> r> ] when
|
|
border-color swap hash
|
|
[ <solid> over set-gadget-boundary ] when* ;
|
|
|
|
M: pane with-nested-stream ( quot style stream -- )
|
|
>r >r make-pane r> paragraph-style
|
|
r> pane-current add-gadget ;
|
|
|
|
[ drop t ] "Prettyprint" [ . ] define-command
|
|
[ drop t ] "Describe" [ describe ] define-command
|
|
[ drop t ] "Push on data stack" [ ] define-command
|
|
|
|
[ word? ] "See word" [ see ] define-command
|
|
[ word? ] "Word call hierarchy" [ uses. ] define-command
|
|
[ word? ] "Word caller hierarchy" [ usage. ] define-command
|
|
[ word? ] "Open in jEdit" [ jedit ] define-command
|
|
[ word? ] "Reload original source" [ reload ] define-command
|
|
[ compound? ] "Annotate with watchpoint" [ watch ] define-command
|
|
[ compound? ] "Annotate with breakpoint" [ break ] define-command
|
|
[ compound? ] "Annotate with profiling" [ profile ] define-command
|
|
[ word? ] "Compile" [ recompile ] define-command
|
|
[ word? ] "Infer stack effect" [ unit infer . ] define-command
|
|
|
|
[ [ gadget? ] is? ] "Display gadget" [ gadget. ] define-command
|