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 ;
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 : command-map ( group class -- command-map )
35 : command-gestures ( class -- hash )
40 [ [ invoke-command ] curry swap set ] assoc-each
44 : update-gestures ( class -- )
45 dup command-gestures "gestures" set-word-prop ;
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 )
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 [ props>> ] [ default-flags swap assoc-union ] bi* update ;
72 : command-quot ( target command -- quot )
73 dup 1quotation swap +nullary+ word-prop
74 [ nip ] [ curry ] if ;
76 M: word invoke-command ( target command -- )
79 M: word command-word ;
81 M: f invoke-command ( target command -- ) 2drop ;
83 : command-string ( gesture command -- string )
86 gesture>string [ " (" % % ")" % ] when*