1 ! Copyright (C) 2006, 2008 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs help.markup kernel make quotations
4 sequences splitting tr ui.gestures unicode words ;
11 PREDICATE: listener-command < word +listener+ word-prop ;
13 GENERIC: invoke-command ( target command -- )
15 GENERIC: command-name ( command -- str )
17 TUPLE: command-map blurb commands ;
19 GENERIC: command-description ( command -- str/f )
21 GENERIC: command-word ( command -- word )
23 : <command-map> ( blurb commands -- command-map )
24 { } like command-map boa ;
26 : commands ( class -- hash )
27 [ "commands" word-prop ] [
28 H{ } clone [ "commands" set-word-prop ] keep
31 TR: convert-command-name "-" " " ;
33 : (command-name) ( string -- newstring )
34 convert-command-name >title ;
36 : get-command-at ( group class -- command-map )
39 : command-map-row ( gesture command -- seq )
44 [ command-word <$link> , ]
45 [ command-description , ]
50 : command-map. ( alist -- )
51 [ command-map-row ] { } assoc>map
52 { "Shortcut" "Command" "Word" "Notes" }
53 [ \ $strong swap ] { } map>assoc prefix
56 : $command-map ( element -- )
57 [ second (command-name) " commands" append $heading ]
59 first2 swap get-command-at
60 [ blurb>> print-element ] [ commands>> command-map. ] bi
63 : $command ( element -- )
64 reverse first3 get-command-at
65 commands>> value-at gesture>string
68 : command-gestures ( class -- hash )
73 [ '[ _ invoke-command ] swap ,, ] assoc-each
77 : update-gestures ( class -- )
78 dup command-gestures set-gestures ;
80 : define-command-map ( class group blurb pairs -- )
82 swap pick commands set-at
87 "com-" ?head drop "." ?tail drop
88 dup first Letter? [ rest ] unless
91 M: word command-description
92 +description+ word-prop ;
94 : default-flags ( -- assoc )
95 H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
97 : define-command ( word hash -- )
98 default-flags swap assoc-union
99 '[ _ assoc-union ] change-props drop ;
101 : command-quot ( target command -- quot )
102 [ 1quotation ] [ +nullary+ word-prop ] bi
103 [ nip ] [ curry ] if ;
105 M: word invoke-command
106 command-quot call( -- ) ;
108 M: word command-word ;
110 M: f invoke-command 2drop ;