markup fixes; changing some stream protocol details

library/bootstrap/boot-stage1.factor

@@ -192,6 +192,7 @@ vectors words ;
         "/library/ui/ui.factor"
 
         "/library/help/database.factor"
+        "/library/help/stylesheet.factor"
         "/library/help/markup.factor"
         "/library/help/help.factor"
         "/library/help/tutorial.factor"

library/help/database.factor

@@ -5,34 +5,8 @@ USING: arrays hashtables io kernel namespaces parser sequences
 strings styles words ;
 
 ! Markup
-SYMBOL: style-stack
-
 GENERIC: print-element
 
-: with-style ( style quot -- )
-    swap style-stack get push call style-stack get pop* ; inline
-
-: current-style ( -- style )
-    H{ } clone style-stack get [ dupd hash-update ] each ;
-
-PREDICATE: array simple-element
-    dup empty? [ drop t ] [ first word? not ] if ;
-
-M: string print-element current-style format ;
-
-M: simple-element print-element [ print-element ] each ;
-
-M: array print-element
-    dup first >r 1 swap tail r> execute ;
-
-: default-style H{ { font "Sans Serif" } { font-size 14 } } ;
-
-: with-markup ( quot -- )
-    [
-        default-style V{ } clone [ push ] keep style-stack set
-        call
-    ] with-scope ; inline
-
 ! Help articles
 SYMBOL: articles
 

library/help/help.factor

@@ -3,16 +3,16 @@ USING: arrays gadgets-presentations hashtables io kernel
 namespaces parser sequences words ;
 
 : help ( topic -- )
-    [
-        dup article-title $heading terpri terpri
-        article-content print-element terpri
-    ] with-markup ;
+    default-style [
+        dup article-title $heading
+        article-content print-element
+    ] with-style ;
 
 : glossary ( name -- ) <term> help ;
 
 "Show word documentation" [ word? ] [ help ] define-command
-"Show term definition" [ term? ] [ help ] define-command
-"Show article" [ link? ] [ help ] define-command
+"Show term definition" [ term? ] [ help ] define-default-command
+"Show article" [ link? ] [ help ] define-default-command
 
 H{ } clone articles global set-hash
 H{ } clone terms global set-hash

library/help/markup.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: help
-USING: gadgets gadgets-panes gadgets-presentations hashtables io
-kernel lists namespaces prettyprint sequences styles ;
+USING: arrays gadgets gadgets-panes gadgets-presentations
+hashtables words io kernel lists namespaces prettyprint
+sequences strings styles ;
 
 ! Simple markup language.
 
@@ -12,27 +13,51 @@ kernel lists namespaces prettyprint sequences styles ;
 
 ! Element types are words whose name begins with $.
 
-: ($span) ( content style -- )
-    [ print-element ] with-style ; inline
+PREDICATE: array simple-element
+    dup empty? [ drop t ] [ first word? not ] if ;
 
-: ($block) ( content style quot -- )
-    >r [ [ print-element ] make-pane ] with-style
-    dup r> call gadget. ; inline
+M: string print-element format* ;
+
+M: array print-element
+    dup first >r 1 swap tail r> execute ;
+
+: ($span) ( content style -- )
+    [ print-element ] with-style ;
+
+: ($block) ( content style -- )
+    terpri dup [
+        [ print-element terpri ] with-style
+    ] with-nesting terpri ;
 
 : $see ( content -- ) first see ;
 
 ! Some spans
-: $heading H{ { font "Serif" } { font-size 24 } } ($span) ;
 
-: $subheading H{ { font "Serif" } { font-size 18 } } ($span) ;
+: $heading heading-style ($block) ;
 
-: $parameter H{ { font "Monospaced" } { font-size 12 } } ($span) ;
+: $subheading subheading-style ($block) ;
+
+: $parameter parameter-style ($span) ;
 
 ! Some blocks
-: $code
-    H{ { font "Monospaced" } { font-size 12 } }
-    [ T{ solid f { 0.9 0.9 0.9 1 } } swap set-gadget-interior ]
-    ($block) ;
+: wrap-string ( string -- )
+    " " split [
+        dup empty? [ dup format* bl ] unless drop
+    ] each ;
+
+: ($paragraph) ( element style -- )
+    dup [
+        [
+            [
+                dup string?
+                [ wrap-string ] [ print-element bl ] if
+            ] each
+        ] with-style
+    ] with-nesting terpri ;
+
+M: simple-element print-element paragraph-style ($paragraph) ;
+
+: $code code-style ($block) ;
 
 ! Some links
 TUPLE: link name ;
