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.case unicode.categories
   5 words ;
   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 TR: convert-command-name "-" " " ;
  33
  34 : (command-name) ( string -- newstring )
  35     convert-command-name >title ;
  36
  37 : get-command-at ( group class -- command-map )
  38     commands at ;
  39
  40 : command-map-row ( gesture command -- seq )
  41     [
  42         [ gesture>string , ]
  43         [
  44             [ command-name , ]
  45             [ command-word <$link> , ]
  46             [ command-description , ]
  47             tri
  48         ] bi*
  49     ] { } make ;
  50
  51 : command-map. ( alist -- )
  52     [ command-map-row ] { } assoc>map
  53     { "Shortcut" "Command" "Word" "Notes" }
  54     [ \ $strong swap ] { } map>assoc prefix
  55     $table ;
  56
  57 : $command-map ( element -- )
  58     [ second (command-name) " commands" append $heading ]
  59     [
  60         first2 swap get-command-at
  61         [ blurb>> print-element ] [ commands>> command-map. ] bi
  62     ] bi ;
  63
  64 : $command ( element -- )
  65     reverse first3 get-command-at
  66     commands>> value-at gesture>string
  67     $snippet ;
  68
  69 : command-gestures ( class -- hash )
  70     commands values [
  71         [
  72             commands>>
  73             sift-keys
  74             [ '[ _ invoke-command ] swap ,, ] assoc-each
  75         ] each
  76     ] H{ } make ;
  77
  78 : update-gestures ( class -- )
  79     dup command-gestures set-gestures ;
  80
  81 : define-command-map ( class group blurb pairs -- )
  82     <command-map>
  83     swap pick commands set-at
  84     update-gestures ;
  85
  86 M: word command-name ( word -- str )
  87     name>>
  88     "com-" ?head drop "." ?tail drop
  89     dup first Letter? [ rest ] unless
  90     (command-name) ;
  91
  92 M: word command-description ( word -- str )
  93     +description+ word-prop ;
  94
  95 : default-flags ( -- assoc )
  96     H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
  97
  98 : define-command ( word hash -- )
  99     default-flags swap assoc-union
 100     '[ _ assoc-union ] change-props drop ;
 101
 102 : command-quot ( target command -- quot )
 103     [ 1quotation ] [ +nullary+ word-prop ] bi
 104     [ nip ] [ curry ] if ;
 105
 106 M: word invoke-command ( target command -- )
 107     command-quot call( -- ) ;
 108
 109 M: word command-word ;
 110
 111 M: f invoke-command ( target command -- ) 2drop ;