basis/ui/commands/commands.factor

   1 ! Copyright (C) 2006, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays definitions kernel sequences strings
   4 math assocs words generic namespaces make assocs quotations
   5 splitting ui.gestures unicode.case unicode.categories tr fry
   6 call ;
   7 IN: ui.commands
   8
   9 SYMBOL: +nullary+
  10 SYMBOL: +listener+
  11 SYMBOL: +description+
  12
  13 PREDICATE: listener-command < word +listener+ word-prop ;
  14
  15 GENERIC: invoke-command ( target command -- )
  16
  17 GENERIC: command-name ( command -- str )
  18
  19 TUPLE: command-map blurb commands ;
  20
  21 GENERIC: command-description ( command -- str/f )
  22
  23 GENERIC: command-word ( command -- word )
  24
  25 : <command-map> ( blurb commands -- command-map )
  26     { } like \ command-map boa ;
  27
  28 : commands ( class -- hash )
  29     dup "commands" word-prop [ ] [
  30         H{ } clone [ "commands" set-word-prop ] keep
  31     ] ?if ;
  32
  33 : command-map ( group class -- command-map )
  34     commands at ;
  35
  36 : command-gestures ( class -- hash )
  37     commands values [
  38         [
  39             commands>>
  40             [ drop ] assoc-filter
  41             [ '[ _ invoke-command ] swap set ] assoc-each
  42         ] each
  43     ] H{ } make-assoc ;
  44
  45 : update-gestures ( class -- )
  46     dup command-gestures "gestures" set-word-prop ;
  47
  48 : define-command-map ( class group blurb pairs -- )
  49     <command-map>
  50     swap pick commands set-at
  51     update-gestures ;
  52
  53 TR: convert-command-name "-" " " ;
  54
  55 : (command-name) ( string -- newstring )
  56     convert-command-name >title ;
  57
  58 M: word command-name ( word -- str )
  59     name>>
  60     "com-" ?head drop "." ?tail drop
  61     dup first Letter? [ rest ] unless
  62     (command-name) ;
  63
  64 M: word command-description ( word -- str )
  65     +description+ word-prop ;
  66
  67 : default-flags ( -- assoc )
  68     H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
  69
  70 : define-command ( word hash -- )
  71     [ props>> ] [ default-flags swap assoc-union ] bi* update ;
  72
  73 : command-quot ( target command -- quot )
  74     [ 1quotation ] [ +nullary+ word-prop ] bi
  75     [ nip ] [ curry ] if ;
  76
  77 M: word invoke-command ( target command -- )
  78     command-quot call( -- ) ;
  79
  80 M: word command-word ;
  81
  82 M: f invoke-command ( target command -- ) 2drop ;
  83
  84 : command-string ( gesture command -- string )
  85     [
  86         command-name %
  87         gesture>string [ " (" % % ")" % ] when*
  88     ] "" make ;