extra/ui/commands/commands.factor

   1 ! Copyright (C) 2006, 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays definitions kernel sequences strings math assocs
   4 words generic namespaces assocs quotations splitting
   5 ui.gestures ;
   6 IN: ui.commands
   7
   8 SYMBOL: +nullary+
   9 SYMBOL: +listener+
  10 SYMBOL: +description+
  11
  12 PREDICATE: word listener-command +listener+ word-prop ;
  13
  14 GENERIC: invoke-command ( target command -- )
  15
  16 GENERIC: command-name ( command -- str )
  17
  18 TUPLE: command-map blurb ;
  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
  26     { set-command-map-blurb set-delegate }
  27     \ command-map construct ;
  28
  29 : commands ( class -- hash )
  30     dup "commands" word-prop [ ] [
  31         H{ } clone [ "commands" set-word-prop ] keep
  32     ] ?if ;
  33
  34 : command-map ( group class -- command-map )
  35     commands at ;
  36
  37 : command-gestures ( class -- hash )
  38     commands values [
  39         [
  40             [ first ] subset
  41             [ [ invoke-command ] curry 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 : (command-name) ( string -- newstring )
  54     "-" split " " join unclip ch>upper add* ;
  55
  56 M: word command-name ( word -- str )
  57     word-name
  58     "com-" ?head drop
  59     dup first Letter? [ 1 tail ] unless
  60     (command-name) ;
  61
  62 M: word command-description ( word -- str )
  63     +description+ word-prop ;
  64
  65 : default-flags ( -- assoc )
  66     H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
  67
  68 : define-command ( word hash -- )
  69     default-flags swap union >r word-props r> update ;
  70
  71 : command-quot ( target command -- quot )
  72     dup 1quotation swap +nullary+ word-prop
  73     [ nip ] [ curry ] if ;
  74
  75 M: word invoke-command ( target command -- )
  76     command-quot call ;
  77
  78 M: word command-word ;
  79
  80 M: f invoke-command ( target command -- ) 2drop ;
  81
  82 : command-string ( gesture command -- string )
  83     [
  84         command-name %
  85         gesture>string [ " (" % % ")" % ] when*
  86     ] "" make ;