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