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 ;
   6 IN: ui.commands
   7
   8 SYMBOL: +nullary+
   9 SYMBOL: +listener+
  10 SYMBOL: +description+
  11
  12 PREDICATE: listener-command < word +listener+ word-prop ;
  13
  14 GENERIC: invoke-command ( target command -- )
  15
  16 GENERIC: command-name ( command -- str )
  17
  18 TUPLE: command-map blurb commands ;
  19
  20 GENERIC: command-description ( command -- str/f )
  21
  22 GENERIC: command-word ( command -- word )
  23
  24 : <command-map> ( blurb commands -- command-map )
  25     { } like \ command-map boa ;
  26
  27 : commands ( class -- hash )
  28     dup "commands" word-prop [ ] [
  29         H{ } clone [ "commands" set-word-prop ] keep
  30     ] ?if ;
  31
  32 : command-map ( group class -- command-map )
  33     commands at ;
  34
  35 : command-gestures ( class -- hash )
  36     commands values [
  37         [
  38             commands>>
  39             [ drop ] assoc-filter
  40             [ [ invoke-command ] curry swap set ] assoc-each
  41         ] each
  42     ] H{ } make-assoc ;
  43
  44 : update-gestures ( class -- )
  45     dup command-gestures "gestures" set-word-prop ;
  46
  47 : define-command-map ( class group blurb pairs -- )
  48     <command-map>
  49     swap pick commands set-at
  50     update-gestures ;
  51
  52 TR: convert-command-name "-" " " ;
  53
  54 : (command-name) ( string -- newstring )
  55     convert-command-name >title ;
  56
  57 M: word command-name ( word -- str )
  58     name>>
  59     "com-" ?head drop
  60     dup first Letter? [ rest ] unless
  61     (command-name) ;
  62
  63 M: word command-description ( word -- str )
  64     +description+ word-prop ;
  65
  66 : default-flags ( -- assoc )
  67     H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
  68
  69 : define-command ( word hash -- )
  70     [ props>> ] [ default-flags swap assoc-union ] bi* update ;
  71
  72 : command-quot ( target command -- quot )
  73     dup 1quotation swap +nullary+ word-prop
  74     [ nip ] [ curry ] if ;
  75
  76 M: word invoke-command ( target command -- )
  77     command-quot call ;
  78
  79 M: word command-word ;
  80
  81 M: f invoke-command ( target command -- ) 2drop ;
  82
  83 : command-string ( gesture command -- string )
  84     [
  85         command-name %
  86         gesture>string [ " (" % % ")" % ] when*
  87     ] "" make ;