basis/ui/tools/listener/completion/completion.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs calendar colors documents
   4 documents.elements fry kernel words sets splitting math math.vectors
   5 models.delay models.filter combinators.short-circuit parser present
   6 sequences tools.completion generic generic.standard.engines.tuple
   7 fonts ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.glass
   8 ui.gadgets.scrollers ui.gadgets.tables ui.gadgets.theme
   9 ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.render
  10 ui.tools.listener.history ;
  11 IN: ui.tools.listener.completion
  12
  13 : complete-IN:/USE:? ( tokens -- ? )
  14     2 short tail* { "IN:" "USE:" } intersects? ;
  15
  16 : chop-; ( seq -- seq' )
  17     { ";" } split1-last [ ] [ ] ?if ;
  18
  19 : complete-USING:? ( tokens -- ? )
  20     chop-; { "USING:" } intersects? ;
  21
  22 : up-to-caret ( caret document -- string )
  23     [ { 0 0 } ] 2dip doc-range ;
  24
  25 : vocab-completion? ( interactor -- ? )
  26     [ editor-caret ] [ model>> ] bi up-to-caret " \r\n" split
  27     { [ complete-IN:/USE:? ] [ complete-USING:? ] } 1|| ;
  28
  29 ! We don't directly depend on the listener tool but we use a couple
  30 ! of slots
  31 SLOT: completion-popup
  32 SLOT: interactor
  33 SLOT: history
  34
  35 TUPLE: completion-popup < wrapper table interactor element ;
  36
  37 : find-completion-popup ( gadget -- popup )
  38     [ completion-popup? ] find-parent ;
  39
  40 SINGLETON: completion-renderer
  41 M: completion-renderer row-columns drop present 1array ;
  42 M: completion-renderer row-value drop ;
  43
  44 : <completion-model> ( editor quot -- model )
  45     [ one-word-elt <element-model> 1/3 seconds <delay> ] dip
  46     '[ @ keys 1000 short head ] <filter> ;
  47
  48 M: completion-popup hide-glass-hook
  49     interactor>> f >>completion-popup request-focus ;
  50
  51 : hide-completion-popup ( popup -- )
  52     find-world hide-glass ;
  53
  54 : completion-loc/doc ( popup -- loc doc )
  55     interactor>> [ editor-caret ] [ model>> ] bi ;
  56
  57 GENERIC: completion-string ( object -- string )
  58
  59 M: object completion-string present ;
  60
  61 : method-completion-string ( word -- string )
  62     "method-generic" word-prop present ;
  63
  64 M: method-body completion-string method-completion-string ;
  65
  66 M: engine-word completion-string method-completion-string ;
  67
  68 GENERIC# accept-completion-hook 1 ( item popup -- )
  69
  70 : insert-completion ( item popup -- )
  71     [ completion-string ] [ completion-loc/doc ] bi*
  72     one-word-elt set-elt-string ;
  73
  74 : accept-completion ( item table -- )
  75     find-completion-popup
  76     [ insert-completion ]
  77     [ accept-completion-hook ]
  78     [ nip hide-completion-popup ]
  79     2tri ;
  80
  81 : <completion-table> ( interactor quot -- table )
  82     <completion-model> <table>
  83         monospace-font >>font
  84         t >>selection-required?
  85         completion-renderer >>renderer
  86         dup '[ _ accept-completion ] >>action ;
  87
  88 : <completion-scroller> ( object -- object )
  89     <limited-scroller>
  90         { 300 120 } >>min-dim
  91         { 300 120 } >>max-dim ;
  92
  93 : <completion-popup> ( interactor quot -- popup )
  94     [ completion-popup new-gadget ] 2dip
  95     [ drop >>interactor ] [ <completion-table> >>table ] 2bi
  96     dup table>> <completion-scroller> add-gadget
  97     white <solid> >>interior ;
  98
  99 completion-popup H{
 100     { T{ key-down f f "ESC" } [ hide-completion-popup ] }
 101     { T{ key-down f f "TAB" } [ table>> row-action ] }
 102     { T{ key-down f f " " } [ table>> row-action ] }
 103 } set-gestures
 104
 105 CONSTANT: completion-popup-offset { -4 0 }
 106
 107 : (completion-popup-loc) ( interactor element -- loc )
 108     [ drop screen-loc ] [
 109         [ [ [ editor-caret ] [ model>> ] bi ] dip prev-elt ] [ drop ] 2bi
 110         loc>point
 111     ] 2bi v+ completion-popup-offset v+ ;
 112
 113 : completion-popup-loc-1 ( interactor element -- loc )
 114     [ (completion-popup-loc) ] [ drop caret-dim ] 2bi v+ ;
 115
 116 : completion-popup-loc-2 ( interactor element popup -- loc )
 117     [ (completion-popup-loc) ] dip pref-dim { 0 1 } v* v- ;
 118
 119 : completion-popup-fits? ( interactor element popup -- ? )
 120     [ [ completion-popup-loc-1 ] dip pref-dim v+ ]
 121     [ 2drop find-world dim>> ]
 122     3bi [ second ] bi@ <= ;
 123
 124 : completion-popup-loc ( interactor element popup -- loc )
 125     3dup completion-popup-fits?
 126     [ drop completion-popup-loc-1 ]
 127     [ completion-popup-loc-2 ]
 128     if ;
 129
 130 : show-completion-popup ( interactor quot element -- )
 131     [ nip ] [ drop <completion-popup> ] 3bi
 132     [ nip >>completion-popup drop ]
 133     [ [ 2drop find-world ] [ 2nip ] [ completion-popup-loc ] 3tri ] 3bi
 134     show-glass ;
 135
 136 : code-completion-popup ( interactor -- )
 137     dup vocab-completion?
 138     [ vocabs-matching ] [ words-matching ] ? '[ [ { } ] _ if-empty ]
 139     one-word-elt show-completion-popup ;
 140
 141 : history-matching ( interactor -- alist )
 142     history>> elements>>
 143     [ dup string>> { { CHAR: \n CHAR: \s } } substitute ] { } map>assoc
 144     <reversed> ;
 145
 146 : history-completion-popup ( interactor -- )
 147     dup '[ drop _ history-matching ] one-line-elt show-completion-popup ;
 148
 149 : recall-previous ( interactor -- )
 150     history>> history-recall-previous ;
 151
 152 : recall-next ( interactor -- )
 153     history>> history-recall-next ;
 154
 155 : selected-word ( editor -- word )
 156     dup completion-popup>> [
 157         [ table>> selected-row drop ] [ hide-completion-popup ] bi
 158     ] [
 159         selected-token dup search [ ] [ no-word ] ?if
 160     ] ?if ;