Clean up some messy stack shuffling

basis/ui/tools/listener/listener.factor

@@ -3,22 +3,22 @@
 USING: accessors arrays assocs calendar combinators
 combinators.short-circuit compiler.units concurrency.flags
 concurrency.mailboxes continuations destructors documents
-documents.elements fry hashtables help help.markup io
-io.styles kernel lexer listener math models models.delay models.filter
-namespaces parser prettyprint quotations sequences strings threads
-tools.vocabs ui ui.commands ui.gadgets ui.gadgets.buttons
-ui.gadgets.editors ui.gadgets.frames ui.gadgets.grids
-ui.gadgets.labelled ui.gadgets.panes ui.gadgets.scrollers
-ui.gadgets.status-bar ui.gadgets.tracks ui.gestures ui.operations
-ui.tools.browser ui.tools.common ui.tools.debugger
-ui.tools.listener.completion ui.tools.listener.history vocabs
-vocabs.parser words ;
+documents.elements fry hashtables help help.markup io io.styles kernel
+lexer listener math models models.delay models.filter namespaces
+parser prettyprint quotations sequences strings threads tools.vocabs
+vocabs vocabs.loader vocabs.parser words ui ui.commands ui.gadgets
+ui.gadgets.buttons ui.gadgets.editors ui.gadgets.frames
+ui.gadgets.grids ui.gadgets.labelled ui.gadgets.panes
+ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.tracks
+ui.gestures ui.operations ui.tools.browser ui.tools.common
+ui.tools.debugger ui.tools.listener.completion
+ui.tools.listener.history ;
 IN: ui.tools.listener
 
 ! If waiting is t, we're waiting for user input, and invoking
 ! evaluate-input resumes the thread.
 TUPLE: interactor < source-editor
-output history flag mailbox thread waiting word-model
+output history flag mailbox thread waiting token-model word-model
 completion-popup ;
 
 : register-self ( interactor -- )
@@ -42,16 +42,23 @@ completion-popup ;
         assoc-stack
     ] if ;
 
+: vocab-exists? ( name -- ? )
+    { [ vocab ] [ find-vocab-root ] } 1|| ;
+
+: word-at-caret ( token interactor -- word/vocab/f )
+    dup vocab-completion?
+    [ drop dup vocab-exists? [ >vocab-link ] [ drop f ] if ]
+    [ interactor-use assoc-stack ] if ;
+
 : <word-model> ( interactor -- model )
-    [ one-word-elt <element-model> 1/3 seconds <delay> ] keep
-    '[
-        _ dup vocab-completion?
-        [ drop >vocab-link ] [ interactor-use assoc-stack ] if
-    ] <filter> ;
+    [ token-model>> 1/3 seconds <delay> ]
+    [ '[ _ word-at-caret ] ] bi
+    <filter> ;
 
 : <interactor> ( output -- gadget )
     interactor new-editor
         <flag> >>flag
+        dup one-word-elt <element-model> >>token-model
         dup <word-model> >>word-model
         dup model>> <history> >>history
         swap >>output ;
@@ -332,15 +339,14 @@ M: interactor stream-read-quot
     completion-popup>> focusable-child resend-gesture ;
 
 : interactor-operation ( gesture interactor -- ? )
-    word-model>> value>>
-    [ nip ] [ gesture>operation ] 2bi
-    dup [ invoke-command f ] [ 2drop t ] if ;
+    [ token-model>> value>> ] keep word-at-caret
+    [ nip ] [ gesture>operation ] 2bi dup [ invoke-command f ] [ 2drop t ] if ;
 
 M: interactor handle-gesture
     {
         { [ over key-gesture? not ] [ call-next-method ] }
         { [ dup completion-popup>> ] [ { [ pass-to-popup ] [ call-next-method ] } 2&& ] }
-        { [ dup word-model>> value>> ] [ { [ interactor-operation ] [ call-next-method ] } 2&& ] }
+        { [ dup token-model>> value>> ] [ { [ interactor-operation ] [ call-next-method ] } 2&& ] }
         [ call-next-method ]
     } cond ;
 

core/kernel/kernel.factor

@@ -51,7 +51,7 @@ DEFER: if
 
 ! Default
 : ?if ( default cond true false -- )
-    pick [ roll 2drop call ] [ 2nip call ] if ; inline
+    pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline
 
 ! Slippers and dippers.
 ! Not declared inline because the compiler special-cases them

core/sequences/sequences.factor

@@ -280,7 +280,7 @@ INSTANCE: repetition immutable-sequence
 PRIVATE>
 
 : subseq ( from to seq -- subseq )
-    [ check-slice prepare-subseq (copy) ] [ like ] bi ;
+    [ check-slice prepare-subseq (copy) ] keep like ;
 
 : head ( seq n -- headseq ) (head) subseq ;
 
@@ -386,9 +386,6 @@ PRIVATE>
     [ 2drop f f ]
     if ; inline
 
-: (interleave) ( n elt between quot -- )
-    roll 0 = [ nip ] [ swapd 2slip ] if call ; inline
-
 PRIVATE>
 
 : each ( seq quot -- )
@@ -475,9 +472,6 @@ PRIVATE>
 : partition ( seq quot -- trueseq falseseq )
     over [ 2pusher [ each ] 2dip ] dip tuck [ like ] 2bi@ ; inline
 
-: interleave ( seq between quot -- )
-    [ (interleave) ] 2curry [ [ length ] keep ] dip 2each ; inline
-
 : accumulator ( quot -- quot' vec )
     V{ } clone [ [ push ] curry compose ] keep ; inline
 
@@ -496,6 +490,11 @@ PRIVATE>
 : each-index ( seq quot -- )
     prepare-index 2each ; inline
 
+: interleave ( seq between quot -- )
+    swap [ drop ] [ [ 2dip call ] 2curry ] 2bi
+    [ [ 0 = ] 2dip if ] 2curry
+    each-index ; inline
+
 : map-index ( seq quot -- )
     prepare-index 2map ; inline
 
@@ -700,8 +699,10 @@ PRIVATE>
 
 : join ( seq glue -- newseq )
     [
-        2dup joined-length over new-resizable spin
-        [ dup pick push-all ] [ pick push-all ] interleave drop
+        2dup joined-length over new-resizable [
+            [ [ push-all ] 2curry ] [ [ nip push-all ] 2curry ] 2bi
+            interleave
+        ] keep
     ] keep like ;
 
 : padding ( seq n elt quot -- newseq )