latest fixes

library/syntax/prettyprint.factor

@@ -44,7 +44,11 @@ C: section ( length -- section )
     0 over set-section-indent ;
 
 : section-fits? ( section -- ? )
-    section-end last-newline get - indent get + margin get <= ;
+    margin get dup 0 = [
+        2drop t
+    ] [
+        >r section-end last-newline get - indent get + r> <=
+    ] if ;
 
 : line-limit? ( -- ? )
     line-limit get dup [ line-count get <= ] when ;

library/syntax/see.factor

@@ -48,9 +48,9 @@ sequences styles words ;
     dup pprint-word
     stack-effect stack-effect. ;
 
-: synopsis ( word -- )
+: synopsis ( word -- string )
-    #! Print a brief description of the word in question.
+    #! Output a brief description of the word in question.
-    [ (synopsis) ] with-pprint ;
+    [ 0 margin set [ (synopsis) ] with-pprint ] string-out ;
 
 GENERIC: (see) ( word -- )
 

library/ui/editors.factor

@@ -31,12 +31,14 @@ USE: line-editor
 
 TUPLE: editor line caret ;
 
+: scroll>caret ( editor -- ) editor-caret scroll-to ;
+
 : with-editor ( editor quot -- )
     #! Execute a quotation in the line editor scope, then
     #! update the display.
     swap [ editor-line swap bind ] keep
     dup editor-caret reset-caret
-    dup relayout scroll>bottom ; inline
+    dup relayout scroll>caret ; inline
 
 : editor-text ( editor -- text )
     editor-line [ line-text get ] bind ;

library/ui/layouts.factor

@@ -45,14 +45,17 @@ M: gadget layout* drop ;
 
 : prefer ( gadget -- ) dup pref-dim swap set-gadget-dim ;
 
+DEFER: layout
+
+: layout-children ( gadget -- ) gadget-children [ layout ] each ;
+
 : layout ( gadget -- )
     #! Position the children of the gadget inside the gadget.
     #! Note that nothing is done if the gadget does not need to
     #! be laid out.
     dup gadget-relayout? [
         f over set-gadget-relayout?
-        dup layout*
+        dup layout* dup layout-children
-        dup gadget-children [ layout ] each
     ] when drop ;
 
 TUPLE: pack align fill gap vector ;

library/ui/panes.factor

@@ -131,15 +131,15 @@ M: pane stream-finish ( pane -- ) drop ;
 M: pane stream-readln ( pane -- line )
     [ over set-pane-continuation stop ] callcc1 nip ;
 
-: ?scroll>bottom ( pane -- )
+: scroll-pane ( pane -- )
-    dup pane-scrolls? [ dup scroll>bottom ] when drop ;
+    dup pane-scrolls? [ pane-input scroll>caret ] [ drop ] if ;
 
 M: pane stream-write1 ( char pane -- )
     [ >r ch>string <label> r> pane-current add-gadget ] keep
-    ?scroll>bottom ;
+    scroll-pane ;
 
 M: pane stream-format ( string style pane -- )
-    [ rot "\n" split pane-write ] keep ?scroll>bottom ;
+    [ rot "\n" split pane-write ] keep scroll-pane ;
 
 M: pane stream-close ( pane -- ) drop ;
 

library/ui/presentations.factor

@@ -36,7 +36,7 @@ C: command-button ( gadget object -- button )
 
 M: command-button gadget-help ( button -- string )
     command-button-object
-    dup word? [ [ synopsis ] string-out ] [ summary ] if ;
+    dup word? [ synopsis ] [ summary ] if ;
 
 : init-commands ( gadget -- gadget )
     dup presented paint-prop [ <command-button> ] when* ;

library/ui/scrolling.factor

@@ -5,10 +5,11 @@ USING: arrays gadgets gadgets-books gadgets-layouts generic kernel
 lists math namespaces sequences styles threads ;
 
 ! A viewport can be scrolled.
-TUPLE: viewport bottom? ;
+TUPLE: viewport ;
 
 ! A scroller combines a viewport with two x and y sliders.
-TUPLE: scroller viewport x y ;
+! The follows slot is set by scroll-to.
+TUPLE: scroller viewport x y follows ;
 
 : scroller-origin ( scroller -- { x y 0 } )
     dup scroller-x slider-value
@@ -43,21 +44,19 @@ M: viewport pref-dim gadget-child pref-dim ;
     2dup over scroller-x update-slider
     over scroller-y update-slider ;
 
-: (scroll>bottom) ( viewport scroller -- )
+: update-scroller ( scroller -- )
-    over viewport-bottom? [
+    dup dup scroller-follows dup [
-        f pick set-viewport-bottom?
+        f rot set-scroller-follows screen-loc
-        2dup swap viewport-dim scroll
+    ] [
-    ] when 2drop ;
+        drop scroller-origin
+    ] if scroll ;
 
-: update-scroller ( scroller -- ) dup scroller-origin scroll ;
+: position-viewport ( viewport scroller -- )
-
+    scroller-origin vneg swap gadget-child set-rect-loc ;
-: update-viewport ( viewport scroller -- )
-    scroller-origin vneg
-    swap gadget-child dup prefer set-rect-loc ;
 
 M: viewport layout* ( viewport -- )
-    dup find-scroller dup update-scroller
+    dup gadget-child dup prefer layout
-    2dup (scroll>bottom) update-viewport ;
+    dup find-scroller dup update-scroller position-viewport ;
 
 M: viewport focusable-child* ( viewport -- gadget )
     gadget-child ;
@@ -68,9 +67,11 @@ M: viewport focusable-child* ( viewport -- gadget )
 
 : add-y-slider 2dup set-scroller-y @right frame-add ;
 
-: scroll>bottom ( gadget -- )
+: scroll-to ( gadget -- )
-    find-viewport
+    #! Scroll the scroller that contains this gadget, if any, so
-    [ t over set-viewport-bottom? relayout ] when* ;
+    #! that the gadget becomes visible.
+    dup find-scroller dup
+    [ [ set-scroller-follows ] keep relayout ] [ 2drop ] if ;
 
 : scroll-up-line scroller-y -1 swap slide-by-line ;