Removing old single-line editor and updating code

library/bootstrap/boot-stage1.factor

@@ -189,11 +189,9 @@ sequences vectors words ;
         "/library/ui/gadgets/borders.factor"
         "/library/ui/gadgets/buttons.factor"
         "/library/ui/gadgets/tiles.factor"
-        "/library/ui/gadgets/line-editor.factor"
         "/library/ui/gadgets/sliders.factor"
         "/library/ui/gadgets/viewports.factor"
         "/library/ui/gadgets/scrolling.factor"
-        "/library/ui/gadgets/editors.factor"
         "/library/ui/gadgets/tracks.factor"
         "/library/ui/gadgets/incremental.factor"
         "/library/ui/gadgets/paragraphs.factor"
@@ -204,6 +202,7 @@ sequences vectors words ;
         "/library/ui/text/editor.factor"
         "/library/ui/text/commands.factor"
         "/library/ui/text/field.factor"
+        "/library/ui/text/interactor.factor"
         "/library/ui/ui.factor"
         "/library/ui/gadgets/presentations.factor"
         "/library/ui/tools/listener.factor"

library/ui/cocoa/callback.factor

@@ -4,7 +4,7 @@ IN: objc-classes
 DEFER: FactorCallback
 
 IN: cocoa
-USING: hashtables kernel namespaces objc ;
+USING: gadgets hashtables kernel namespaces objc ;
 
 SYMBOL: callbacks
 
