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 fry
13 PREDICATE: listener-command < word +listener+ word-prop ;
15 GENERIC: invoke-command ( target command -- )
17 GENERIC: command-name ( command -- str )
19 TUPLE: command-map blurb commands ;
21 GENERIC: command-description ( command -- str/f )
23 GENERIC: command-word ( command -- word )
25 : <command-map> ( blurb commands -- command-map )
26 { } like \ command-map boa ;
28 : commands ( class -- hash )
29 dup "commands" word-prop [ ] [
30 H{ } clone [ "commands" set-word-prop ] keep
33 : command-map ( group class -- command-map )
36 : command-gestures ( class -- hash )
41 [ '[ _ invoke-command ] swap set ] assoc-each
45 : update-gestures ( class -- )
46 dup command-gestures "gestures" set-word-prop ;
48 : define-command-map ( class group blurb pairs -- )
50 swap pick commands set-at
53 TR: convert-command-name "-" " " ;
55 : (command-name) ( string -- newstring )
56 convert-command-name >title ;
58 M: word command-name ( word -- str )
60 "com-" ?head drop "." ?tail drop
61 dup first Letter? [ rest ] unless
64 M: word command-description ( word -- str )
65 +description+ word-prop ;
67 : default-flags ( -- assoc )
68 H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
70 : define-command ( word hash -- )
71 [ props>> ] [ default-flags swap assoc-union ] bi* update ;
73 : command-quot ( target command -- quot )
74 [ 1quotation ] [ +nullary+ word-prop ] bi
75 [ nip ] [ curry ] if ;
77 M: word invoke-command ( target command -- )
78 command-quot call( -- ) ;
80 M: word command-word ;
82 M: f invoke-command ( target command -- ) 2drop ;
84 : command-string ( gesture command -- string )
87 gesture>string [ " (" % % ")" % ] when*