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 $nl
"Operations have the following slots:" "Operations have the following slots:"
{ $list { $list
{ { $link operation-predicate } " - a quotation with stack effect " { $snippet "( obj -- ? )" } } { { $snippet "predicate" } " - a quotation with stack effect " { $snippet "( obj -- ? )" } }
{ { $link operation-command } " - a " { $link word } } { { $snippet "command" } " - a " { $link word } }
{ { $link operation-translator } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } } { { $snippet "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 } } { { $snippet "hook" } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
{ { $link operation-listener? } " - a boolean" } { { $snippet "listener?" } " - a boolean" }
} } ; } } ;
HELP: operation-gesture HELP: operation-gesture
@ -38,7 +38,7 @@ HELP: operations
HELP: object-operations HELP: object-operations
{ $values { "obj" object } { "operations" "a sequence of " { $link operation } " instances" } } { $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 HELP: primary-operation
{ $values { "obj" object } { "operation" "an " { $link operation } " or " { $link f } } } { $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 ; swap >>predicate ;
PREDICATE: listener-operation < operation PREDICATE: listener-operation < operation
dup operation-command listener-command? dup command>> listener-command?
swap operation-listener? or ; swap listener?>> or ;
M: operation command-name M: operation command-name
operation-command command-name ; command>> command-name ;
M: operation command-description 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-gesture ( operation -- gesture )
operation-command +keyboard+ word-prop ; command>> +keyboard+ word-prop ;
SYMBOL: operations SYMBOL: operations
: object-operations ( obj -- operations ) : object-operations ( obj -- operations )
operations get [ operation-predicate call ] with filter ; operations get [ predicate>> call ] with filter ;
: find-operation ( obj quot -- command ) : find-operation ( obj quot -- command )
>r object-operations r> find-last nip ; inline >r object-operations r> find-last nip ; inline
: primary-operation ( obj -- operation ) : primary-operation ( obj -- operation )
[ operation-command +primary+ word-prop ] find-operation ; [ command>> +primary+ word-prop ] find-operation ;
: secondary-operation ( obj -- operation ) : secondary-operation ( obj -- operation )
dup dup
[ operation-command +secondary+ word-prop ] find-operation [ command>> +secondary+ word-prop ] find-operation
[ ] [ primary-operation ] ?if ; [ ] [ primary-operation ] ?if ;
: default-flags ( -- assoc ) : default-flags ( -- assoc )
@ -59,9 +59,9 @@ SYMBOL: operations
: modify-operation ( hook translator operation -- operation ) : modify-operation ( hook translator operation -- operation )
clone clone
tuck set-operation-translator tuck (>>translator)
tuck set-operation-hook tuck (>>hook)
t over set-operation-listener? ; t over (>>listener?) ;
: modify-operations ( operations hook translator -- operations ) : modify-operations ( operations hook translator -- operations )
rot [ >r 2dup r> modify-operation ] map 2nip ; rot [ >r 2dup r> modify-operation ] map 2nip ;
@ -76,9 +76,9 @@ SYMBOL: operations
: operation-quot ( target command -- quot ) : operation-quot ( target command -- quot )
[ [
swap literalize , swap literalize ,
dup operation-translator % dup translator>> %
operation-command , command>> ,
] [ ] make ; ] [ ] make ;
M: operation invoke-command ( target command -- ) 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 ; command-quot call-listener ;
M: listener-operation invoke-command ( target command -- ) 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 -- ) : eval-listener ( string -- )
get-workspace get-workspace