1 ! Copyright (C) 2006, 2008 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 ;
12 TUPLE: operation predicate command translator hook listener? ;
14 : <operation> ( predicate command -- operation )
21 PREDICATE: listener-operation < operation
22 dup command>> listener-command?
25 M: operation command-name
26 command>> command-name ;
28 M: operation command-description
29 command>> command-description ;
31 M: operation command-word command>> command-word ;
33 : operation-gesture ( operation -- gesture )
34 command>> +keyboard+ word-prop ;
38 : object-operations ( obj -- operations )
39 operations get [ predicate>> call ] with filter ;
41 : find-operation ( obj quot -- command )
42 >r object-operations r> find-last nip ; inline
44 : primary-operation ( obj -- operation )
45 [ command>> +primary+ word-prop ] find-operation ;
47 : secondary-operation ( obj -- operation )
49 [ command>> +secondary+ word-prop ] find-operation
50 [ ] [ primary-operation ] ?if ;
52 : default-flags ( -- assoc )
53 H{ { +keyboard+ f } { +primary+ f } { +secondary+ f } } ;
55 : define-operation ( pred command flags -- )
56 default-flags swap assoc-union
57 dupd define-command <operation>
60 : modify-operation ( hook translator operation -- operation )
64 t over (>>listener?) ;
66 : modify-operations ( operations hook translator -- operations )
67 rot [ >r 2dup r> modify-operation ] map 2nip ;
69 : operations>commands ( object hook translator -- pairs )
70 >r >r object-operations r> r> modify-operations
71 [ [ operation-gesture ] keep ] { } map>assoc ;
73 : define-operation-map ( class group blurb object hook translator -- )
74 operations>commands define-command-map ;
76 : operation-quot ( target command -- quot )
83 M: operation invoke-command ( target command -- )
84 [ hook>> call ] keep operation-quot call ;