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