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

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs colors.constants
   4 definitions.icons fry help help.topics kernel math.rectangles
   5 models.arrow namespaces sequences tools.crossref ui.gadgets
   6 ui.gadgets.glass ui.gadgets.labeled ui.gadgets.search-tables
   7 ui.gadgets.tables ui.gadgets.theme ui.gadgets.wrappers ui.gestures ui.images
   8 ui.operations ui.pens.solid ui.theme ;
   9 FROM: ui.gadgets.wrappers => wrapper ;
  10 IN: ui.tools.browser.popups
  11
  12 SINGLETON: link-renderer
  13
  14 M: link-renderer row-columns
  15     drop first2 [ definition-icon <image-name> ] dip 2array ;
  16
  17 M: link-renderer row-value drop first ;
  18
  19 TUPLE: links-popup < wrapper ;
  20
  21 : <links-table> ( model quot -- table )
  22     '[
  23         @ sort-articles
  24         [ dup article-title ] { } map>assoc
  25     ] <arrow> link-renderer [ second ] <search-table>
  26         [ invoke-primary-operation ] >>action
  27         [ hide-glass ] >>hook
  28         t >>selection-required?
  29         10 >>min-rows
  30         10 >>max-rows
  31         30 >>min-cols
  32         30 >>max-cols ;
  33
  34 : <links-popup> ( model quot title -- gadget )
  35     [ <links-table> content-background <solid> >>interior ] dip
  36     popup-color <labeled> links-popup new-wrapper ;
  37
  38 links-popup H{
  39     { T{ key-down f f "ESC" } [ hide-glass ] }
  40 } set-gestures
  41
  42 SLOT: model
  43
  44 : show-links-popup ( browser-gadget quot title -- )
  45     [ dup model>> ] 2dip <links-popup>
  46     [ hand-loc get-global point>rect show-glass ] [ request-focus ] bi ; inline
  47
  48 : com-show-outgoing-links ( browser-gadget -- )
  49     [ uses ] "Outgoing links" show-links-popup ;
  50
  51 : com-show-incoming-links ( browser-gadget -- )
  52     [ usage ] "Incoming links" show-links-popup ;