UI fixes

TODO.FACTOR.txt

@@ -14,6 +14,9 @@
 - move 2repeat somewhere else
 - rotating cube demo
 
+- plugin: extra space in stack effects
+- plugin: type "re" in edit word dialog --> hang
+
 + ui:
 
 - console with presentations
@@ -94,6 +97,8 @@
 
 + i/o:
 
+- print [ foo ] car as \ foo
+- printing f inside a list prints ...
 - merge unix and win32 io where appropriate
 - unix io: handle \n\r and \n\0
 - reader syntax for arrays, byte arrays, displaced aliens

library/bootstrap/win32-io.factor

@@ -40,8 +40,9 @@ USE: win32-api
 
 IN: io-internals
 
-: io-multiplex ( -- task )
-    win32-next-io-task ;
+: io-multiplex ( timeout -- task )
+    #! FIXME: needs to work given a timeout
+    -1 = [ win32-next-io-task ] when ;
 
 : init-io ( -- )
     win32-init-stdio ;

library/collections/sequences-epilogue.factor

@@ -61,6 +61,7 @@ M: sequence (tree-each) [ (tree-each) ] seq-each-with ;
 
 : change-nth ( seq i quot -- )
     pick pick >r >r >r swap nth r> call r> r> swap set-nth ;
+    inline
 
 : (nmap) ( seq i quot -- )
     pick length pick <= [

library/test/gadgets.factor

@@ -78,3 +78,15 @@ USING: gadgets kernel lists math namespaces test ;
 ] unit-test
 
 [ ] [ "pile" get layout* ] unit-test
+
+[
+    1 15
+] [
+    1 15 << line [ ] 0 0 0 14 >> [ resize-shape ] keep shape-size
+] unit-test
+
+[
+    1 15
+] [
+    1 15 << line [ ] 0 22 -1 14 >> [ resize-shape ] keep shape-size
+] unit-test

library/threads.factor

@@ -24,11 +24,15 @@ namespaces ;
 : stop ( -- )
     #! If there is a quotation in the run queue, call it,
     #! otherwise wait for I/O.
-    next-thread [
-        call
+    pending-io? [
+        10 io-multiplex
     ] [
-        io-multiplex [ call ] [ stop ] ifte*
-    ] ifte* ;
+        next-thread [
+            call
+        ] [
+            -1 io-multiplex
+        ] ifte*
+    ] ifte ;
 
 : yield ( -- )
     #! Add the current continuation to the run queue, and yield

library/ui/editors.factor

@@ -70,7 +70,7 @@ TUPLE: editor line caret ;
     dup red background set-paint-prop ;
 
 C: editor ( text -- )
-    0 0 0 0 <line> <gadget> over set-delegate
+    <empty-gadget> over set-delegate
     [ <line-editor> swap set-editor-line ] keep
     [ <caret> swap set-editor-caret ] keep
     [ set-editor-text ] keep
@@ -85,16 +85,19 @@ C: editor ( text -- )
 : caret-size ( editor -- w h )
     1 swap shape-h ;
 
-M: editor user-input* ( ch field -- ? )
+M: editor user-input* ( ch editor -- ? )
     [ [ insert-char ] with-editor ] keep
     scroll>bottom  t ;
 
-M: editor layout* ( field -- )
+M: editor pref-size ( editor -- w h )
+    editor-text shape-size >r 1 + r> ;
+
+M: editor layout* ( editor -- )
     dup [ editor-text shape-size ] keep resize-gadget
     dup editor-caret over caret-size rot resize-gadget
     dup editor-caret swap caret-pos rot move-gadget ;
 
-M: editor draw-shape ( label -- )
+M: editor draw-shape ( editor -- )
     dup [ editor-text draw-shape ] with-trans ;
 
 : <field> ( text -- field )

library/ui/gadgets.factor

