basis/ui/operations/operations.factor

   1 ! Copyright (C) 2006, 2008 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 make
   5 hashtables help.markup quotations assocs ;
   6 IN: ui.operations
   7
   8 SYMBOL: +keyboard+
   9 SYMBOL: +primary+
  10 SYMBOL: +secondary+
  11
  12 TUPLE: operation predicate command translator hook listener? ;
  13
  14 : <operation> ( predicate command -- operation )
  15     operation new
  16         [ ] >>hook
  17         [ ] >>translator
  18         swap >>command
  19         swap >>predicate ;
  20
  21 PREDICATE: listener-operation < operation
  22     dup command>> listener-command?
  23     swap listener?>> or ;
  24
  25 M: operation command-name
  26     command>> command-name ;
  27
  28 M: operation command-description
  29     command>> command-description ;
  30
  31 M: operation command-word command>> command-word ;
  32
  33 : operation-gesture ( operation -- gesture )
  34     command>> +keyboard+ word-prop ;
  35
  36 SYMBOL: operations
  37
  38 : object-operations ( obj -- operations )
  39     operations get [ predicate>> call ] with filter ;
  40
  41 : find-operation ( obj quot -- command )
  42     >r object-operations r> find-last nip ; inline
  43
  44 : primary-operation ( obj -- operation )
  45     [ command>> +primary+ word-prop ] find-operation ;
  46
  47 : secondary-operation ( obj -- operation )
  48     dup
  49     [ command>> +secondary+ word-prop ] find-operation
  50     [ ] [ primary-operation ] ?if ;
  51
  52 : default-flags ( -- assoc )
  53     H{ { +keyboard+ f } { +primary+ f } { +secondary+ f } } ;
  54
  55 : define-operation ( pred command flags -- )
  56     default-flags swap assoc-union
  57     dupd define-command <operation>
  58     operations get push ;
  59
  60 : modify-operation ( hook translator operation -- operation )
  61     clone
  62     tuck (>>translator)
  63     tuck (>>hook)
  64     t over (>>listener?) ;
  65
  66 : modify-operations ( operations hook translator -- operations )
  67     rot [ >r 2dup r> modify-operation ] map 2nip ;
  68
  69 : operations>commands ( object hook translator -- pairs )
  70     >r >r object-operations r> r> modify-operations
  71     [ [ operation-gesture ] keep ] { } map>assoc ;
  72
  73 : define-operation-map ( class group blurb object hook translator -- )
  74     operations>commands define-command-map ;
  75
  76 : operation-quot ( target command -- quot )
  77     [
  78         swap literalize ,
  79         dup translator>> %
  80         command>> ,
  81     ] [ ] make ;
  82
  83 M: operation invoke-command ( target command -- )
  84     [ hook>> call ] keep operation-quot call ;