paragraph styles

library/help/tutorial.factor

@@ -39,7 +39,7 @@ M: string tutorial-line
 
 : <page> ( list -- gadget )
     [ tutorial-line ] map make-pile 1 over set-pack-fill
-    dup page-theme <border> ;
+    dup page-theme <default-border> ;
 
 : tutorial-pages
     {

library/styles.factor

@@ -37,4 +37,4 @@ SYMBOL: outline
 ! Paragraph styles
 SYMBOL: border-color
 SYMBOL: border-width
-SYMBOL: word-wrap
+SYMBOL: wrap-margin

library/ui/borders.factor

@@ -1,16 +1,19 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets-borders
-USING: errors gadgets gadgets-layouts gadgets-theme generic
+USING: arrays errors gadgets gadgets-layouts gadgets-theme
-hashtables kernel math namespaces vectors ;
+generic hashtables kernel math namespaces vectors ;
 
 TUPLE: border size ;
 
-C: border ( child -- border )
+C: border ( child gap -- border )
     dup delegate>gadget
-    { 5 5 0 } over set-border-size
+    [ >r dup 0 3array r> set-border-size ] keep
     [ add-gadget ] keep ;
 
+: <default-border> ( child -- border )
+    5 <border> ;
+
 : layout-border-loc ( border -- )
     dup border-size swap gadget-child set-rect-loc ;
 

library/ui/buttons.factor

@@ -36,7 +36,7 @@ TUPLE: button rollover? pressed? ;
     [ button-update ] [ mouse-enter ] set-action ;
 
 C: button ( gadget quot -- button )
-    rot <border> over set-gadget-delegate
+    rot <default-border> over set-gadget-delegate
     [ swap button-gestures ] keep ;
 
 : <highlight-button> ( gadget quot -- button )

library/ui/commands.factor

@@ -80,9 +80,4 @@ M: command-button gadget-help ( button -- string )
 "Compile" [ word? ] [ recompile ] define-command
 "Infer stack effect" [ word? ] [ unit infer . ] define-command
 
-: gadget. ( gadget -- )
-    gadget associate
-    "This stream does not support live gadgets"
-    swap format terpri ;
-
 "Display gadget" [ [ gadget? ] is? ] [ gadget. ] define-command

library/ui/menus.factor

@@ -39,4 +39,4 @@ namespaces sequences ;
 
 : <menu> ( assoc -- gadget )
     #! Given an association list mapping labels to quotations.
-    menu-items <border> dup menu-theme ;
+    menu-items <default-border> dup menu-theme ;

library/ui/outliner.factor

@@ -24,7 +24,8 @@ DEFER: <expand-button>
     [ outliner? ] find-parent ;
 
 : <expand-arrow> ( ? -- gadget )
-    arrow-right arrow-down ? gray swap <polygon-gadget> <border> ;
+    arrow-right arrow-down ? gray swap
+    <polygon-gadget> <default-border> ;
 
 : <expand-button> ( ? -- gadget )
     #! If true, the button expands, otherwise it collapses.

library/ui/panes.factor

@@ -112,6 +112,14 @@ M: pane stream-terpri ( pane -- )
     3dup car -rot pane-current stream-format cdr dup
     [ over stream-terpri pane-format ] [ 3drop ] if ;
 
+: write-gadget ( gadget pane -- )
+    #! Print a gadget to the given pane.
+    pane-current add-gadget ;
+
+: gadget. ( gadget -- )
+    #! Print a gadget to the current pane.
+    stdio get write-gadget terpri ;
+
 ! Panes are streams.
 M: pane stream-flush ( pane -- ) drop ;
 
@@ -138,12 +146,12 @@ M: pane stream-close ( pane -- ) drop ;
     dup pane-current gadget-children empty?
     [ dup stream-terpri ] unless drop ;
 
-: make-pane ( quot -- pane )
-    #! Execute the quotation with output to an output-only pane.
-    <pane> [ swap with-stream ] keep
-    dup ?pane-terpri pane-output ; inline
-
 : with-pane ( pane quot -- )
     #! Clear the pane and run the quotation in a scope with
     #! stdio set to the pane.
-    >r dup pane-clear r> with-stream* ; inline
+    over pane-clear over >r with-stream*
+    r> ?pane-terpri ; inline
+
+: make-pane ( quot -- pane )
+    #! Execute the quotation with output to an output-only pane.
+    <pane> [ with-pane ] keep ; inline

library/ui/presentations.factor

@@ -5,48 +5,83 @@ USING: arrays gadgets gadgets-borders gadgets-labels
 gadgets-layouts gadgets-outliner gadgets-panes hashtables io
 kernel sequences strings styles ;
 
-: init-commands ( style gadget -- gadget )
+! Utility pseudo-stream for implementation of panes
-    presented rot hash [ <command-button> ] when* ;
-
-: style-font ( style -- font )
-    [ font swap hash [ "Monospaced" ] unless* ] keep
-    [ font-style swap hash [ plain ] unless* ] keep
-    font-size swap hash [ 12 ] unless* 3array ;
-
-: <styled-label> ( style text -- label )
-    <label> foreground pick hash [ over set-label-color ] when*
-    swap style-font over set-label-font ;
-
-: <presentation> ( style text -- presentation )
-    gadget pick hash
-    [ ] [ >r dup dup r> <styled-label> init-commands ] ?if
-    outline rot hash [ <outliner> ] when* ;
 
 UNION: gadget-stream pack paragraph ;
 
+M: gadget-stream stream-close ( stream -- ) drop ;
+
 M: gadget-stream stream-write ( string stream -- )
     over empty? [ 2drop ] [ >r <label> r> add-gadget ] if ;
 
 M: gadget-stream stream-write1 ( char stream -- )
     >r ch>string r> stream-write ;
 
-M: gadget-stream stream-format ( string style stream -- )
-    pick empty? pick hash-empty? and [
-        3drop
-    ] [
-        >r swap <presentation> r> add-gadget
-    ] if ;
-
 M: gadget-stream stream-break ( stream -- )
     <break> swap add-gadget ;
 
-M: gadget-stream stream-close ( stream -- ) drop ;
+! Character styles
 
-: paragraph-style ( pane style -- pane )
+: apply-style ( style gadget key quot -- style gadget )
-    border-width over hash [ >r <border> r> ] when
+    >r pick hash r> when* ; inline
-    border-color swap hash
+
-    [ <solid> over set-gadget-boundary ] when* ;
+: apply-foreground-style ( style gadget -- style gadget )
+    foreground [ over set-label-color ] apply-style ;
+
+: apply-background-style ( style gadget -- style gadget )
+    background [ <solid> over set-gadget-interior ] apply-style ;
+
+: specified-font ( style -- font )
+    [ font swap hash [ "Monospaced" ] unless* ] keep
+    [ font-style swap hash [ plain ] unless* ] keep
+    font-size swap hash [ 12 ] unless* 3array ;
+
+: apply-font-style ( style gadget -- style gadget )
+    over specified-font over set-label-font ;
+
+: apply-command-style ( style gadget -- style gadget )
+    presented [ <command-button> ] apply-style ;
+
+: apply-outliner-style ( style gadget -- style gadget )
+    outline [ <outliner> ] apply-style ;
+
+: <presentation> ( style text -- gadget )
+    <label>
+    apply-foreground-style
+    apply-background-style
+    apply-font-style
+    apply-command-style
+    nip ;
+
+M: gadget-stream stream-format ( string style stream -- )
+    pick empty? pick hash-empty? and
+    [ 3drop ] [ >r swap <presentation> r> add-gadget ] if ;
+
+! Paragraph styles
+
+: apply-wrap-style ( style pane -- style pane )
+    wrap-margin [
+        <paragraph> over set-pane-prototype
+    ] apply-style ;
+
+: apply-border-width-style ( style gadget -- style gadget )
+    border-width [ <border> ] apply-style ;
+
+: apply-border-color-style ( style gadget -- style gadget )
+    border-color [
+        <solid> over set-gadget-boundary
+    ] apply-style ;
+
+: paragraph-style ( style pane -- gadget )
+    apply-wrap-style
+    apply-border-width-style
+    apply-border-color-style
+    nip ;
+
+: <nested-pane> ( quot style -- gadget )
+    #! Create a pane, call the quotation to fill it out.
+    >r <pane> dup r> swap paragraph-style >r swap with-pane r> ;
+    inline
 
 M: pane with-nested-stream ( quot style stream -- )
-    >r >r make-pane r> paragraph-style
+    >r <nested-pane> r> write-gadget ;
-    r> pane-current add-gadget ;