From 00fad429b5d790f8ce6fcf74d9e459ed5a0cd8bf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 6 Jan 2009 20:55:23 -0600
Subject: [PATCH] Add shortcuts for scrolling up/down to listener
---
basis/ui/tools/browser/browser.factor | 15 ++-------------
basis/ui/tools/common/common.factor | 16 ++++++++++++++++
basis/ui/tools/listener/listener.factor | 25 +++++++++++++++++--------
basis/ui/tools/tools-docs.factor | 1 +
4 files changed, 36 insertions(+), 21 deletions(-)
create mode 100644 basis/ui/tools/common/common.factor
diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor
index f506d77b8e..40ba6de60c 100644
--- a/basis/ui/tools/browser/browser.factor
+++ b/basis/ui/tools/browser/browser.factor
@@ -5,7 +5,8 @@ assocs words vocabs accessors fry combinators.short-circuit
models models.history tools.apropos ui.tools.workspace
ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.gadgets.buttons ui.gadgets.packs
-ui.gadgets.editors ui.gadgets.labels ui.gadgets.status-bar ui ;
+ui.gadgets.editors ui.gadgets.labels ui.gadgets.status-bar
+ui.tools.common ui ;
IN: ui.tools.browser
TUPLE: browser-gadget < track pane scroller search-field ;
@@ -83,18 +84,6 @@ M: browser-gadget focusable-child* search-field>> ;
\ browser-help H{ { +nullary+ t } } define-command
-: com-page-up ( browser -- )
- scroller>> scroll-up-page ;
-
-: com-page-down ( browser -- )
- scroller>> scroll-down-page ;
-
-: com-scroll-up ( browser -- )
- scroller>> scroll-up-line ;
-
-: com-scroll-down ( browser -- )
- scroller>> scroll-down-line ;
-
browser-gadget "toolbar" f {
{ T{ key-down f { A+ } "LEFT" } com-back }
{ T{ key-down f { A+ } "RIGHT" } com-forward }
diff --git a/basis/ui/tools/common/common.factor b/basis/ui/tools/common/common.factor
new file mode 100644
index 0000000000..944b443422
--- /dev/null
+++ b/basis/ui/tools/common/common.factor
@@ -0,0 +1,16 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors ui.gadgets.scrollers ;
+IN: ui.tools.common
+
+: com-page-up ( tool -- )
+ scroller>> scroll-up-page ;
+
+: com-page-down ( tool -- )
+ scroller>> scroll-down-page ;
+
+: com-scroll-up ( tool -- )
+ scroller>> scroll-up-line ;
+
+: com-scroll-down ( tool -- )
+ scroller>> scroll-down-line ;
diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index f12549b32b..5699fa2a80 100644
--- a/basis/ui/tools/listener/listener.factor
+++ b/basis/ui/tools/listener/listener.factor
@@ -3,15 +3,16 @@
USING: inspector help help.markup io io.styles kernel models strings
namespaces parser quotations sequences vocabs words prettyprint
listener debugger threads boxes concurrency.flags math arrays
-generic accessors combinators assocs fry ui.commands ui.gadgets
-ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes
-ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.packs
+generic accessors combinators assocs fry generic.standard.engines.tuple
+ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.labelled
+ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.packs
ui.gadgets.tracks ui.gadgets.borders ui.gadgets.frames
ui.gadgets.grids ui.gestures ui.operations ui.tools.browser
-ui.tools.interactor ui.tools.inspector ui.tools.workspace ;
+ui.tools.interactor ui.tools.inspector ui.tools.workspace
+ui.tools.common ;
IN: ui.tools.listener
-TUPLE: listener-gadget < track input output ;
+TUPLE: listener-gadget < track input output scroller ;
: listener-streams ( listener -- input output )
[ input>> ] [ output>> <pane-stream> ] bi ;
@@ -85,8 +86,6 @@ M: word word-completion-string
M: method-body word-completion-string
"method-generic" word-prop word-completion-string ;
-USE: generic.standard.engines.tuple
-
M: engine-word word-completion-string
"engine-generic" word-prop word-completion-string ;
@@ -152,7 +151,8 @@ M: engine-word word-completion-string
{ 0 1 } listener-gadget new-track
add-toolbar
init-listener
- dup <listener-scroller> 1 track-add ;
+ dup <listener-scroller> >>scroller
+ dup scroller>> 1 track-add ;
: listener-help ( -- ) "ui-listener" com-follow ;
@@ -175,6 +175,15 @@ listener-gadget "toolbar" f {
{ T{ key-down f { C+ } "d" } com-end }
} define-command-map
+listener-gadget "scrolling"
+"The listener's scroller can be scrolled from the keyboard."
+{
+ { T{ key-down f { A+ } "UP" } com-scroll-up }
+ { T{ key-down f { A+ } "DOWN" } com-scroll-down }
+ { T{ key-down f { A+ } "PAGE_UP" } com-page-up }
+ { T{ key-down f { A+ } "PAGE_DOWN" } com-page-down }
+} define-command-map
+
M: listener-gadget graft*
[ call-next-method ] [ restart-listener ] bi ;
diff --git a/basis/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor
index c0f911ecf7..416f6b46ce 100644
--- a/basis/ui/tools/tools-docs.factor
+++ b/basis/ui/tools/tools-docs.factor
@@ -26,6 +26,7 @@ ARTICLE: "ui-listener" "UI listener"
{ "Clickable presentations (see " { $link "ui-presentations" } ")" }
}
{ $command-map listener-gadget "toolbar" }
+{ $command-map listener-gadget "scrolling" }
{ $command-map interactor "interactor" }
{ $command-map source-editor "word" }
{ $command-map interactor "quotation" }