From 4513417657c1c4e02c1404b6123ad13e75c47d69 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 1 Feb 2009 19:14:43 -0600 Subject: [PATCH] Clean up some messy stack shuffling --- basis/ui/tools/listener/listener.factor | 46 ++++++++++++++----------- core/kernel/kernel.factor | 2 +- core/sequences/sequences.factor | 19 +++++----- 3 files changed, 37 insertions(+), 30 deletions(-) diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 912e279e7f..8a48d25db8 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/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 ; + : ( interactor -- model ) - [ one-word-elt 1/3 seconds ] keep - '[ - _ dup vocab-completion? - [ drop >vocab-link ] [ interactor-use assoc-stack ] if - ] ; + [ token-model>> 1/3 seconds ] + [ '[ _ word-at-caret ] ] bi + ; : ( output -- gadget ) interactor new-editor >>flag + dup one-word-elt >>token-model dup >>word-model dup model>> >>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 ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index be1de76650..b9bd7bfa42 100644 --- a/core/kernel/kernel.factor +++ b/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 diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 1c6cff82c8..b761730ecc 100755 --- a/core/sequences/sequences.factor +++ b/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 )