@@ -43,16 +68,14 @@ M: link article-content link-name article-content ;
 
 DEFER: help
 
+: ($link) dup article-title swap ;
+
 : $subsection ( object -- )
-    first [
-        dup <link> presented set
-        dup [ link-name help ] curry outline set
-    ] make-hash [ article-title $subheading ] with-style terpri ;
+    subheading-style [
+        first <link> ($link) dup [ link-name help ] curry
+        simple-outliner
+    ] with-style ;
 
-: $link ( name -- )
-    first dup <link> presented associate
-    [ article-title print-element ] with-style ;
+: $link ( article -- ) first <link> ($link) simple-object ;
 
-: $glossary ( element -- )
-    first dup <term> presented associate
-    [ print-element ] with-style ;
+: $glossary ( element -- ) first <term> ($link) simple-object ;

library/help/stylesheet.factor

@@ -0,0 +1,26 @@
+IN: help
+USING: styles ;
+
+: default-style H{ { font "Sans Serif" } { font-size 14 } } ;
+
+: heading-style H{ { font "Serif" } { font-size 24 } } ;
+
+: subheading-style H{ { font "Serif" } { font-size 18 } } ;
+
+: parameter-style H{ { font "Monospaced" } { font-size 12 } } ;
+
+: paragraph-style
+    H{
+        { font "Sans Serif" }
+        { font-size 14 }
+        { wrap-margin 300 }
+    } ;
+
+: code-style
+    H{
+        { font "Monospaced" }
+        { font-size 12 }
+        { page-color { 0.9 0.9 0.9 1 } }
+        { border-color { 0.95 0.95 0.95 1 } }
+        { border-width 5 }
+    } ;

library/io/duplex-stream.factor

@@ -22,8 +22,8 @@ M: duplex-stream stream-write1
 M: duplex-stream stream-write
     duplex-stream-out stream-write ;
 
-M: duplex-stream stream-break
-    duplex-stream-out stream-break ;
+M: duplex-stream stream-bl
+    duplex-stream-out stream-bl ;
 
 M: duplex-stream stream-terpri
     duplex-stream-out stream-terpri ;

library/io/files.factor

@@ -24,18 +24,18 @@ styles ;
     #! Open a file path relative to the Factor source code root.
     resource-path <file-reader> ;
 
+: (file.) ( name path -- )
+    file associate [ format* ] with-style ;
+
 DEFER: directory.
 
-: file-style ( text path -- text style )
-    [
-        dup directory? [
-            >r "/" append r>
-            dup [ directory. ] curry outline set
-        ] when file set
-    ] make-hash ;
+: (directory.) ( name path -- )
+    dup [ directory. ] curry
+    [ "/" append (file.) ] write-outliner ;
 
 : file. ( dir name -- )
-    tuck path+ file-style format ;
+    tuck path+
+    dup directory? [ (directory.) ] [ (file.) terpri ] if ;
 
 : directory. ( dir -- )
-    dup directory [ file. terpri ] each-with ;
+    dup directory [ file. ] each-with ;

library/io/null-stream.factor

@@ -15,5 +15,5 @@ M: f stream-terpri drop ;
 M: f stream-flush drop ;
 
 M: f stream-format 3drop ;
-M: f stream-break drop ;
+M: f stream-bl drop ;
 M: f with-nested-stream rot drop with-stream* ;

library/io/plain-stream.factor

@@ -7,7 +7,8 @@ TUPLE: plain-writer ;
 
 C: plain-writer ( stream -- stream ) [ set-delegate ] keep ;
 
-M: plain-writer stream-break CHAR: \s swap stream-write1 ;
+M: plain-writer stream-bl CHAR: \s swap stream-write1 ;
 M: plain-writer stream-terpri CHAR: \n swap stream-write1 ;
 M: plain-writer stream-format nip stream-write ;
-M: plain-writer with-nested-stream rot drop with-stream* ;
+M: plain-writer with-nested-stream ( quot style stream -- )
+    nip swap with-stream* ;

library/io/stdio.factor

@@ -1,22 +1,23 @@
 ! Copyright (C) 2003, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: io
-USING: errors hashtables generic kernel namespaces strings
-styles ;
+USING: errors generic hashtables kernel namespaces sequences
+strings styles ;
 
+! Default stream
 SYMBOL: stdio
 
 : close ( -- ) stdio get stream-close ;
 
-: readln ( -- string/f )     stdio get stream-readln ;
-: read1 ( -- char/f )       stdio get stream-read1 ;
+: readln ( -- string/f ) stdio get stream-readln ;
+: read1 ( -- char/f ) stdio get stream-read1 ;
 : read ( count -- string ) stdio get stream-read ;
 
 : write1 ( char -- ) stdio get stream-write1 ;
 : write ( string -- ) stdio get stream-write ;
 : flush ( -- ) stdio get stream-flush ;
 
