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 make
   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 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     [ command>> listener-command? ] [ listener?>> ] bi or ;
  23
  24 M: operation command-name
  25     command>> command-name ;
  26
  27 M: operation command-description
  28     command>> command-description ;
  29
  30 M: operation command-word command>> command-word ;
  31
  32 : operation-gesture ( operation -- gesture )
  33     command>> +keyboard+ word-prop ;
  34
  35 SYMBOL: operations
  36
  37 operations [ <linked-hash> ] initialize
  38
  39 : object-operations ( obj -- operations )
  40     operations get values
  41     [ predicate>> call ] with filter ;
  42
  43 : find-operation ( obj quot -- command )
  44     [ object-operations ] dip find-last nip ; inline
  45
  46 : primary-operation ( obj -- operation )
  47     [ command>> +primary+ word-prop ] find-operation ;
  48
  49 : secondary-operation ( obj -- operation )
  50     dup
  51     [ command>> +secondary+ word-prop ] find-operation
  52     [ ] [ primary-operation ] ?if ;
  53
  54 : default-flags ( -- assoc )
  55     H{ { +keyboard+ f } { +primary+ f } { +secondary+ f } } ;
  56
  57 : (define-operation) ( operation -- )
  58     dup [ command>> ] [ predicate>> ] bi
  59     2array operations get set-at ;
  60
  61 : define-operation ( pred command flags -- )
  62     default-flags swap assoc-union
  63     dupd define-command <operation>
  64     (define-operation) ;
  65
  66 : modify-operation ( hook translator operation -- operation )
  67     clone
  68         swap >>translator
  69         swap >>hook
  70         t >>listener? ;
  71
  72 : modify-operations ( operations hook translator -- operations )
  73     '[ [ _ _ ] dip modify-operation ] map ;
  74
  75 : operations>commands ( object hook translator -- pairs )
  76     [ object-operations ] 2dip modify-operations
  77     [ [ operation-gesture ] keep ] { } map>assoc ;
  78
  79 : define-operation-map ( class group blurb object hook translator -- )
  80     operations>commands define-command-map ;
  81
  82 : operation-quot ( target command -- quot )
  83     [
  84         swap literalize ,
  85         dup translator>> %
  86         command>> ,
  87     ] [ ] make ;
  88
  89 M: operation invoke-command ( target command -- )
  90     [ hook>> call ] keep operation-quot call ;