! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions kernel sequences strings math assocs words generic namespaces assocs quotations splitting ui.gestures unicode.case unicode.categories tr ; IN: ui.commands SYMBOL: +nullary+ SYMBOL: +listener+ SYMBOL: +description+ PREDICATE: listener-command < word +listener+ word-prop ; GENERIC: invoke-command ( target command -- ) GENERIC: command-name ( command -- str ) TUPLE: command-map blurb commands ; GENERIC: command-description ( command -- str/f ) GENERIC: command-word ( command -- word ) : ( blurb commands -- command-map ) { } like \ command-map boa ; : 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 [ [ 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 -- ) swap pick commands set-at update-gestures ; TR: convert-command-name "-" " " ; : (command-name) ( string -- newstring ) convert-command-name >title ; M: word command-name ( word -- str ) name>> "com-" ?head drop dup first Letter? [ rest ] unless (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 ; : 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 ;