io.styles: support image style

basis/help/markup/markup.factor

@@ -137,6 +137,10 @@ ALIAS: $slot $snippet
         ] with-nesting
     ] ($heading) ;
 
+! Images
+: $image ( element -- )
+    [ [ "" ] dip first image associate format ] ($span) ;
+
 ! Some links
 : write-link ( string object -- )
     link-style get [ write-object ] with-style ;

basis/io/styles/styles-docs.factor

@@ -111,6 +111,12 @@ $nl
 { $subsection with-cell }
 { $subsection write-cell } ;
 
+HELP: href
+{ $description "Character style. A URL string that the text links to." } ;
+
+HELP: image
+{ $description "Character style. A pathname string for an image file to display in place of the printed text. If this style is specified, the printed text serves the same role as the " { $snippet "alt" } " attribute of an HTML " { $snippet "img" } " tag -- the text is only displayed if the output medium does not support images." } ;
+
 ARTICLE: "character-styles" "Character styles"
 "Character styles for " { $link stream-format } " and " { $link with-style } ":"
 { $subsection foreground }
@@ -118,7 +124,10 @@ ARTICLE: "character-styles" "Character styles"
 { $subsection font-name }
 { $subsection font-size }
 { $subsection font-style }
-{ $subsection presented } ;
+"Special styles:"
+{ $subsection href }
+{ $subsection image }
+{ $see-also "presentations" } ;
 
 ARTICLE: "paragraph-styles" "Paragraph styles"
 "Paragraph styles for " { $link with-nesting } ":"
@@ -139,6 +148,8 @@ HELP: write-object
 $io-error ;
 
 ARTICLE: "presentations" "Presentations"
+"A special style for " { $link format } " and " { $link with-nesting } ":"
+{ $subsection presented }
 "The " { $link presented } " style can be used to emit clickable objects. A utility word for outputting this style:"
 { $subsection write-object } ;
 

basis/io/styles/styles.factor

@@ -117,8 +117,12 @@ SYMBOL: font-style
 ! Presentation
 SYMBOL: presented
 
+! Link
 SYMBOL: href
 
+! Image
+SYMBOL: image
+
 ! Paragraph styles
 SYMBOL: page-color
 SYMBOL: border-color

basis/ui/gadgets/panes/panes.factor

@@ -1,15 +1,15 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays hashtables io kernel namespaces sequences
+USING: arrays hashtables io kernel namespaces sequences io.styles
-io.styles strings quotations math opengl combinators memoize
+strings quotations math opengl combinators memoize math.vectors
-math.vectors sorting splitting assocs classes.tuple models
+sorting splitting assocs classes.tuple models continuations
-continuations destructors accessors math.rectangles fry
+destructors accessors math.rectangles fry fonts ui.images ui.gadgets
-fonts ui.gadgets ui.gadgets.private ui.gadgets.borders ui.gadgets.buttons
+ui.gadgets.private ui.gadgets.borders ui.gadgets.buttons
 ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.paragraphs
 ui.gadgets.incremental ui.gadgets.packs ui.gadgets.theme
 ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render
 ui.text ui.gadgets.presentations ui.gadgets.grids ui.gadgets.tracks
-ui.gadgets.grid-lines colors call ;
+ui.gadgets.icons ui.gadgets.grid-lines colors call ;
 IN: ui.gadgets.panes
 
 TUPLE: pane < pack
@@ -210,9 +210,13 @@ MEMO: specified-font ( assoc -- font )
 : apply-presentation-style ( style gadget -- style gadget )
     presented [ <presentation> ] apply-style ;
 
+: apply-image-style ( style gadget -- style gadget )
+    image [ nip <image-name> <icon> ] apply-style ;
+
 : style-label ( style gadget -- gadget )
     apply-font-style
     apply-presentation-style
+    apply-image-style
     nip ; inline
 
 : <styled-label> ( style text -- gadget )
@@ -322,14 +326,18 @@ M: paragraph stream-write1
     over CHAR: \s =
     [ H{ } swap gadget-bl drop ] [ gadget-write1 ] if ;
 
+: empty-output? ( string style -- ? )
+    [ empty? ] [ image swap key? not ] bi* and ;
+
 : gadget-format ( string style stream -- )
-    '[ _ swap <styled-label> _ swap add-gadget drop ] unless-empty ;
+    [ [ empty-output? ] 2keep ] dip
+    '[ _ _ swap <styled-label> _ swap add-gadget drop ] unless ;
 
 M: pack stream-format
     gadget-format ;
 
 M: paragraph stream-format
-    presented pick at [
+    over { presented image } [ swap key? ] with any? [
         gadget-format
     ] [
         [ " " split ] 2dip