@@ -15,7 +15,7 @@ reset-callbacks
 
 "NSObject" "FactorCallback" {
     { "perform:" "void" { "id" "SEL" "id" }
-        [ 2drop callbacks get hash call ]
+        [ 2drop callbacks get hash ui-try ]
     }
     
     { "dealloc" "void" { "id" "SEL" }

library/ui/gadgets/editors.factor

@@ -1,124 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: gadgets-editors
-USING: arrays freetype gadgets gadgets-labels gadgets-scrolling
-gadgets-theme generic kernel math namespaces sequences strings
-styles threads ;
-
-! A caret
-TUPLE: caret ;
-
-C: caret ( -- caret )
-    dup delegate>gadget
-    dup caret-theme
-    f over set-gadget-visible? ;
-
-USE: line-editor
-
-! An editor gadget wraps a line editor object and passes
-! gestures to the line editor.
-
-TUPLE: editor line caret font color ;
-
-: with-editor ( editor quot -- )
-    #! Execute a quotation in the line editor scope, then
-    #! update the display.
-    swap [ editor-line swap bind ] keep
-    dup relayout editor-caret scroll>gadget ; inline
-
-: editor-text ( editor -- text )
-    editor-line [ line-text get ] bind ;
-
-: set-editor-text ( text editor -- )
-    [ set-line-text ] with-editor ;
-
-: commit-editor-text ( editor -- line )
-    #! Add current line to the history, and clear the editor.
-    [ commit-history line-text get line-clear ] with-editor ;
-
-: run-char-widths ( font str -- wlist )
-    #! List of x co-ordinates of each character.
-    >array [ char-width ] map-with
-    dup 0 [ + ] accumulate swap 2 v/n v+ ;
-
-: x>offset ( x font str -- offset )
-    dup >r run-char-widths [ <= ] find-with drop dup -1 =
-    [ drop r> length ] [ r> drop ] if ;
-
-: set-caret-x ( x editor -- )
-    #! Move the caret to a clicked location.
-    dup [
-        label-font lookup-font line-text get
-        x>offset set-caret-pos
-    ] with-editor ;
-
-: click-editor ( editor -- )
-    dup hand-click-rel first over set-caret-x request-focus ;
-
-editor H{
-    { T{ button-down } [ click-editor ] }
-    { T{ gain-focus } [ editor-caret show-gadget ] }
-    { T{ lose-focus } [ editor-caret hide-gadget ] }
-    { T{ key-down f f "BACKSPACE" } [ [ T{ char-elt } delete-prev-elt ] with-editor ] }
-    { T{ key-down f f "DELETE" } [ [ T{ char-elt } delete-next-elt ] with-editor ] }
-    { T{ key-down f { C+ } "BACKSPACE" } [ [ T{ word-elt } delete-prev-elt ] with-editor ] }
-    { T{ key-down f { C+ } "DELETE" } [ [ T{ word-elt } delete-next-elt ] with-editor ] }
-    { T{ key-down f { A+ } "BACKSPACE" } [ [ T{ document-elt } delete-prev-elt ] with-editor ] }
-    { T{ key-down f { A+ } "DELETE" } [ [ T{ document-elt } delete-next-elt ] with-editor ] }
-    { T{ key-down f f "LEFT" } [ [ T{ char-elt } prev-elt ] with-editor ] }
-    { T{ key-down f f "RIGHT" } [ [ T{ char-elt } next-elt ] with-editor ] }
-    { T{ key-down f { C+ } "LEFT" } [ [ T{ word-elt } prev-elt ] with-editor ] }
-    { T{ key-down f { C+ } "RIGHT" } [ [ T{ word-elt } next-elt ] with-editor ] }
-    { T{ key-down f f "HOME" } [ [ T{ document-elt } prev-elt ] with-editor ] }
-    { T{ key-down f f "END" } [ [ T{ document-elt } next-elt ] with-editor ] }
-    { T{ key-down f { C+ } "k" } [ [ line-clear ] with-editor ] }
-    { T{ button-up f 2 } [ dup click-editor selection get paste-clipboard ] }
-    { T{ paste-action } [ clipboard get paste-clipboard ] }
-} set-gestures
-
-: add-editor-caret 2dup set-editor-caret add-gadget ;
-
-C: editor ( text -- )
-    dup delegate>gadget
-    dup editor-theme
-    <line-editor> over set-editor-line
-    <caret> over add-editor-caret
-    [ set-editor-text ] keep ;
-
-: offset>x ( gadget offset str -- x )
-    head-slice >r label-font lookup-font r> string-width ;
-
-: caret-loc ( editor -- x y )
-    dup editor-line [ caret-pos line-text get ] bind offset>x
-    0 2array ;
-
-: caret-dim ( editor -- w h )
-    rect-dim { 0 1 } v* { 1 0 } v+ ;
-
-M: editor user-input* ( str editor -- ? )
-    [ insert-string ] with-editor f ;
-
-M: editor pref-dim* ( editor -- dim )
-    label-size { 1 0 } v+ ;
-
-M: editor layout* ( editor -- )
-    dup editor-caret over caret-dim swap set-layout-dim
-    dup editor-caret swap caret-loc swap set-rect-loc ;
-
-M: editor label-text editor-text ;
-
-M: editor label-color editor-color ;
-
-M: editor label-font editor-font ;
-
-M: editor set-label-text set-editor-text ;
-
-M: editor set-label-color set-editor-color ;
-
-M: editor set-label-font set-editor-font ;
-
-M: editor draw-gadget* ( editor -- ) draw-label ;
-
-: set-possibilities ( possibilities editor -- )
-    #! Set completion possibilities.
-    [ possibilities set ] with-editor ;

library/ui/gadgets/line-editor.factor

@@ -1,152 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: line-editor
-USING: kernel math namespaces sequences strings vectors words ;
-
-SYMBOL: history
-SYMBOL: history-index
-
-SYMBOL: line-text
-SYMBOL: caret
-
-! Completion
-SYMBOL: possibilities
-
-: history-length ( -- n )
-    #! Call this in the line editor scope.
-    history get length ;
-
-: reset-history ( -- )
-    #! Call this in the line editor scope. After user input,
-    #! resets the history index.
-    history-length history-index set ;
-
-! A point is a mutable object holding an index in the line
-! editor. Changing text in the points registered with the
-! line editor will move the point if it is after the changed
-! text.
-TUPLE: point index ;
-
-: (point-update) ( len from to index -- index )
-    pick over > [
-        >r 3drop r>
-    ] [
-        3dup -rot between? [ 2drop ] [ >r - + r> ] if +
-    ] if ;
-
-: point-update ( len from to point -- )
-    #! Call this in the line editor scope.
-    [ point-index (point-update) ] keep set-point-index ;
-
-: line-replace ( str from to -- )
-    #! Call this in the line editor scope.
-    reset-history
-    pick length pick pick caret get point-update
-    line-text [ replace-slice ] change ;
-
-: line-remove ( from to -- )
-    #! Call this in the line editor scope.
-    "" -rot line-replace ;
-
-: line-length line-text get length ;
-
-: set-line-text ( text -- )
-    #! Call this in the line editor scope.
-    0 line-length line-replace ;
-
-: line-clear ( -- )
-    #! Call this in the line editor scope.
-    "" set-line-text ;
-
-! An element is a unit of text; character, word, etc.
-GENERIC: next-elt* ( i str element -- i )
-GENERIC: prev-elt* ( i str element -- i )
-
-TUPLE: char-elt ;
-
-M: char-elt next-elt* 2drop 1+ ;
-M: char-elt prev-elt* 2drop 1- ;
-
-TUPLE: word-elt ;
-
-M: word-elt next-elt* ( i str element -- i )
-    drop dup length >r [ blank? ] find* drop dup -1 =
-    [ drop r> ] [ r> drop 1+ ] if ;
-
-M: word-elt prev-elt* ( i str element -- i )
-    drop >r 1- r> [ blank? ] find-last* drop 1+ ;
-
-TUPLE: document-elt ;
-
-M: document-elt next-elt* rot 2drop length ;
-M: document-elt prev-elt* 3drop 0 ;
-
-: caret-pos caret get point-index ;
-
-: set-caret-pos caret get set-point-index ;
-
-: next-elt@ ( element -- from to )
-    >r caret-pos dup line-text get r> next-elt* line-length min ;
-
-: next-elt ( element -- )
-    next-elt@ set-caret-pos drop ;
-
-: prev-elt@ ( element -- from to )
-    >r caret-pos dup line-text get r> prev-elt* 0 max swap ;
-
-: prev-elt ( element -- )
-    prev-elt@ drop set-caret-pos ;
-
-: delete-next-elt ( element -- )
-    next-elt@ line-remove ;
-
-: delete-prev-elt ( element -- )
-    prev-elt@ line-remove ;
-
-: insert-string ( str -- )
-    #! Call this in the line editor scope.
-    caret-pos dup line-replace ;
-
-: commit-history ( -- )
-    #! Call this in the line editor scope. Adds the currently
-    #! entered text to the history.
-    line-text get dup empty?
-    [ drop ] [ history get push reset-history ] if ;
-
-: <line-editor> ( -- editor )
-    [
-        "" line-text set
-        0 <point> caret set
-        V{ } clone history set
-        0 history-index set
-        possibilities off
-    ] make-hash ;
-
-: goto-history ( n -- )
-    #! Call this in the line editor scope.
-    dup history get nth set-line-text history-index set ;
-
-: history-prev ( -- )
-    #! Call this in the line editor scope.
-    history-index get dup zero? [
-        drop
-    ] [
-        dup history-length = [ commit-history ] when
-        1- goto-history
-    ] if ;
-
-: history-next ( -- )
-    #! Call this in the line editor scope.
-    history-index get dup 1+ history-length >=
-    [ drop ] [ 1+ goto-history ] if ;
-
-: line-completions ( -- seq )
-    T{ word-elt } prev-elt@ 2dup = [
-        2drop f
-    ] [
-        line-text get subseq possibilities get completions
-        [ word-name ] map
-    ] if ;
-
-: complete ( completion -- )
-    T{ word-elt } prev-elt@ line-replace ;

library/ui/gadgets/panes.factor

@@ -2,56 +2,22 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-panes
 USING: arrays gadgets gadgets-buttons gadgets-controls
-gadgets-editors gadgets-frames gadgets-grids gadgets-labels
+gadgets-frames gadgets-grids gadgets-labels gadgets-scrolling
-gadgets-scrolling gadgets-theme generic hashtables io kernel
+gadgets-theme generic hashtables io kernel math namespaces
-line-editor math namespaces prettyprint sequences strings styles
+sequences strings ;
-threads ;
 
-TUPLE: pane output active current input prototype continuation ;
+TUPLE: pane output active current prototype ;
 
 : add-output 2dup set-pane-output add-gadget ;
 
-: <active-line> ( current input -- line )
-    2array [ ] subset make-shelf ;
-
 : init-line ( pane -- )
     dup pane-prototype clone swap set-pane-current ;
 
 : prepare-line ( pane -- )
     dup init-line dup pane-active unparent
-    [ dup pane-current swap pane-input <active-line> ] keep
+    [ pane-current 1array make-shelf ] keep
     2dup set-pane-active add-gadget ;
 
-: pop-continuation ( pane -- quot )
-    dup pane-continuation f rot set-pane-continuation ;
-
-: pane-eval ( string pane -- )
-    pop-continuation dup [
-        [ continue-with ] in-thread
-    ] when 2drop ;
-
-SYMBOL: structured-input
-
-: pane-call ( quot pane -- )
-    dup [ "Command: " write over short. ] with-stream*
-    >r structured-input set-global
-    "\"structured-input\" \"gadgets-panes\" lookup get-global call"
-    r> pane-eval ;
-
-: replace-input ( string pane -- ) pane-input set-editor-text ;
-
-: print-input ( string pane -- )
-    [
-        dup [
-            <input> presented set
-            bold font-style set
-        ] make-hash format terpri
-    ] with-stream* ;
-
-: pane-commit ( pane -- )
-    dup pane-input commit-editor-text
-    swap 2dup print-input pane-eval ;
-
 : pane-clear ( pane -- )
     dup pane-output clear-incremental pane-current clear-gadget ;
 
@@ -61,20 +27,6 @@ C: pane ( -- pane )
     <pile> <incremental> over add-output
     dup prepare-line ;
 
-pane H{
-    { T{ button-down } [ pane-input click-editor ] }
-    { T{ key-down f f "RETURN" } [ pane-commit ] }
-    { T{ key-down f f "UP" } [ pane-input [ history-prev ] with-editor ] }
-    { T{ key-down f f "DOWN" } [ pane-input [ history-next ] with-editor ] }
-    { T{ key-down f { C+ } "l" } [ pane-clear ] }
-} set-gestures
-
-: <input-pane> ( -- pane )
-    <pane> "" <editor> over set-pane-input ;
-
-M: pane focusable-child* ( pane -- editor )
-    pane-input [ t ] unless* ;
-
 : prepare-print ( current -- gadget )
     #! Optimization: if line has 1 child, add the child.
     dup gadget-children {
@@ -105,12 +57,10 @@ M: pane focusable-child* ( pane -- editor )
 ! Panes are streams.
 M: pane stream-flush ( pane -- ) drop ;
 
-M: pane stream-readln ( pane -- line )
-    [ over set-pane-continuation stop ] callcc1 nip ;
-
 : scroll-pane ( pane -- )
     #! Only input panes scroll.
-    dup pane-input [ dup pane-active scroll>gadget ] when drop ;
+    drop ;
+    ! dup pane-input [ dup pane-active scroll>gadget ] when drop ;
 
 M: pane stream-terpri ( pane -- )
     dup pane-current prepare-print

library/ui/gestures.factor

@@ -6,7 +6,8 @@ sequences words ;
 
 : (gestures) ( gadget -- )
     [
-        dup "gestures" word-prop [ , ] when* delegate (gestures)
+        dup class "gestures" word-prop [ , ] when*
+        delegate (gestures)
     ] when* ;
 
 : gestures ( gadget -- seq ) [ (gestures) ] { } make ;

library/ui/text/document.factor

@@ -17,7 +17,7 @@ test ;
 TUPLE: document locs ;
 
 C: document ( -- document )
-    { "" } <history> over set-delegate
+    V{ "" } clone <history> over set-delegate
     V{ } clone over set-document-locs ;
 
 : add-loc document-locs push ;

library/ui/text/editor.factor

@@ -3,7 +3,7 @@
 IN: gadgets-text
 USING: arrays errors freetype gadgets gadgets-borders
 gadgets-buttons gadgets-frames gadgets-labels gadgets-scrolling
-gadgets-theme io kernel math models namespaces opengl sequences
+io kernel math models namespaces opengl sequences
 strings styles ;
 
 TUPLE: editor

library/ui/text/field.factor

@@ -13,12 +13,13 @@ C: field ( model -- field )
 
 : field-next editor-document go-forward ;
 
-: field-commit ( field -- )
+: field-commit ( field -- string )
-    dup field-model [ >r editor-text r> set-model ] when*
+    [ editor-text ] keep
+    dup field-model [ dupd set-model ] when*
     editor-document dup add-history clear-doc ;
 
 field H{
     { T{ key-down f { C+ } "p" } [ field-prev ] }
     { T{ key-down f { C+ } "n" } [ field-next ] }
-    { T{ key-down f f "ENTER" } [ field-commit ] }
+    { T{ key-down f f "RETURN" } [ field-commit drop ] }
 } set-gestures

library/ui/text/interactor.factor

@@ -0,0 +1,45 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: gadgets-text
+USING: gadgets gadgets-panes io kernel namespaces prettyprint
+styles threads ;
+
+TUPLE: interactor output continuation ;
+
+C: interactor ( output -- gadget )
+    [ set-interactor-output ] keep
+    f <field> over set-gadget-delegate ;
+
+: interactor-eval ( string gadget -- )
+    interactor-continuation dup
+    [ [ continue-with ] in-thread ] [ 2drop ] if ;
+
+SYMBOL: structured-input
+
+: interactor-call ( quot gadget -- )
+    dup interactor-output [
+        "Command: " write over short.
+    ] with-stream*
+    >r structured-input set-global
+    "\"structured-input\" \"gadgets-text\" lookup get-global call"
+    r> interactor-eval ;
+
+: print-input ( string interactor -- )
+    interactor-output [
+        dup [
+            <input> presented set
+            bold font-style set
+        ] make-hash format terpri
+    ] with-stream* ;
+
+: interactor-commit ( gadget -- )
+    dup field-commit
+    swap 2dup print-input interactor-eval ;
+
+interactor H{
+    { T{ key-down f f "RETURN" } [ interactor-commit ] }
+    { T{ key-down f { C+ } "l" } [ interactor-output pane-clear ] }
+} set-gestures
+
+M: interactor stream-readln ( pane -- line )
+    [ over set-interactor-continuation stop ] callcc1 nip ;

library/ui/tools/listener.factor

@@ -1,21 +1,25 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-listener
-USING: arrays gadgets gadgets-editors gadgets-frames
+USING: arrays gadgets gadgets-frames gadgets-labels
-gadgets-labels gadgets-panes gadgets-presentations
+gadgets-panes gadgets-presentations gadgets-scrolling
-gadgets-scrolling gadgets-theme gadgets-tiles gadgets-tracks
+gadgets-text gadgets-theme gadgets-tiles gadgets-tracks generic
-generic hashtables inspector io jedit kernel listener math
+hashtables inspector io jedit kernel listener math models
-models namespaces parser prettyprint sequences shells styles
+namespaces parser prettyprint sequences shells styles threads
-threads words ;
+words ;
 
-TUPLE: listener-gadget pane stack ;
+TUPLE: listener-gadget input output stack ;
 
 : ui-listener-hook ( listener -- )
     >r datastack-hook get call r>
     listener-gadget-stack set-model ;
 
+: listener-stream ( listener -- stream )
+    dup listener-gadget-input swap listener-gadget-output
+    <duplex-stream> ;
+
 : listener-thread ( listener -- )
-    dup listener-gadget-pane [
+    dup listener-stream [
         [ ui-listener-hook ] curry listener-hook set tty
     ] with-stream* ;
 
@@ -23,6 +27,9 @@ TUPLE: listener-gadget pane stack ;
     [ >r clear r> init-namespaces listener-thread ] in-thread
     drop ;
 
+: <listener-input> ( -- gadget )
+    gadget get listener-gadget-output <interactor> ;
+
 : <pane-tile> ( model quot title -- gadget )
     >r <pane-control> <scroller> r> f <tile> ;
 
@@ -34,7 +41,8 @@ TUPLE: listener-gadget pane stack ;
 
 C: listener-gadget ( -- gadget )
     f <model> over set-listener-gadget-stack {
-        { [ <input-pane> ] set-listener-gadget-pane [ <scroller> ] 5/6 }
+        { [ <pane> ] set-listener-gadget-output [ <scroller> ] 4/6 }
+        { [ <listener-input> ] set-listener-gadget-input [ <scroller> ] 1/6 }
         { [ <stack-display> ] f f 1/6 }
     } { 0 1 } make-track* dup start-listener ;
 
@@ -42,15 +50,15 @@ M: listener-gadget pref-dim*
     delegate pref-dim* { 600 600 } vmax ;
 
 M: listener-gadget focusable-child* ( listener -- gadget )
-    listener-gadget-pane ;
+    listener-gadget-input ;
 
 M: listener-gadget gadget-title drop "Listener" <model> ;
 
 : listener-window ( -- ) <listener-gadget> open-window ;
 
 : call-listener ( quot/string listener -- )
-    listener-gadget-pane over quotation?
+    listener-gadget-input over quotation?
-    [ pane-call ] [ replace-input ] if ;
+    [ interactor-call ] [ set-editor-text ] if ;
 
 : listener-tool
     [ listener-gadget? ]

library/ui/tools/search.factor

@@ -1,27 +1,20 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-search
-USING: gadgets gadgets-editors gadgets-frames gadgets-labels
+USING: gadgets gadgets-frames gadgets-labels gadgets-panes
-gadgets-panes gadgets-scrolling gadgets-theme generic help
+gadgets-scrolling gadgets-text gadgets-theme generic help
-inspector kernel sequences words ;
+inspector kernel models sequences words ;
 
-TUPLE: search-gadget pane input quot ;
+TUPLE: search-gadget input ;
 
-: do-search ( apropos -- )
+: <search-pane> ( model quot -- )
-    dup search-gadget-input commit-editor-text dup empty? [
+    [ over empty? [ 2drop ] [ call ] if ] curry
-        2drop
+    <pane-control> ;
-    ] [
-        over search-gadget-pane
-        rot search-gadget-quot with-pane
-    ] if ;
-
-search-gadget H{ { T{ key-down f f "RETURN" } [ do-search ] } }
-set-gestures
 
 C: search-gadget ( quot -- )
-    [ set-search-gadget-quot ] keep {
+    >r f <model> dup r> {
-        { [ <pane> ] set-search-gadget-pane [ <scroller> ] @center }
+        { [ <field> ] set-search-gadget-input f @top }
-        { [ "" <editor> ] set-search-gadget-input f @top }
+        { [ swap <search-pane> <scroller> ] f f @center }
     } make-frame* ;
 
 M: search-gadget focusable-child* search-gadget-input ;