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