basis/ui/operations/operations.factor

   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 ;
   5 IN: ui.operations
   6
   7 SYMBOL: +keyboard+
   8 SYMBOL: +primary+
   9 SYMBOL: +secondary+
  10
  11 TUPLE: operation predicate command translator listener? ;
  12
  13 : <operation> ( predicate command -- operation )
  14     operation new
  15         [ ] >>translator
  16         swap >>command
  17         swap >>predicate ;
  18
  19 PREDICATE: listener-operation < operation
  20     { [ command>> listener-command? ] [ listener?>> ] } 1|| ;
  21
  22 M: operation command-name
  23     command>> command-name ;
  24
  25 M: operation command-description
  26     command>> command-description ;
  27
  28 M: operation command-word command>> command-word ;
  29
  30 : operation-gesture ( operation -- gesture )
  31     command>> +keyboard+ word-prop ;
  32
  33 SYMBOL: operations
  34
  35 operations [ <linked-hash> ] initialize
  36
  37 : object-operations ( obj -- operations )
  38     operations get values
  39     [ predicate>> call( obj -- ? ) ] with filter ;
  40
  41 : gesture>operation ( gesture object -- operation/f )
  42     object-operations [ operation-gesture = ] with find nip ;
  43
  44 : find-operation ( obj quot -- command )
  45     [ object-operations ] dip find-last nip ; inline
  46
  47 : primary-operation? ( operation -- ? )
  48     command>> +primary+ word-prop ;
  49
  50 : primary-operation ( obj -- operation )
  51     [ primary-operation? ] find-operation ;
  52
  53 : invoke-primary-operation ( obj -- )
  54     dup primary-operation invoke-command ;
  55
  56 : secondary-operation ( obj -- operation )
  57     dup
  58     [ command>> +secondary+ word-prop ] find-operation
  59     [ ] [ primary-operation ] ?if ;
  60
  61 : invoke-secondary-operation ( obj -- )
  62     dup secondary-operation invoke-command ;
  63
  64 : default-flags ( -- assoc )
  65     H{ { +keyboard+ f } { +primary+ f } { +secondary+ f } } ;
  66
  67 : (define-operation) ( operation -- )
  68     dup [ command>> ] [ predicate>> ] bi
  69     2array operations get set-at ;
  70
  71 : define-operation ( pred command flags -- )
  72     default-flags swap assoc-union
  73     dupd define-command <operation>
  74     (define-operation) ;
  75
  76 : modify-operation ( translator operation -- operation )
  77     clone
  78         swap >>translator
  79         t >>listener? ;
  80
  81 : modify-operations ( operations translator -- operations )
  82     '[ [ _ ] dip modify-operation ] map ;
  83
  84 : operations>commands ( object translator -- pairs )
  85     [ object-operations ] dip modify-operations
  86     [ [ operation-gesture ] keep ] { } map>assoc ;
  87
  88 : define-operation-map ( class group blurb object translator -- )
  89     operations>commands define-command-map ;
  90
  91 : operation-quot ( target operation -- quot )
  92     [ translator>> ] [ command>> ] bi '[ _ @ _ execute ] ;
  93
  94 M: operation invoke-command ( target command -- )
  95     operation-quot call( -- ) ;