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 assocs fry help.markup kernel make quotations
   4 sequences splitting tr ui.gestures unicode words ;
   5 IN: ui.commands
   6
   7 SYMBOL: +nullary+
   8 SYMBOL: +listener+
   9 SYMBOL: +description+
  10
  11 PREDICATE: listener-command < word +listener+ word-prop ;
  12
  13 GENERIC: invoke-command ( target command -- )
  14
  15 GENERIC: command-name ( command -- str )
  16
  17 TUPLE: command-map blurb commands ;
  18
  19 GENERIC: command-description ( command -- str/f )
  20
  21 GENERIC: command-word ( command -- word )
  22
  23 : <command-map> ( blurb commands -- command-map )
  24     { } like command-map boa ;
  25
  26 : commands ( class -- hash )
  27     dup "commands" word-prop [ ] [
  28         H{ } clone [ "commands" set-word-prop ] keep
  29     ] ?if ;
  30
  31 TR: convert-command-name "-" " " ;
  32
  33 : (command-name) ( string -- newstring )
  34     convert-command-name >title ;
  35
  36 : get-command-at ( group class -- command-map )
  37     commands at ;
  38
  39 : command-map-row ( gesture command -- seq )
  40     [
  41         [ gesture>string , ]
  42         [
  43             [ command-name , ]
  44             [ command-word <$link> , ]
  45             [ command-description , ]
  46             tri
  47         ] bi*
  48     ] { } make ;
  49
  50 : command-map. ( alist -- )
  51     [ command-map-row ] { } assoc>map
  52     { "Shortcut" "Command" "Word" "Notes" }
  53     [ \ $strong swap ] { } map>assoc prefix
  54     $table ;
  55
  56 : $command-map ( element -- )
  57     [ second (command-name) " commands" append $heading ]
  58     [
  59         first2 swap get-command-at
  60         [ blurb>> print-element ] [ commands>> command-map. ] bi
  61     ] bi ;
  62
  63 : $command ( element -- )
  64     reverse first3 get-command-at
  65     commands>> value-at gesture>string
  66     $snippet ;
  67
  68 : command-gestures ( class -- hash )
  69     commands values [
  70         [
  71             commands>>
  72             sift-keys
  73             [ '[ _ invoke-command ] swap ,, ] assoc-each
  74         ] each
  75     ] H{ } make ;
  76
  77 : update-gestures ( class -- )
  78     dup command-gestures set-gestures ;
  79
  80 : define-command-map ( class group blurb pairs -- )
  81     <command-map>
  82     swap pick commands set-at
  83     update-gestures ;
  84
  85 M: word command-name ( word -- str )
  86     name>>
  87     "com-" ?head drop "." ?tail drop
  88     dup first Letter? [ rest ] unless
  89     (command-name) ;
  90
  91 M: word command-description ( word -- str )
  92     +description+ word-prop ;
  93
  94 : default-flags ( -- assoc )
  95     H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
  96
  97 : define-command ( word hash -- )
  98     default-flags swap assoc-union
  99     '[ _ assoc-union ] change-props drop ;
 100
 101 : command-quot ( target command -- quot )
 102     [ 1quotation ] [ +nullary+ word-prop ] bi
 103     [ nip ] [ curry ] if ;
 104
 105 M: word invoke-command ( target command -- )
 106     command-quot call( -- ) ;
 107
 108 M: word command-word ;
 109
 110 M: f invoke-command ( target command -- ) 2drop ;