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 colors.constants
   4 documents documents.elements fry kernel words sets splitting math
   5 math.vectors models.delay models.arrow combinators.short-circuit
   6 parser present sequences tools.completion tools.vocabs.browser generic
   7 generic.standard.engines.tuple fonts definitions.icons ui.images
   8 ui.commands ui.operations ui.gadgets ui.gadgets.editors
   9 ui.gadgets.glass ui.gadgets.scrollers ui.gadgets.tables
  10 ui.gadgets.tracks ui.gadgets.labeled
  11 ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.pens.solid
  12 ui.tools.listener.history combinators vocabs ui.tools.listener.popups ;
  13 IN: ui.tools.listener.completion
  14
  15 ! We don't directly depend on the listener tool but we use a few slots
  16 SLOT: interactor
  17 SLOT: history
  18
  19 : history-list ( interactor -- alist )
  20     history>> elements>>
  21     [ dup string>> { { CHAR: \n CHAR: \s } } substitute ] { } map>assoc
  22     <reversed> ;
  23
  24 TUPLE: word-completion vocabs ;
  25 C: <word-completion> word-completion
  26
  27 SINGLETONS: vocab-completion char-completion history-completion ;
  28 UNION: definition-completion word-completion vocab-completion ;
  29 UNION: listener-completion definition-completion char-completion history-completion ;
  30
  31 GENERIC: completion-quot ( interactor completion-mode -- quot )
  32
  33 : (completion-quot) ( interactor completion-mode quot -- quot' )
  34     2nip '[ [ { } ] _ if-empty ] ; inline
  35
  36 M: word-completion completion-quot [ words-matching ] (completion-quot) ;
  37 M: vocab-completion completion-quot [ vocabs-matching ] (completion-quot) ;
  38 M: char-completion completion-quot [ chars-matching ] (completion-quot) ;
  39 M: history-completion completion-quot drop '[ drop _ history-list ] ;
  40
  41 GENERIC: completion-element ( completion-mode -- element )
  42
  43 M: object completion-element drop one-word-elt ;
  44 M: history-completion completion-element drop one-line-elt ;
  45
  46 GENERIC: completion-banner ( completion-mode -- string )
  47
  48 M: word-completion completion-banner drop "Words" ;
  49 M: vocab-completion completion-banner drop "Vocabularies" ;
  50 M: char-completion completion-banner drop "Unicode code point names" ;
  51 M: history-completion completion-banner drop "Input history" ;
  52
  53 ! Completion modes also implement the row renderer protocol
  54 M: listener-completion row-columns drop present 1array ;
  55
  56 M: definition-completion prototype-row
  57     drop \ + definition-icon <image-name> "" 2array ;
  58
  59 M: definition-completion row-columns
  60     drop
  61     [ definition-icon <image-name> ]
  62     [ present ] bi
  63     2array ;
  64
  65 M: word-completion row-color
  66     [ vocabulary>> ] [ vocabs>> ] bi* {
  67         { [ 2dup [ vocab-words ] dip memq? ] [ COLOR: black ] }
  68         { [ over ".private" tail? ] [ COLOR: dark-red ] }
  69         [ COLOR: dark-gray ]
  70     } cond 2nip ;
  71
  72 M: vocab-completion row-color
  73     drop vocab? COLOR: black COLOR: dark-gray ? ;
  74
  75 : complete-IN:/USE:? ( tokens -- ? )
  76     2 short tail* { "IN:" "USE:" } intersects? ;
  77
  78 : chop-; ( seq -- seq' )
  79     { ";" } split1-last [ ] [ ] ?if ;
  80
  81 : complete-USING:? ( tokens -- ? )
  82     chop-; { "USING:" } intersects? ;
  83
  84 : complete-CHAR:? ( tokens -- ? )
  85     2 short tail* "CHAR:" swap member? ;
  86
  87 : up-to-caret ( caret document -- string )
  88     [ { 0 0 } ] 2dip doc-range ;
  89
  90 : completion-mode ( interactor -- symbol )
  91     [ vocabs>> ] [ editor-caret ] [ model>> ] tri up-to-caret " \r\n" split
  92     {
  93         { [ dup { [ complete-IN:/USE:? ] [ complete-USING:? ] } 1|| ] [ 2drop vocab-completion ] }
  94         { [ dup complete-CHAR:? ] [ 2drop char-completion ] }
  95         [ drop <word-completion> ]
  96     } cond ;
  97
  98 TUPLE: completion-popup < track interactor table completion-mode ;
  99
 100 : find-completion-popup ( gadget -- popup )
 101     [ completion-popup? ] find-parent ;
 102
 103 : <completion-model> ( editor element quot -- model )
 104     [ <element-model> 1/3 seconds <delay> ] dip
 105     '[ @ keys 1000 short head ] <arrow> ;
 106
 107 M: completion-popup focusable-child* table>> ;
 108
 109 : completion-loc/doc/elt ( popup -- loc doc elt )
 110     [ interactor>> [ editor-caret ] [ model>> ] bi ]
 111     [ completion-mode>> completion-element ]
 112     bi ;
 113
 114 GENERIC: completion-string ( object -- string )
 115
 116 M: object completion-string present ;
 117
 118 : method-completion-string ( word -- string )
 119     "method-generic" word-prop present ;
 120
 121 M: method-body completion-string method-completion-string ;
 122
 123 M: engine-word completion-string method-completion-string ;
 124
 125 GENERIC# accept-completion-hook 1 ( item popup -- )
 126
 127 : insert-completion ( item popup -- )
 128     [ completion-string ] [ completion-loc/doc/elt ] bi* set-elt-string ;
 129
 130 : accept-completion ( item table -- )
 131     find-completion-popup
 132     [ insert-completion ]
 133     [ accept-completion-hook ]
 134     [ nip hide-glass ]
 135     2tri ;
 136
 137 : <completion-table> ( interactor completion-mode -- table )
 138     [ completion-element ] [ completion-quot ] [ nip ] 2tri
 139     [ <completion-model> ] dip <table>
 140         monospace-font >>font
 141         t >>selection-required?
 142         t >>single-click?
 143         30 >>min-cols
 144         10 >>max-rows
 145         dup '[ _ accept-completion ] >>action ;
 146
 147 : <completion-scroller> ( completion-popup -- scroller )
 148     table>> <scroller> COLOR: white <solid> >>interior ;
 149
 150 : <completion-popup> ( interactor completion-mode -- popup )
 151     [ vertical completion-popup new-track ] 2dip
 152     [ [ >>interactor ] [ >>completion-mode ] bi* ] [ <completion-table> >>table ] 2bi
 153     dup [ <completion-scroller> ] [ completion-mode>> completion-banner ] bi
 154     <labeled-gadget> 1 track-add ;
 155
 156 completion-popup H{
 157     { T{ key-down f f "TAB" } [ table>> row-action ] }
 158     { T{ key-down f f " " } [ table>> row-action ] }
 159 } set-gestures
 160
 161 : show-completion-popup ( interactor mode -- )
 162     [ completion-element ] [ <completion-popup> ] 2bi
 163     show-listener-popup ;
 164
 165 : code-completion-popup ( interactor -- )
 166     dup completion-mode show-completion-popup ;
 167
 168 : history-completion-popup ( interactor -- )
 169     history-completion show-completion-popup ;
 170
 171 : recall-previous ( interactor -- )
 172     history>> history-recall-previous ;
 173
 174 : recall-next ( interactor -- )
 175     history>> history-recall-next ;
 176
 177 : completion-gesture ( gesture completion -- value/f operation/f )
 178     table>> selected-row
 179     [ [ nip ] [ gesture>operation ] 2bi ] [ drop f ] if ;
 180
 181 M: completion-popup handle-gesture ( gesture completion -- ? )
 182     2dup completion-gesture dup [
 183         [ nip hide-glass ] [ invoke-command ] 2bi* f
 184     ] [ 2drop call-next-method ] if ;