More slight operations fixes

release
slava 2006-09-01 05:20:38 +00:00
parent 7ee943117c
commit b979addffc
3 changed files with 36 additions and 26 deletions

View File

@ -89,32 +89,36 @@ SYMBOL: +quot+
SYMBOL: +listener+ SYMBOL: +listener+
SYMBOL: +gesture+ SYMBOL: +gesture+
TUPLE: operation class tags gesture listener? ; TUPLE: operation predicate tags gesture listener? ;
: (operation) ( -- command ) : (operation) ( -- command )
f +name+ get +gesture+ get +quot+ get <command> ; f +name+ get +gesture+ get +quot+ get <command> ;
: (tags) ( -- seq ) +button+ get +group+ get 2array ; : (tags) ( -- seq ) +button+ get +group+ get 2array ;
C: operation ( class hash -- operation ) C: operation ( predicate hash -- operation )
swap [ swap [
(operation) over set-delegate (operation) over set-delegate
(tags) over set-operation-tags (tags) over set-operation-tags
+listener+ get over set-operation-listener? +listener+ get over set-operation-listener?
] bind ] bind
[ set-operation-class ] keep ; [ set-operation-predicate ] keep ;
SYMBOL: operations SYMBOL: operations
: class-operations ( class -- operations ) : object-operations ( obj -- operations )
operations get [ operation-class class< ] subset-with ; operations get [ operation-predicate call ] subset-with ;
: tagged-operations ( class tag -- commands ) : class-operations ( class -- operations )
swap class-operations "predicate" word-prop
operations get [ operation-predicate = ] subset-with ;
: tagged-operations ( obj tag -- commands )
swap object-operations
[ operation-tags member? ] subset-with ; [ operation-tags member? ] subset-with ;
: mouse-operation ( class button# -- command ) : mouse-operation ( obj button# -- command )
tagged-operations dup empty? [ drop f ] [ peek ] if ; tagged-operations dup empty? [ drop f ] [ peek ] if ;
: mouse-operations ( class -- seq ) : mouse-operations ( obj -- seq )
3 [ 1+ mouse-operation ] map-with ; 3 [ 1+ mouse-operation ] map-with ;

View File

@ -17,7 +17,7 @@ C: presentation ( button object commands -- button )
: <object-presentation> ( gadget object -- button ) : <object-presentation> ( gadget object -- button )
>r f <roll-button> r> >r f <roll-button> r>
dup class mouse-operations <presentation> ; dup mouse-operations <presentation> ;
: <command-presentation> ( target command -- button ) : <command-presentation> ( target command -- button )
dup command-name f <bevel-button> -rot { f f } swap add* dup command-name f <bevel-button> -rot { f f } swap add*

View File

@ -155,7 +155,7 @@ M: operation invoke-command ( target operation -- )
[ modify-listener-operation ] map-with ; [ modify-listener-operation ] map-with ;
! Objects ! Objects
object H{ [ drop t ] H{
{ +button+ 1 } { +button+ 1 }
{ +name+ "Inspect" } { +name+ "Inspect" }
{ +quot+ [ inspect ] } { +quot+ [ inspect ] }
@ -163,76 +163,82 @@ object H{
} define-operation } define-operation
! Input ! Input
input H{ [ input? ] H{
{ +button+ 1 } { +button+ 1 }
{ +name+ "Input" } { +name+ "Input" }
{ +quot+ [ listener-gadget call-tool ] } { +quot+ [ listener-gadget call-tool ] }
} define-operation } define-operation
! Words ! Words
\ word H{ [ word? ] H{
{ +button+ 1 } { +button+ 1 }
{ +name+ "Browse" } { +name+ "Browse" }
{ +gesture+ T{ key-down f { A+ } "b" } } { +gesture+ T{ key-down f { A+ } "b" } }
{ +quot+ [ browser call-tool ] } { +quot+ [ browser call-tool ] }
} define-operation } define-operation
\ word H{ [ word? ] H{
{ +button+ 2 } { +button+ 2 }
{ +name+ "Edit" } { +name+ "Edit" }
{ +gesture+ T{ key-down f { A+ } "e" } } { +gesture+ T{ key-down f { A+ } "e" } }
{ +quot+ [ edit ] } { +quot+ [ edit ] }
} define-operation } define-operation
\ word H{ [ word? ] H{
{ +button+ 3 } { +button+ 3 }
{ +name+ "Documentation" } { +name+ "Documentation" }
{ +gesture+ T{ key-down f { A+ } "h" } } { +gesture+ T{ key-down f { A+ } "h" } }
{ +quot+ [ help-gadget call-tool ] } { +quot+ [ help-gadget call-tool ] }
} define-operation } define-operation
\ word H{ [ word? ] H{
{ +name+ "Usage" } { +name+ "Usage" }
{ +gesture+ T{ key-down f { A+ } "u" } } { +gesture+ T{ key-down f { A+ } "u" } }
{ +quot+ [ usage. ] } { +quot+ [ usage. ] }
{ +listener+ t } { +listener+ t }
} define-operation } define-operation
\ word H{ [ word? ] H{
{ +name+ "Reload" } { +name+ "Reload" }
{ +gesture+ T{ key-down f { A+ } "r" } } { +gesture+ T{ key-down f { A+ } "r" } }
{ +quot+ [ reload ] } { +quot+ [ reload ] }
{ +listener+ t } { +listener+ t }
} define-operation } define-operation
\ word H{ [ word? ] H{
{ +name+ "Watch" } { +name+ "Watch" }
{ +quot+ [ watch ] } { +quot+ [ watch ] }
{ +listener+ t } { +listener+ t }
} define-operation } define-operation
! Vocabularies ! Vocabularies
vocab-link H{ [ vocab-link? ] H{
{ +button+ 1 } { +button+ 1 }
{ +name+ "Browse" } { +name+ "Browse" }
{ +quot+ [ browser call-tool ] } { +quot+ [ browser call-tool ] }
} define-operation } define-operation
! Link ! Link
link H{ [ link? ] H{
{ +button+ 1 } { +button+ 1 }
{ +name+ "Follow" } { +name+ "Follow" }
{ +quot+ [ help-gadget call-tool ] } { +quot+ [ help-gadget call-tool ] }
} define-operation } define-operation
link H{ [ link? ] H{
{ +button+ 2 } { +button+ 2 }
{ +name+ "Edit" } { +name+ "Edit" }
{ +quot+ [ edit ] } { +quot+ [ edit ] }
} define-operation } define-operation
[ word-link? ] H{
{ +button+ 2 }
{ +name+ "Definition" }
{ +quot+ [ link-name browser call-tool ] }
} define-operation
! Strings ! Strings
string H{ [ string? ] H{
{ +name+ "Apropos (all)" } { +name+ "Apropos (all)" }
{ +gesture+ T{ key-down f { A+ } "a" } } { +gesture+ T{ key-down f { A+ } "a" } }
{ +quot+ [ apropos ] } { +quot+ [ apropos ] }
@ -244,7 +250,7 @@ string H{
use get [ hash-values [ dup set ] each ] each use get [ hash-values [ dup set ] each ] each
] make-hash hash-values natural-sort ; ] make-hash hash-values natural-sort ;
string H{ [ string? ] H{
{ +name+ "Apropos (used)" } { +name+ "Apropos (used)" }
{ +gesture+ T{ key-down f f "TAB" } } { +gesture+ T{ key-down f f "TAB" } }
{ +quot+ [ usable-words (apropos) ] } { +quot+ [ usable-words (apropos) ] }
@ -252,21 +258,21 @@ string H{
} define-operation } define-operation
! Quotations ! Quotations
quotation H{ [ quotation? ] H{
{ +name+ "Infer" } { +name+ "Infer" }
{ +gesture+ T{ key-down f { C+ A+ } "i" } } { +gesture+ T{ key-down f { C+ A+ } "i" } }
{ +quot+ [ infer . ] } { +quot+ [ infer . ] }
{ +listener+ t } { +listener+ t }
} define-operation } define-operation
quotation H{ [ quotation? ] H{
{ +name+ "Walk" } { +name+ "Walk" }
{ +gesture+ T{ key-down f { C+ A+ } "w" } } { +gesture+ T{ key-down f { C+ A+ } "w" } }
{ +quot+ [ walk ] } { +quot+ [ walk ] }
{ +listener+ t } { +listener+ t }
} define-operation } define-operation
quotation H{ [ quotation? ] H{
{ +name+ "Time" } { +name+ "Time" }
{ +gesture+ T{ key-down f { C+ A+ } "t" } } { +gesture+ T{ key-down f { C+ A+ } "t" } }
{ +quot+ [ time ] } { +quot+ [ time ] }