-: break ( -- ) stdio get stream-break ;
+: bl ( -- ) stdio get stream-bl ;
 : terpri ( -- ) stdio get stream-terpri ;
 : format ( string style -- ) stdio get stream-format ;
 
@@ -25,9 +26,6 @@ SYMBOL: stdio
 
 : print ( string -- ) stdio get stream-print ;
 
-: write-outliner ( string object quot -- )
-    [ outline set presented set ] make-hash format terpri ;
-
 : with-stream ( stream quot -- )
     #! Close the stream no matter what happens.
     [ swap stdio set [ close ] cleanup ] with-scope ; inline
@@ -36,3 +34,28 @@ SYMBOL: stdio
     #! Close the stream if there is an error.
     [ swap stdio set [ close rethrow ] recover ] with-scope ;
     inline
+
+SYMBOL: style-stack
+
+V{ } clone style-stack global set-hash
+
+: with-style ( style quot -- )
+    swap style-stack get push call style-stack get pop* ; inline
+
+: current-style ( -- style ) style-stack get hash-concat ;
+
+: format* ( string -- ) current-style format ;
+
+: write-object ( object quot -- )
+    >r presented associate r> with-style ;
+
+: simple-object ( string object -- )
+    #! Writes a clickable presentation with the specified string.
+    [ format* ] write-object ;
+
+: write-outliner ( content caption -- )
+    #! Takes a pair of quotations.
+    >r outline associate r> with-nesting terpri ;
+
+: simple-outliner ( string object content -- )
+    [ simple-object ] write-outliner ;

library/io/stream.factor

@@ -19,7 +19,7 @@ GENERIC: stream-write  ( string stream -- )
 GENERIC: stream-flush  ( stream -- )
 
 ! Extended output protocol.
-GENERIC: stream-break  ( stream -- )
+GENERIC: stream-bl  ( stream -- )
 GENERIC: stream-terpri ( stream -- )
 GENERIC: stream-format ( string style stream -- )
 GENERIC: with-nested-stream ( quot style stream -- )

library/styles.factor

@@ -35,6 +35,7 @@ SYMBOL: file
 SYMBOL: outline
 
 ! Paragraph styles
+SYMBOL: page-color
 SYMBOL: border-color
 SYMBOL: border-width
 SYMBOL: wrap-margin

library/tools/describe.factor

@@ -77,32 +77,32 @@ DEFER: describe
 
 : sheet. ( sheet -- )
     dup format-sheet swap peek
-    [ dup [ describe ] curry write-outliner ] 2each ;
+    [ dup [ describe ] curry simple-outliner ] 2each ;
 
 : describe ( object -- ) dup summary print sheet sheet. ;
 
 : word. ( word -- )
-    dup word-name swap dup [ see ] curry write-outliner ;
+    dup word-name swap dup [ see ] curry simple-outliner ;
 
-: simple-outliner ( seq quot -- | quot: obj -- )
+: sequence-outliner ( seq quot -- | quot: obj -- )
     swap [
-        [ unparse-short ] keep rot dupd curry write-outliner
+        [ unparse-short ] keep rot dupd curry simple-outliner
     ] each-with ;
 
 : words. ( vocab -- )
-    words word-sort [ see ] simple-outliner ;
+    words word-sort [ see ] sequence-outliner ;
 
 : vocabs. ( -- )
     #! Outlining word browser.
-    vocabs [ f over [ words. ] curry write-outliner ] each ;
+    vocabs [ words. ] sequence-outliner ;
 
 : usage. ( word -- )
     #! Outlining usages browser.
-    usage [ usage. ] simple-outliner ;
+    usage [ usage. ] sequence-outliner ;
 
 : uses. ( word -- )
     #! Outlining call hierarchy browser.
-    uses [ uses. ] simple-outliner ;
+    uses [ uses. ] sequence-outliner ;
 
 : stack. ( seq -- seq )
     reverse-slice >array describe ;

library/ui/commands.factor

@@ -10,7 +10,9 @@ TUPLE: command name pred quot default? ;
 V{ } clone commands global set-hash
 
 : forget-command ( name -- )
-    commands [ [ command-name = not ] subset-with ] change ;
+    global [
+        commands [ [ command-name = not ] subset-with ] change
+    ] bind ;
 
 : (define-command) ( name pred quot default? -- )
     <command> dup command-name forget-command commands get push ;
