Simplify define-operation-map; it doesn't need the hook quotation at all

db4
Slava Pestov 2009-01-15 15:22:25 -06:00
parent ca9e04c086
commit d871691342
4 changed files with 15 additions and 23 deletions

View File

@ -61,8 +61,8 @@ HELP: define-operation
} ;
HELP: define-operation-map
{ $values { "class" "a class word" } { "group" string } { "blurb" { $maybe string } } { "object" object } { "hook" { $quotation "( obj -- newobj )" } ", or " { $link f } } { "translator" { $quotation "( obj -- newobj )" } ", or " { $link f } } }
{ $description "Defines a command map named " { $snippet "group" } " on " { $snippet "class" } " consisting of operations applicable to " { $snippet "object" } ". The hook quotation is applied to the target gadget; the translator quotation is applied to the result of the hook. Finally the result of the translator is passed to the operation. A distinction is drawn between the hook and the translator because for listener operations, the hook runs in the event loop and the translator runs in the listener. This avoids polluting the listener output with large prettyprinted gadgets and long quotations." } ;
{ $values { "class" "a class word" } { "group" string } { "blurb" { $maybe string } } { "object" object } { "translator" { $quotation "( obj -- newobj )" } ", or " { $link f } } }
{ $description "Defines a command map named " { $snippet "group" } " on " { $snippet "class" } " consisting of operations applicable to " { $snippet "object" } ". The translator quotation is applied to the target gadget, and the result of the translator is passed to the operation." } ;
HELP: $operations
{ $values { "element" "a sequence" } }

View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel ui.commands
ui.gestures sequences strings math words generic namespaces make
ui.gestures sequences strings math words generic namespaces
hashtables help.markup quotations assocs fry ;
IN: ui.operations
@ -9,11 +9,10 @@ SYMBOL: +keyboard+
SYMBOL: +primary+
SYMBOL: +secondary+
TUPLE: operation predicate command translator hook listener? ;
TUPLE: operation predicate command translator listener? ;
: <operation> ( predicate command -- operation )
operation new
[ ] >>hook
[ ] >>translator
swap >>command
swap >>predicate ;
@ -56,28 +55,23 @@ SYMBOL: operations
dupd define-command <operation>
operations get push ;
: modify-operation ( hook translator operation -- operation )
: modify-operation ( translator operation -- operation )
clone
swap >>translator
swap >>hook
t >>listener? ;
: modify-operations ( operations hook translator -- operations )
'[ [ _ _ ] dip modify-operation ] map ;
: modify-operations ( operations translator -- operations )
'[ [ _ ] dip modify-operation ] map ;
: operations>commands ( object hook translator -- pairs )
[ object-operations ] 2dip modify-operations
: operations>commands ( object translator -- pairs )
[ object-operations ] dip modify-operations
[ [ operation-gesture ] keep ] { } map>assoc ;
: define-operation-map ( class group blurb object hook translator -- )
: define-operation-map ( class group blurb object translator -- )
operations>commands define-command-map ;
: operation-quot ( target command -- quot )
[
swap literalize ,
dup translator>> %
command>> ,
] [ ] make ;
[ translator>> ] [ command>> ] bi '[ _ @ _ execute ] ;
M: operation invoke-command ( target command -- )
[ hook>> call ] keep operation-quot call ;
operation-quot call ;

View File

@ -257,7 +257,7 @@ M: listener-command invoke-command ( target command -- )
command-quot call-listener ;
M: listener-operation invoke-command ( target command -- )
[ hook>> call ] keep operation-quot call-listener ;
operation-quot call-listener ;
: eval-listener ( string -- )
get-listener input>> [ set-editor-string ] keep

View File

@ -181,7 +181,6 @@ source-editor
"word"
"These commands operate on the Factor word named by the token at the caret position."
\ selected-word
[ ]
[ selected-word ]
define-operation-map
@ -189,6 +188,5 @@ interactor
"quotation"
"These commands operate on the entire contents of the input area."
[ ]
[ quot-action ]
[ [ parse-lines ] with-compilation-unit ]
[ quot-action [ parse-lines ] with-compilation-unit ]
define-operation-map