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 call ;
   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 : object-operations ( obj -- operations )
  37     operations get [ predicate>> call( obj -- ? ) ] with filter ;
  38
  39 : gesture>operation ( gesture object -- operation/f )
  40     object-operations [ operation-gesture = ] with find nip ;
  41
  42 : find-operation ( obj quot -- command )
  43     [ object-operations ] dip find-last nip ; inline
  44
  45 : primary-operation ( obj -- operation )
  46     [ command>> +primary+ word-prop ] find-operation ;
  47
  48 : secondary-operation ( obj -- operation )
  49     dup
  50     [ command>> +secondary+ word-prop ] find-operation
  51     [ ] [ primary-operation ] ?if ;
  52
  53 : default-flags ( -- assoc )
  54     H{ { +keyboard+ f } { +primary+ f } { +secondary+ f } } ;
  55
  56 : define-operation ( pred command flags -- )
  57     default-flags swap assoc-union
  58     dupd define-command <operation>
  59     operations get push ;
  60
  61 : modify-operation ( translator operation -- operation )
  62     clone
  63         swap >>translator
  64         t >>listener? ;
  65
  66 : modify-operations ( operations translator -- operations )
  67     '[ [ _ ] dip modify-operation ] map ;
  68
  69 : operations>commands ( object translator -- pairs )
  70     [ object-operations ] dip modify-operations
  71     [ [ operation-gesture ] keep ] { } map>assoc ;
  72
  73 : define-operation-map ( class group blurb object translator -- )
  74     operations>commands define-command-map ;
  75
  76 : operation-quot ( target command -- quot )
  77     [ translator>> ] [ command>> ] bi '[ _ @ _ execute ] ;
  78
  79 M: operation invoke-command ( target command -- )
  80     operation-quot call( -- ) ;