]> gitweb.factorcode.org Git - factor.git/commitdiff
fix a few minor menu bugs
authorSlava Pestov <slava@factorcode.org>
Sat, 9 Jul 2005 22:32:31 +0000 (22:32 +0000)
committerSlava Pestov <slava@factorcode.org>
Sat, 9 Jul 2005 22:32:31 +0000 (22:32 +0000)
library/ui/editors.factor
library/ui/gadgets.factor
library/ui/menus.factor
library/ui/paint.factor
library/ui/panes.factor
library/ui/presentations.factor

index 7348e046e99bfc551bd21372394f58996ccd7704..ae56623ad7e5296fe1583c56b1e9c787dde37ca8 100644 (file)
@@ -9,11 +9,17 @@ sdl sequences strings styles vectors ;
 
 TUPLE: editor line caret ;
 
+: with-editor ( editor quot -- )
+    #! Execute a quotation in the line editor scope, then
+    #! update the display.
+    swap [ editor-line swap bind ] keep
+    dup relayout scroll>bottom ; inline
+
 : editor-text ( editor -- text )
     editor-line [ line-text get ] bind ;
 
 : set-editor-text ( text editor -- )
-    editor-line [ set-line-text ] bind ;
+    [ set-line-text ] with-editor ;
 
 : focus-editor ( editor -- )
     dup editor-caret swap add-gadget ;
@@ -21,11 +27,6 @@ TUPLE: editor line caret ;
 : unfocus-editor ( editor -- )
     editor-caret unparent ;
 
-: with-editor ( editor quot -- )
-    #! Execute a quotation in the line editor scope, then
-    #! update the display.
-    swap [ editor-line swap bind ] keep relayout ; inline
-
 : run-char-widths ( str -- wlist )
     #! List of x co-ordinates of each character.
     0 swap >list
@@ -84,8 +85,7 @@ C: editor ( text -- )
     shape-dim { 0 1 1 } v* { 1 0 0 } v+ ;
 
 M: editor user-input* ( ch editor -- ? )
-    [ [ insert-char ] with-editor ] keep
-    scroll>bottom  t ;
+    [ insert-char ] with-editor  t ;
 
 M: editor pref-dim ( editor -- dim )
     dup editor-text label-size { 1 0 0 } v+ ;
index d3f407d2eea680c3ad83a140262bceb3142c7897..79098c6601e19d21d53a2e9dd8469ad4c939e865 100644 (file)
@@ -27,12 +27,12 @@ DEFER: relayout
 DEFER: add-invalid
 
 : invalidate ( gadget -- )
-    t over set-gadget-redraw?
     t swap set-gadget-relayout? ;
 
 : relayout ( gadget -- )
     #! Relayout and redraw a gadget and its parent before the
     #! next iteration of the event loop.
+    dup redraw
     dup gadget-relayout? [
         drop
     ] [
index 0e5a4f9cb902f14e6c00883591a1fd4fa463dd3c..365592a8de5c8a32562fe773bed302c08051afd3 100644 (file)
@@ -17,13 +17,13 @@ USING: generic kernel lists math namespaces sequences ;
 TUPLE: menu ;
 
 : menu-actions ( menu -- )
-    [ drop world get hide-glass ] [ button-down 1 ] set-action ;
+    [ drop hide-glass ] [ button-down 1 ] set-action ;
 
 : assoc>menu ( assoc menu -- )
     #! Given an association list mapping labels to quotations.
     #! Prepend a call to hide-menu to each quotation.
     [
-        uncons \ hide-menu swons <menu-item> swap add-gadget
+        uncons \ hide-glass swons <menu-item> swap add-gadget
     ] each-with ;
 
 C: menu ( assoc -- gadget )
index 3fd785ac93f56855c7c3beec43c43f8012ca1b9a..2608b977edc1d117638fe47c4ce9a2b85fdf0f7f 100644 (file)
@@ -7,12 +7,7 @@ io strings sequences ;
 : redraw ( 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*
-    ] ifte ;
+    drop  t world get set-gadget-redraw? ;
 
 ! Clipping
 
index 671fb0d0d823a5061b9f1a50022f18d30eef18d5..fecbee8ff8fb43c5501ee30566b4cd16a7a26feb 100644 (file)
@@ -84,6 +84,3 @@ M: pane stream-write-attr ( string style stream -- )
     [ rot "\n" split pane-write ] keep scroll>bottom ;
 
 M: pane stream-close ( stream -- ) drop ;
-
-: <console> ( -- pane )
-    <pane> <scroller> ;
index 9eb21f2bd0f5be39aeb0d2057bc6e67f90d19061..b7bdb3583fce89594e87c80f14ff94fb8399179e 100644 (file)
@@ -20,14 +20,20 @@ DEFER: pane-call
 : command-menu ( pane -- menu )
     presented get dup applicable [
         3dup third [
-            [ swap literal, % ] make-list , , \ pane-call ,
+            [ swap literal, % ] make-list , ,
+            [ pane-call drop ] %
         ] make-list >r second r> cons
     ] map 2nip ;
 
 : init-commands ( gadget pane -- )
-    over presented paint-prop
-    [ [ command-menu <menu> show-menu ] cons button-gestures ]
-    [ 2drop ] ifte ;
+    over presented paint-prop [
+        [ drop ] swap
+        unit
+        [ command-menu <menu> show-menu ] append3
+        button-gestures
+    ] [
+        2drop
+    ] ifte ;
 
 : <styled-label> ( style text -- label )
     <label> swap alist>hash over set-gadget-paint ;