Browser: keyboard navigation popups for A+k and A+K

basis/ui/tools/browser/browser.factor

@@ -2,14 +2,15 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: debugger help help.topics help.crossref kernel models compiler.units
 assocs words vocabs accessors fry combinators.short-circuit
-sequences models models.history tools.apropos
+sequences models models.history tools.apropos combinators
 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.gadgets.borders ui.tools.common ui ;
+ui.gadgets.glass ui.gadgets.borders ui.tools.common
+ui.tools.browser.popups ui ;
 IN: ui.tools.browser
 
-TUPLE: browser-gadget < tool pane scroller search-field ;
+TUPLE: browser-gadget < tool pane scroller search-field popup ;
 
 { 650 400 } browser-gadget set-tool-dim
 
@@ -52,6 +53,13 @@ M: browser-gadget graft*
 M: browser-gadget ungraft*
     [ call-next-method ] [ remove-definition-observer ] bi ;
 
+M: browser-gadget handle-gesture
+    {
+        { [ over key-gesture? not ] [ call-next-method ] }
+        { [ dup popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
+        [ call-next-method ]
+    } cond ;
+
 : showing-definition? ( defspec assoc -- ? )
     {
         [ key? ]
@@ -115,6 +123,8 @@ browser-gadget "navigation" "Commands for navigating in the article hierarchy" {
     { T{ key-down f { A+ } "u" } com-up }
     { T{ key-down f { A+ } "p" } com-prev }
     { T{ key-down f { A+ } "n" } com-next }
+    { T{ key-down f { A+ } "k" } com-show-outgoing-links }
+    { T{ key-down f { A+ } "K" } com-show-incoming-links }
 } define-command-map
 
 browser-gadget "multi-touch" f {

basis/ui/tools/browser/popups/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/ui/tools/browser/popups/popups.factor

@@ -0,0 +1,49 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs definitions fry help.topics kernel
+colors.constants math.rectangles models.filter namespaces sequences
+sorting ui.gadgets ui.gadgets.glass ui.gadgets.labeled
+ui.gadgets.scrollers ui.gadgets.tables ui.gadgets.search-tables
+ui.gadgets.wrappers ui.gestures ui.operations ui.pens.solid ;
+IN: ui.tools.browser.popups
+
+SINGLETON: link-renderer
+
+M: link-renderer row-columns drop second 1array ;
+
+M: link-renderer row-value drop first ;
+
+TUPLE: links-popup < wrapper ;
+
+: sorted-links ( links -- alist )
+    [ dup article-title ] { } map>assoc sort-values ;
+
+: match? ( value str -- ? )
+    swap second subseq? ;
+
+: <links-table> ( model quot -- table )
+    '[ @ sorted-links ] <filter>
+    link-renderer [ second ] <search-table>
+        [ invoke-primary-operation ] >>action
+        dup '[ _ hide-glass ] >>hook
+        t >>selection-required? ;
+
+: <links-popup> ( model quot title -- gadget )
+    [ <links-table> COLOR: white <solid> >>interior ] dip
+    <labeled-gadget> links-popup new-wrapper ;
+
+links-popup H{
+    { T{ key-down f f "ESC" } [ hide-glass ] }
+} set-gestures
+
+SLOT: model
+
+: show-links-popup ( browser-gadget quot title -- )
+    [ dup model>> ] 2dip <links-popup>
+    [ hand-loc get { 0 0 } <rect> show-glass ] [ request-focus ] bi ;
+
+: com-show-outgoing-links ( browser-gadget -- )
+    [ uses ] "Outgoing links" show-links-popup ;
+
+: com-show-incoming-links ( browser-gadget -- )
+    [ usage ] "Incoming links" show-links-popup ;