1 ! Copyright (C) 2006, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays definitions kernel ui.commands
4 ui.gestures sequences strings math words generic namespaces
5 hashtables help.markup quotations assocs fry call linked-assocs ;
12 TUPLE: operation predicate command translator listener? ;
14 : <operation> ( predicate command -- operation )
20 PREDICATE: listener-operation < operation
21 [ command>> listener-command? ] [ listener?>> ] bi or ;
23 M: operation command-name
24 command>> command-name ;
26 M: operation command-description
27 command>> command-description ;
29 M: operation command-word command>> command-word ;
31 : operation-gesture ( operation -- gesture )
32 command>> +keyboard+ word-prop ;
36 operations [ <linked-hash> ] initialize
38 : object-operations ( obj -- operations )
40 [ predicate>> call( obj -- ? ) ] with filter ;
42 : gesture>operation ( gesture object -- operation/f )
43 object-operations [ operation-gesture = ] with find nip ;
45 : find-operation ( obj quot -- command )
46 [ object-operations ] dip find-last nip ; inline
48 : primary-operation? ( operation -- ? )
49 command>> +primary+ word-prop ;
51 : primary-operation ( obj -- operation )
52 [ primary-operation? ] find-operation ;
54 : invoke-primary-operation ( obj -- )
55 dup primary-operation invoke-command ;
57 : secondary-operation ( obj -- operation )
59 [ command>> +secondary+ word-prop ] find-operation
60 [ ] [ primary-operation ] ?if ;
62 : invoke-secondary-operation ( obj -- )
63 dup secondary-operation invoke-command ;
65 : default-flags ( -- assoc )
66 H{ { +keyboard+ f } { +primary+ f } { +secondary+ f } } ;
68 : (define-operation) ( operation -- )
69 dup [ command>> ] [ predicate>> ] bi
70 2array operations get set-at ;
72 : define-operation ( pred command flags -- )
73 default-flags swap assoc-union
74 dupd define-command <operation>
77 : modify-operation ( translator operation -- operation )
82 : modify-operations ( operations translator -- operations )
83 '[ [ _ ] dip modify-operation ] map ;
85 : operations>commands ( object translator -- pairs )
86 [ object-operations ] dip modify-operations
87 [ [ operation-gesture ] keep ] { } map>assoc ;
89 : define-operation-map ( class group blurb object translator -- )
90 operations>commands define-command-map ;
92 : operation-quot ( target command -- quot )
93 [ translator>> ] [ command>> ] bi '[ _ @ _ execute ] ;
95 M: operation invoke-command ( target command -- )
96 operation-quot call( -- ) ;