@@ -32,7 +34,7 @@ TUPLE: command-button object ;
 : command-action ( command-button -- )
     #! Invoke the default action.
     command-button-object dup applicable
-    [ command-default? ] find nip command>quot call ;
+    [ command-default? ] find-last nip command>quot call ;
 
 : <command-menu-item> ( presented command -- item )
     [ command>quot [ drop ] swap append ] keep
@@ -63,8 +65,6 @@ C: command-button ( gadget object -- button )
 M: command-button gadget-help ( button -- string )
     command-button-object dup word? [ synopsis ] [ summary ] if ;
 
-"Use as input" [ input? ] [ input-string pane get replace-input ] define-default-command
-
 "Describe" [ drop t ] [ describe ] define-default-command
 "Prettyprint" [ drop t ] [ . ] define-command
 "Push on data stack" [ drop t ] [ ] define-command
@@ -81,3 +81,5 @@ M: command-button gadget-help ( button -- string )
 "Infer stack effect" [ word? ] [ unit infer . ] define-command
 
 "Display gadget" [ [ gadget? ] is? ] [ gadget. ] define-command
+
+"Use as input" [ input? ] [ input-string pane get replace-input ] define-default-command

library/ui/panes.factor

@@ -138,7 +138,7 @@ M: pane stream-write ( string pane -- )
 M: pane stream-format ( string style pane -- )
     [ rot "\n" split pane-format ] keep scroll-pane ;
 
-M: pane stream-break ( pane -- ) pane-current stream-break ;
+M: pane stream-bl ( pane -- ) pane-current stream-bl ;
 
 M: pane stream-close ( pane -- ) drop ;
 
@@ -154,4 +154,4 @@ M: pane stream-close ( pane -- ) drop ;
 
 : make-pane ( quot -- pane )
     #! Execute the quotation with output to an output-only pane.
-    <pane> [ with-pane ] keep ; inline
+    <pane> [ swap with-pane ] keep ; inline

library/ui/paragraphs.factor

@@ -3,9 +3,9 @@ USING: arrays gadgets gadgets-labels generic kernel math
 namespaces sequences ;
 
 ! A word break gadget
-TUPLE: break ;
+TUPLE: word-break ;
 
-C: break ( -- gadget ) " " <label> over set-delegate ;
+C: word-break ( -- gadget ) " " <label> over set-delegate ;
 
 ! A gadget that arranges its children in a word-wrap style.
 TUPLE: paragraph margin ;
@@ -31,7 +31,7 @@ SYMBOL: margin
 
 : wrap-step ( quot child -- | quot: pos child -- )
     dup pref-dim [
-        over break? [
+        over word-break? [
             dup first overrun? [ dup second wrap-line ] when
         ] unless drop wrap-pos rot call
     ] keep first2 advance-y advance-x ; inline

library/ui/presentations.factor

@@ -17,8 +17,8 @@ M: gadget-stream stream-write ( string stream -- )
 M: gadget-stream stream-write1 ( char stream -- )
     >r ch>string r> stream-write ;
 
-M: gadget-stream stream-break ( stream -- )
-    <break> swap add-gadget ;
+M: gadget-stream stream-bl ( stream -- )
+    <word-break> swap add-gadget ;
 
 ! Character styles
 
@@ -42,9 +42,6 @@ M: gadget-stream stream-break ( stream -- )
 : 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
@@ -61,7 +58,8 @@ M: gadget-stream stream-format ( string style stream -- )
 
 : apply-wrap-style ( style pane -- style pane )
     wrap-margin [
-        <paragraph> over 2dup set-pane-prototype set-pane-current
+        2dup <paragraph> swap set-pane-prototype
+        <paragraph> over set-pane-current
     ] apply-style ;
 
 : apply-border-width-style ( style gadget -- style gadget )
@@ -72,16 +70,26 @@ M: gadget-stream stream-format ( string style stream -- )
         <solid> over set-gadget-boundary
     ] apply-style ;
 
-: paragraph-style ( style pane -- gadget )
+: apply-page-color-style ( style gadget -- style gadget )
+    page-color [
+        <solid> over set-gadget-interior
+    ] apply-style ;
+
+: apply-outliner-style ( style gadget -- style gadget )
+    outline [ <outliner> ] apply-style ;
+
+: <styled-paragraph> ( style pane -- gadget )
     apply-wrap-style
     apply-border-width-style
     apply-border-color-style
+    apply-page-color-style
+    apply-outliner-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
+    >r <pane> dup r> swap <styled-paragraph>
+    >r swap with-pane r> ; inline
 
 M: pane with-nested-stream ( quot style stream -- )
     >r <nested-pane> r> write-gadget ;