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 make quotations splitting
5 ui.gestures unicode.case unicode.categories tr fry ;
12 PREDICATE: listener-command < word +listener+ word-prop ;
14 GENERIC: invoke-command ( target command -- )
16 GENERIC: command-name ( command -- str )
18 TUPLE: command-map blurb commands ;
20 GENERIC: command-description ( command -- str/f )
22 GENERIC: command-word ( command -- word )
24 : <command-map> ( blurb commands -- command-map )
25 { } like \ command-map boa ;
27 : commands ( class -- hash )
28 dup "commands" word-prop [ ] [
29 H{ } clone [ "commands" set-word-prop ] keep
32 : get-command-at ( group class -- command-map )
35 : command-gestures ( class -- hash )
40 [ '[ _ invoke-command ] swap ,, ] assoc-each
44 : update-gestures ( class -- )
45 dup command-gestures set-gestures ;
47 : define-command-map ( class group blurb pairs -- )
49 swap pick commands set-at
52 TR: convert-command-name "-" " " ;
54 : (command-name) ( string -- newstring )
55 convert-command-name >title ;
57 M: word command-name ( word -- str )
59 "com-" ?head drop "." ?tail drop
60 dup first Letter? [ rest ] unless
63 M: word command-description ( word -- str )
64 +description+ word-prop ;
66 : default-flags ( -- assoc )
67 H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
69 : define-command ( word hash -- )
70 default-flags swap assoc-union
71 '[ _ assoc-union ] change-props drop ;
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 ;