@@ -21,25 +21,45 @@ C: gadget ( shape -- gadget )
     #! Redraw a gadget before the next iteration of the event
     #! loop.
     dup gadget-redraw? [
+        drop
+    ] [
         t over set-gadget-redraw?
         gadget-parent [ redraw ] when*
-    ] [
-        drop
     ] ifte ;
 
 : relayout ( gadget -- )
     #! Relayout a gadget before the next iteration of the event
     #! loop. Since relayout also implies the visual
     #! representation changed, we redraw the gadget too.
-    t over set-gadget-redraw?
-    t over set-gadget-relayout?
-    gadget-parent [ relayout ] when* ;
+    dup gadget-relayout? [
+        drop
+    ] [
+        t over set-gadget-redraw?
+        t over set-gadget-relayout?
+        gadget-parent [ relayout ] when*
+    ] ifte ;
 
-: move-gadget ( x y gadget -- ) [ move-shape ] keep redraw ;
-: resize-gadget ( w h gadget -- ) [ resize-shape ] keep relayout ;
+: ?move ( x y gadget quot -- )
+    >r 3dup shape-pos >r rect> r> = [
+        3drop
+    ] r> ifte ; inline
 
-: paint-prop ( gadget key -- value ) swap gadget-paint hash ;
-: set-paint-prop ( gadget value key -- ) rot gadget-paint set-hash ;
+: move-gadget ( x y gadget -- )
+    [ [ move-shape ] keep redraw ] ?move ;
+
+: ?resize ( w h gadget quot -- )
+    >r 3dup shape-size rect> >r rect> r> = [
+        3drop
+    ] r> ifte ; inline
+
+: resize-gadget ( w h gadget -- )
+    [ [ resize-shape ] keep relayout ] ?resize ;
+
+: paint-prop ( gadget key -- value )
+    swap gadget-paint hash ;
+
+: set-paint-prop ( gadget value key -- )
+    rot gadget-paint set-hash ;
 
 GENERIC: pref-size ( gadget -- w h )
 M: gadget pref-size shape-size ;

library/ui/layouts.factor

@@ -10,8 +10,8 @@ sdl ;
     #! Note that nothing is done if the gadget does not need to
     #! be laid out.
     dup gadget-relayout? [
+        f over set-gadget-relayout?
         dup gadget-paint [
-            f over set-gadget-relayout?
             dup layout*
             gadget-children [ layout ] each
         ] bind

library/ui/world.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
 USING: alien errors generic kernel lists math memory namespaces
-prettyprint sdl stdio strings threads ;
+prettyprint sdl sequences stdio strings threads ;
 
 ! The world gadget is the top level gadget that all (visible)
 ! gadgets are contained in. The current world is stored in the
@@ -24,7 +24,7 @@ M: world inside? ( point world -- ? ) 2drop t ;
 
 : draw-world ( world -- )
     dup gadget-redraw? [
-        [ dup draw-gadget ] with-surface
+        [ draw-gadget ] with-surface
     ] [
         drop
     ] ifte ;
@@ -34,7 +34,7 @@ DEFER: handle-event
 : layout-world ( world -- )
     dup
     0 0 width get height get <rectangle> clip set-paint-prop
-    dup layout world-hand update-hand ;
+    layout ;
 
 : world-step ( world -- ? )
     dup world-running? [
@@ -59,7 +59,7 @@ DEFER: handle-event
     ] unless ;
 
 : title ( -- str )
-    "Factor " version cat2 ;
+    "Factor " version append ;
 
 IN: shells
 

library/unix/io.factor

@@ -99,8 +99,13 @@ SYMBOL: io-tasks
         ] each nip
     ] keep ;
 
-: io-multiplex ( -- )
-    make-pollfds 2dup -1 poll drop do-io-tasks io-multiplex ;
+: io-multiplex ( timeout -- )
+    make-pollfds [ pick poll drop ] 2keep do-io-tasks
+    io-multiplex ;
+
+: pending-io? ( -- ? )
+    #! Output if there are waiting I/O requests.
+    io-tasks get hash-size 0 > ;
 
 ! Readers