factor/basis/ui/commands/commands.factor

88 lines
2.2 KiB
Factor
Raw Normal View History

! Copyright (C) 2006, 2008 Slava Pestov.
2007-09-20 18:09:08 -04:00
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel sequences strings
math assocs words generic namespaces make assocs quotations
splitting ui.gestures unicode.case unicode.categories tr ;
2007-09-20 18:09:08 -04:00
IN: ui.commands
SYMBOL: +nullary+
SYMBOL: +listener+
SYMBOL: +description+
2008-03-26 19:23:19 -04:00
PREDICATE: listener-command < word +listener+ word-prop ;
2007-09-20 18:09:08 -04:00
GENERIC: invoke-command ( target command -- )
GENERIC: command-name ( command -- str )
TUPLE: command-map blurb commands ;
2007-09-20 18:09:08 -04:00
GENERIC: command-description ( command -- str/f )
GENERIC: command-word ( command -- word )
: <command-map> ( blurb commands -- command-map )
{ } like \ command-map boa ;
2007-09-20 18:09:08 -04:00
: commands ( class -- hash )
dup "commands" word-prop [ ] [
H{ } clone [ "commands" set-word-prop ] keep
] ?if ;
: command-map ( group class -- command-map )
commands at ;
: command-gestures ( class -- hash )
commands values [
[
commands>>
[ drop ] assoc-filter
2007-09-20 18:09:08 -04:00
[ [ invoke-command ] curry swap set ] assoc-each
] each
] H{ } make-assoc ;
: update-gestures ( class -- )
dup command-gestures "gestures" set-word-prop ;
: define-command-map ( class group blurb pairs -- )
<command-map>
swap pick commands set-at
update-gestures ;
TR: convert-command-name "-" " " ;
2007-09-20 18:09:08 -04:00
: (command-name) ( string -- newstring )
convert-command-name >title ;
2007-09-20 18:09:08 -04:00
M: word command-name ( word -- str )
name>>
2007-09-20 18:09:08 -04:00
"com-" ?head drop
dup first Letter? [ rest ] unless
2007-09-20 18:09:08 -04:00
(command-name) ;
M: word command-description ( word -- str )
+description+ word-prop ;
: default-flags ( -- assoc )
H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
: define-command ( word hash -- )
[ props>> ] [ default-flags swap assoc-union ] bi* update ;
2007-09-20 18:09:08 -04:00
: command-quot ( target command -- quot )
dup 1quotation swap +nullary+ word-prop
[ nip ] [ curry ] if ;
M: word invoke-command ( target command -- )
command-quot call ;
M: word command-word ;
M: f invoke-command ( target command -- ) 2drop ;
: command-string ( gesture command -- string )
[
command-name %
gesture>string [ " (" % % ")" % ] when*
] "" make ;