steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Update old accessors from 'ui.operations'

db4
Eduardo Cavazos 2008-08-31 23:53:07 -05:00
parent 401597a387
commit 61e5729cdb
3 changed files with 22 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
basis/ui/operations/operations-docs.factor
View File

@ -22,11 +22,11 @@ HELP: operation
$nl
"Operations have the following slots:"
{ $list
{ { $link operation-predicate } " - a quotation with stack effect " { $snippet "( obj -- ? )" } }
{ { $link operation-command } " - a " { $link word } }
{ { $link operation-translator } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
{ { $link operation-hook } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
{ { $link operation-listener? } " - a boolean" }
{ { $snippet "predicate" } " - a quotation with stack effect " { $snippet "( obj -- ? )" } }
{ { $snippet "command" } " - a " { $link word } }
{ { $snippet "translator" } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
{ { $snippet "hook" } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
{ { $snippet "listener?" } " - a boolean" }
} } ;
HELP: operation-gesture
@ -38,7 +38,7 @@ HELP: operations
HELP: object-operations
{ $values { "obj" object } { "operations" "a sequence of " { $link operation } " instances" } }
{ $description "Outputs a sequence of operations applicable to the given object, by testing each defined operation's " { $link operation-predicate } " quotation in turn." } ;
{ $description "Outputs a sequence of operations applicable to the given object, by testing each defined operation's " { $snippet "predicate" } " quotation in turn." } ;
HELP: primary-operation
{ $values { "obj" object } { "operation" "an " { $link operation } " or " { $link f } } }

30
basis/ui/operations/operations.factor
View File

@ -19,34 +19,34 @@ TUPLE: operation predicate command translator hook listener? ;
swap >>predicate ;
PREDICATE: listener-operation < operation
dup operation-command listener-command?
swap operation-listener? or ;
dup command>> listener-command?
swap listener?>> or ;
M: operation command-name
operation-command command-name ;
command>> command-name ;
M: operation command-description
operation-command command-description ;
command>> command-description ;
M: operation command-word operation-command command-word ;
M: operation command-word command>> command-word ;
: operation-gesture ( operation -- gesture )
operation-command +keyboard+ word-prop ;
command>> +keyboard+ word-prop ;
SYMBOL: operations
: object-operations ( obj -- operations )
operations get [ operation-predicate call ] with filter ;
operations get [ predicate>> call ] with filter ;
: find-operation ( obj quot -- command )
>r object-operations r> find-last nip ; inline
: primary-operation ( obj -- operation )
[ operation-command +primary+ word-prop ] find-operation ;
[ command>> +primary+ word-prop ] find-operation ;
: secondary-operation ( obj -- operation )
dup
[ operation-command +secondary+ word-prop ] find-operation
[ command>> +secondary+ word-prop ] find-operation
[ ] [ primary-operation ] ?if ;
: default-flags ( -- assoc )
@ -59,9 +59,9 @@ SYMBOL: operations
: modify-operation ( hook translator operation -- operation )
clone
tuck set-operation-translator
tuck set-operation-hook
t over set-operation-listener? ;
tuck (>>translator)
tuck (>>hook)
t over (>>listener?) ;
: modify-operations ( operations hook translator -- operations )
rot [ >r 2dup r> modify-operation ] map 2nip ;
@ -76,9 +76,9 @@ SYMBOL: operations
: operation-quot ( target command -- quot )
[
swap literalize ,
dup operation-translator %
operation-command ,
dup translator>> %
command>> ,
] [ ] make ;
M: operation invoke-command ( target command -- )
[ operation-hook call ] keep operation-quot call ;
[ hook>> call ] keep operation-quot call ;

2
basis/ui/tools/listener/listener.factor
View File

@ -64,7 +64,7 @@ M: listener-command invoke-command ( target command -- )
command-quot call-listener ;
M: listener-operation invoke-command ( target command -- )
[ operation-hook call ] keep operation-quot call-listener ;
[ hook>> call ] keep operation-quot call-listener ;
: eval-listener ( string -- )
get-workspace