Display completion popups in the right place

basis/io/styles/styles.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: hashtables io io.streams.plain io.streams.string
 colors summary make accessors splitting math.order
-kernel namespaces assocs destructors strings sequences ;
+kernel namespaces assocs destructors strings sequences
+present ;
 IN: io.styles
 
 GENERIC: stream-format ( str style stream -- )
@@ -172,6 +173,8 @@ TUPLE: input string ;
 
 C: <input> input
 
+M: input present string>> ;
+
 M: input summary
     [
         "Input: " %

basis/ui/gadgets/editors/editors.factor

@@ -146,10 +146,12 @@ M: editor ungraft*
 : line>y ( lines# editor -- y )
     line-height * ;
 
-: caret-loc ( editor -- loc )
+: loc>point ( loc editor -- loc )
-    [ editor-caret* ] keep
     [ loc>x ] [ [ first ] dip line>y ] 2bi 2array ;
 
+: caret-loc ( editor -- loc )
+    [ editor-caret* ] keep loc>point ;
+
 : caret-dim ( editor -- dim )
     line-height 0 swap 2array ;
 

basis/ui/gadgets/tables/tables.factor

@@ -209,9 +209,19 @@ PRIVATE>
 : initial-selected-index ( model table -- n/f )
     [ value>> length 1 >= ] [ selection-required?>> ] bi* and 0 f ? ;
 
+: show-row-summary ( table n -- )
+    over nth-row
+    [ swap [ renderer>> row-value ] keep show-summary ]
+    [ 2drop ]
+    if ;
+
 M: table model-changed
-    tuck initial-selected-index >>selected-index
+    tuck initial-selected-index {
-    [ update-selected-value ] [ relayout ] bi ;
+        [ >>selected-index drop ]
+        [ show-row-summary ]
+        [ drop update-selected-value ]
+        [ drop relayout ]
+    } 2cleave ;
 
 : thin-row-rect ( table row -- rect )
     row-rect [ { 0 1 } v* ] change-dim ;
@@ -242,14 +252,12 @@ PRIVATE>
     hand-click# get 2 =
     [ row-action ] [ update-selected-value ] if ;
 
-: show-row-summary ( row table -- )
-    [ renderer>> row-value ] keep show-summary ;
-
 : select-row ( table n -- )
     over validate-row
     [ (select-row) ]
     [ drop update-selected-value ]
-    [ over nth-row drop swap show-row-summary ] 2tri ;
+    [ show-row-summary ]
+    2tri ;
 
 : prev-row ( table -- )
     dup selected-index>> [ 1- ] [ 0 ] if* select-row ;
@@ -275,11 +283,10 @@ PRIVATE>
 
 : show-mouse-help ( table -- )
     [
-        [ swap >>mouse-index relayout-1 ]
+        swap
-        [
+        [ >>mouse-index relayout-1 ]
-            [ nth-row ] keep
+        [ show-row-summary ]
-            swap [ show-row-summary ] [ 2drop ] if
+        2bi
-        ] 2bi
     ] [ hide-mouse-help ] if-mouse-row ;
 
 : table-operations-menu ( table -- )

basis/ui/tools/listener/listener.factor

@@ -1,18 +1,20 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: inspector kernel help help.markup io io.styles models
+USING: inspector kernel help help.markup io io.styles models math.vectors
 strings splitting namespaces parser quotations sequences vocabs words
 continuations prettyprint listener debugger threads boxes
 concurrency.flags math arrays generic accessors combinators
-assocs fry generic.standard.engines.tuple combinators.short-circuit
+combinators.short-circuit combinators.smart
+assocs fry generic.standard.engines.tuple
 tools.vocabs concurrency.mailboxes vocabs.parser calendar
 models.delay models.filter documents hashtables sets destructors lexer
 ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.labelled
 ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
 ui.gadgets.packs ui.gadgets.tracks ui.gadgets.borders
 ui.gadgets.frames ui.gadgets.grids ui.gadgets.status-bar
-ui.gadgets.wrappers ui.gestures ui.operations ui.tools.browser
+ui.gadgets.viewports ui.gadgets.wrappers ui.gestures ui.operations
-ui.tools.debugger ui.tools.inspector ui.tools.common ui ;
+ui.tools.browser ui.tools.debugger ui.gadgets.theme
+ui.tools.inspector ui.tools.common ui ;
 IN: ui.tools.listener
 
 ! If waiting is t, we're waiting for user input, and invoking
@@ -79,31 +81,35 @@ M: interactor ungraft*
     [ dup help>> remove-connection ] [ call-next-method ] bi ;
 
 M: interactor model-changed
-    2dup help>> eq?
+    2dup [ help>> eq? ] [ nip completion-popup>> not ] 2bi and
     [ [ value>> ] dip show-summary ]
     [ call-next-method ]
     if ;
 
-: write-input ( string input -- )
+GENERIC: (print-input) ( object -- )
-    <input> presented associate
-    [ H{ { font-style bold } } format ] with-nesting ;
 
-: interactor-input. ( string interactor -- )
+M: input (print-input)
-    output>> [
+    dup presented associate
-        dup string? [ dup write-input nl ] [ short. ] if
+    [ string>> H{ { font-style bold } } format ] with-nesting nl ;
-    ] with-output-stream* ;
 
-: add-interactor-history ( str interactor -- )
+M: object (print-input)
-    over empty? [ 2drop ] [ history>> adjoin ] if ;
+    short. ;
+
+: print-input ( object interactor -- )
+    output>> [ (print-input) ] with-output-stream* ;
+
+: add-interactor-history ( input interactor -- )
+    over string>> empty? [ 2drop ] [ history>> adjoin ] if ;
 
 : interactor-continue ( obj interactor -- )
     mailbox>> mailbox-put ;
 
 : interactor-finish ( interactor -- )
-    [ editor-string ] keep
+    [ editor-string <input> ] keep
-    [ interactor-input. ] 2keep
+    [ print-input ]
-    [ add-interactor-history ] keep
+    [ add-interactor-history ]
-    clear-editor ;
+    [ clear-editor drop ]
+    2tri ;
 
 : interactor-eof ( interactor -- )
     dup interactor-busy? [
@@ -111,9 +117,9 @@ M: interactor model-changed
     ] unless drop ;
 
 : evaluate-input ( interactor -- )
-    dup interactor-busy? [
+    dup interactor-busy? [ drop ] [
-        dup control-value over interactor-continue
+        [ control-value ] keep interactor-continue
-    ] unless drop ;
+    ] if ;
 
 : interactor-yield ( interactor -- obj )
     dup thread>> self eq? [
@@ -132,10 +138,9 @@ M: interactor stream-readln
     interactor-read dup [ first ] when ;
 
 : interactor-call ( quot interactor -- )
-    dup interactor-busy? [
+    dup interactor-busy? [ 2drop ] [
-        2dup interactor-input.
+        [ print-input ] [ interactor-continue ] 2bi
-        2dup interactor-continue
+    ] if ;
-    ] unless 2drop ;
 
 M: interactor stream-read
     swap dup zero? [
@@ -299,10 +304,10 @@ M: engine-word word-completion-string method-completion-string ;
     2bi ;
 
 : quot-action ( interactor -- lines )
-    [ control-value ] keep
+    [ [ editor-string <input> ] keep add-interactor-history ]
-    [ [ "\n" join ] dip add-interactor-history ]
+    [ control-value ]
     [ select-all ]
-    2bi ;
+    tri ;
 
 : hide-popup ( listener -- )
     dup popup>> track-remove
@@ -456,22 +461,23 @@ M: completion-renderer row-value drop ;
     '[ @ keys 1000 short head ] <filter> ;
 
 M: completion-popup hide-glass-hook
-    interactor>> f >>completion-popup drop ;
+    interactor>> f >>completion-popup request-focus ;
 
 : hide-completion-popup ( popup -- )
     find-world hide-glass ;
 
-: completion-loc/doc/elt ( popup -- loc doc elt )
+: completion-loc/doc ( popup -- loc doc )
-    [ interactor>> [ editor-caret* ] [ model>> ] bi ] [ element>> ] bi ;
+    interactor>> [ editor-caret* ] [ model>> ] bi ;
 
 : accept-completion ( item table -- )
     find-completion-popup
-    [ [ present ] [ completion-loc/doc/elt ] bi* set-elt-string ]
+    [ [ present ] [ completion-loc/doc ] bi* one-word-elt set-elt-string ]
     [ hide-completion-popup ]
     bi ;
 
 : <completion-table> ( interactor quot -- table )
     <completion-model> <table>
+        monospace-font >>font
         t >>selection-required?
         completion-renderer >>renderer
         dup '[ _ accept-completion ] >>action ;
@@ -493,24 +499,49 @@ completion-popup H{
     { T{ key-down f f " " } [ table>> row-action ] }
 } set-gestures
 
-: show-completion-popup ( interactor quot -- )
+CONSTANT: completion-popup-offset { -4 0 }
-    [ >>completion-popup ] keep
+
-    [ find-world ] dip
+: (completion-popup-loc) ( interactor element -- loc )
-    { 0 0 } show-glass ;
+    [ drop screen-loc ] [
+        [ [ [ editor-caret* ] [ model>> ] bi ] dip prev-elt ] [ drop ] 2bi
+        loc>point
+    ] 2bi v+ completion-popup-offset v+ ;
+
+: completion-popup-loc-1 ( interactor element -- loc )
+    [ (completion-popup-loc) ] [ drop caret-dim ] 2bi v+ ;
+
+: completion-popup-loc-2 ( interactor element popup -- loc )
+    [ (completion-popup-loc) ] dip pref-dim { 0 1 } v* v- ;
+
+: completion-popup-fits? ( interactor element popup -- ? )
+    [ [ completion-popup-loc-1 ] dip pref-dim v+ ]
+    [ 2drop find-world dim>> ]
+    3bi [ second ] bi@ <= ;
+
+: completion-popup-loc ( interactor element popup -- loc )
+    3dup completion-popup-fits?
+    [ drop completion-popup-loc-1 ]
+    [ completion-popup-loc-2 ]
+    if ;
+
+: show-completion-popup ( interactor quot element -- )
+    [ nip ] [ drop <completion-popup> ] 3bi
+    [ nip >>completion-popup drop ]
+    [ [ 2drop find-world ] [ 2nip ] [ completion-popup-loc ] 3tri ] 3bi
+    show-glass ;
 
 : word-completion-popup ( interactor -- )
-    dup dup vocab-completion?
+    dup vocab-completion?
     [ vocabs-matching ] [ words-matching ] ?
-    <completion-popup> one-word-elt >>element
+    one-word-elt show-completion-popup ;
-    show-completion-popup ;
 
-: history-matching ( string interactor -- alist )
+: history-matching ( interactor -- alist )
-    history>> <reversed> dup zip completions ;
+    history>>
+    [ dup string>> { { CHAR: \n CHAR: \s } } substitute ] { } map>assoc
+    <reversed> ;
 
 : history-completion-popup ( interactor -- )
-    dup dup '[ _ history-matching ]
+    dup '[ drop _ history-matching ] one-line-elt show-completion-popup ;
-    <completion-popup> one-line-elt >>element
-    show-completion-popup ;
 
 : pass-to-popup? ( gesture interactor -- ? )
     [ [ key-down? ] [ key-up? ] bi or ]