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 make
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 [ command>> listener-command? ] [ listener?>> ] bi or ;
24 M: operation command-name
25 command>> command-name ;
27 M: operation command-description
28 command>> command-description ;
30 M: operation command-word command>> command-word ;
32 : operation-gesture ( operation -- gesture )
33 command>> +keyboard+ word-prop ;
37 : object-operations ( obj -- operations )
38 operations get [ predicate>> call ] with filter ;
40 : find-operation ( obj quot -- command )
41 >r object-operations r> find-last nip ; inline
43 : primary-operation ( obj -- operation )
44 [ command>> +primary+ word-prop ] find-operation ;
46 : secondary-operation ( obj -- operation )
48 [ command>> +secondary+ word-prop ] find-operation
49 [ ] [ primary-operation ] ?if ;
51 : default-flags ( -- assoc )
52 H{ { +keyboard+ f } { +primary+ f } { +secondary+ f } } ;
54 : define-operation ( pred command flags -- )
55 default-flags swap assoc-union
56 dupd define-command <operation>
59 : modify-operation ( hook translator operation -- operation )
65 : modify-operations ( operations hook translator -- operations )
66 rot [ modify-operation ] with with map ;
68 : operations>commands ( object hook translator -- pairs )
69 [ object-operations ] 2dip modify-operations
70 [ [ operation-gesture ] keep ] { } map>assoc ;
72 : define-operation-map ( class group blurb object hook translator -- )
73 operations>commands define-command-map ;
75 : operation-quot ( target command -- quot )
82 M: operation invoke-command ( target command -- )
83 [ hook>> call ] keep operation-quot call ;