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

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs definitions.icons help
   4 help.topics kernel math.rectangles models.arrow namespaces
   5 sequences tools.crossref ui.gadgets ui.gadgets.glass
   6 ui.gadgets.labeled ui.gadgets.search-tables ui.gadgets.tables
   7 ui.gadgets.wrappers ui.gestures ui.images ui.operations ui.theme
   8 ui.tools.common ;
   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 [ article-title ] zip-with
  24     ] <arrow> link-renderer [ second ] <search-table> dup table>>
  25         [ invoke-primary-operation ] >>action
  26         [ hide-glass ] >>hook
  27         t >>selection-required?
  28         10 >>min-rows
  29         10 >>max-rows
  30         30 >>min-cols
  31         30 >>max-cols drop ;
  32
  33 : <links-popup> ( model quot title -- gadget )
  34     [ <links-table> white-interior ] dip
  35     popup-color <framed-labeled-gadget> links-popup new-wrapper ;
  36
  37 links-popup H{
  38     { T{ key-down f f "ESC" } [ hide-glass ] }
  39 } set-gestures
  40
  41 SLOT: model
  42
  43 : show-links-popup ( browser-gadget quot title -- )
  44     [ dup model>> ] 2dip <links-popup>
  45     [ hand-loc get-global point>rect show-glass ] [ request-focus ] bi ; inline
  46
  47 : com-show-outgoing-links ( browser-gadget -- )
  48     [ uses ] "Outgoing links" show-links-popup ;
  49
  50 : com-show-incoming-links ( browser-gadget -- )
  51     [ usage ] "Incoming links" show-links-popup ;