1 ! Copyright (C) 2006, 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators.short-circuit fry
4 kernel linked-assocs namespaces sequences ui.commands words ;
11 TUPLE: operation predicate command translator listener? ;
13 : <operation> ( predicate command -- operation )
19 PREDICATE: listener-operation < operation
20 { [ command>> listener-command? ] [ listener?>> ] } 1|| ;
22 M: operation command-name
23 command>> command-name ;
25 M: operation command-description
26 command>> command-description ;
28 M: operation command-word command>> command-word ;
30 : operation-gesture ( operation -- gesture )
31 command>> +keyboard+ word-prop ;
35 operations [ <linked-hash> ] initialize
37 : object-operations ( obj -- operations )
39 [ predicate>> call( obj -- ? ) ] with filter ;
41 : gesture>operation ( gesture object -- operation/f )
42 object-operations [ operation-gesture = ] with find nip ;
44 : find-operation ( obj quot -- command )
45 [ object-operations ] dip find-last nip ; inline
47 : primary-operation? ( operation -- ? )
48 command>> +primary+ word-prop ;
50 : primary-operation ( obj -- operation )
51 [ primary-operation? ] find-operation ;
53 : invoke-primary-operation ( obj -- )
54 dup primary-operation invoke-command ;
56 : secondary-operation ( obj -- operation )
58 [ command>> +secondary+ word-prop ] find-operation
59 [ ] [ primary-operation ] ?if ;
61 : invoke-secondary-operation ( obj -- )
62 dup secondary-operation invoke-command ;
64 : default-flags ( -- assoc )
65 H{ { +keyboard+ f } { +primary+ f } { +secondary+ f } } ;
67 : (define-operation) ( operation -- )
68 dup [ command>> ] [ predicate>> ] bi
69 2array operations get set-at ;
71 : define-operation ( pred command flags -- )
72 default-flags swap assoc-union
73 dupd define-command <operation>
76 : modify-operation ( translator operation -- operation )
81 : modify-operations ( operations translator -- operations )
82 '[ [ _ ] dip modify-operation ] map ;
84 : operations>commands ( object translator -- pairs )
85 [ object-operations ] dip modify-operations
86 [ [ operation-gesture ] keep ] { } map>assoc ;
88 : define-operation-map ( class group blurb object translator -- )
89 operations>commands define-command-map ;
91 : operation-quot ( target operation -- quot )
92 [ translator>> ] [ command>> ] bi '[ _ @ _ execute ] ;
94 M: operation invoke-command
95 operation-quot call( -- ) ;