1 ! Copyright (C) 2006, 2009 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators.short-circuit kernel
4 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 )
57 [ [ command>> +secondary+ word-prop ] find-operation ]
58 [ primary-operation ] ?unless ;
60 : invoke-secondary-operation ( obj -- )
61 dup secondary-operation invoke-command ;
63 : default-flags ( -- assoc )
64 H{ { +keyboard+ f } { +primary+ f } { +secondary+ f } } ;
66 : (define-operation) ( operation -- )
67 dup [ command>> ] [ predicate>> ] bi
68 2array operations get set-at ;
70 : define-operation ( pred command flags -- )
71 default-flags swap assoc-union
72 dupd define-command <operation>
75 : modify-operation ( translator operation -- operation )
80 : modify-operations ( operations translator -- operations )
81 '[ [ _ ] dip modify-operation ] map ;
83 : operations>commands ( object translator -- pairs )
84 [ object-operations ] dip modify-operations
85 [ [ operation-gesture ] keep ] { } map>assoc ;
87 : define-operation-map ( class group blurb object translator -- )
88 operations>commands define-command-map ;
90 : operation-quot ( target operation -- quot )
91 [ translator>> ] [ command>> ] bi '[ _ @ _ execute ] ;
93 M: operation invoke-command
94 operation-quot call( -- ) ;