From e62f068db7203dec4a6eb851a2f683e060cce38e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 29 Sep 2008 04:09:02 -0500
Subject: [PATCH] html.streams now emits clickable URLs for $url markup
 elements

---
 basis/help/markup/markup.factor         | 5 ++++-
 basis/html/streams/streams-docs.factor  | 6 +++---
 basis/html/streams/streams-tests.factor | 4 ++--
 basis/html/streams/streams.factor       | 9 ++++++---
 basis/io/styles/styles.factor           | 2 ++
 5 files changed, 17 insertions(+), 9 deletions(-)

diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor
index b5e074b598..1eae56cfcc 100755
--- a/basis/help/markup/markup.factor
+++ b/basis/help/markup/markup.factor
@@ -71,7 +71,10 @@ ALIAS: $slot $snippet
     [ strong-style get print-element* ] ($span) ;
 
 : $url ( children -- )
-    [ url-style get print-element* ] ($span) ;
+    [
+        dup first href associate url-style get assoc-union
+        print-element*
+    ] ($span) ;
 
 : $nl ( children -- )
     nl nl drop ;
diff --git a/basis/html/streams/streams-docs.factor b/basis/html/streams/streams-docs.factor
index d7638a2817..f05eeb30fc 100644
--- a/basis/html/streams/streams-docs.factor
+++ b/basis/html/streams/streams-docs.factor
@@ -13,13 +13,13 @@ HELP: <html-stream>
 { $values { "stream" "an output stream" } { "html-stream" html-stream } }
 { $description "Creates a new formatted output stream which emits HTML markup on " { $snippet "stream" } "." } ;
 
-HELP: with-html-stream
+HELP: with-html-writer
 { $values { "quot" quotation } }
 { $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an " { $link html-stream } " wrapping the current " { $link output-stream } "." }
 { $examples
     { $example
         "USING: io io.styles html.streams ;"
-        "[ \"Hello\" { { font-style bold } } format nl ] with-html-stream"
+        "[ \"Hello\" { { font-style bold } } format nl ] with-html-writer"
         "<span style='font-style: normal; font-weight: bold; '>Hello</span><br/>"
     }
 } ;
@@ -28,6 +28,6 @@ ARTICLE: "html.streams" "HTML streams"
 "The " { $vocab-link "html.streams" } " vocabulary provides a stream which implements " { $link "styles" } " by writing HTML markup to the wrapped stream."
 { $subsection html-stream }
 { $subsection <html-stream> }
-{ $subsection with-html-stream } ;
+{ $subsection with-html-writer } ;
 
 ABOUT: "html.streams"
diff --git a/basis/html/streams/streams-tests.factor b/basis/html/streams/streams-tests.factor
index b5707c158f..94229b3aea 100644
--- a/basis/html/streams/streams-tests.factor
+++ b/basis/html/streams/streams-tests.factor
@@ -4,7 +4,7 @@ xml.writer sbufs sequences inspector colors ;
 IN: html.streams.tests
 
 : make-html-string
-    [ with-html-stream ] with-string-writer ; inline
+    [ with-html-writer ] with-string-writer ; inline
 
 [ [ ] make-html-string ] must-infer
 
@@ -71,4 +71,4 @@ M: funky browser-link-href
     [ H{ } [ ] with-nesting nl ] make-html-string
 ] unit-test
 
-[ ] [ [ { 1 2 3 } describe ] with-html-stream ] unit-test
+[ ] [ [ { 1 2 3 } describe ] with-html-writer ] unit-test
diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor
index 7d0fe9b17c..6874dc2edd 100755
--- a/basis/html/streams/streams.factor
+++ b/basis/html/streams/streams.factor
@@ -22,7 +22,7 @@ TUPLE: html-stream stream last-div ;
 : not-a-div ( stream -- stream )
     f >>last-div ; inline
 
-: a-div ( stream -- straem )
+: a-div ( stream -- stream )
     t >>last-div ; inline
 
 : <html-stream> ( stream -- html-stream )
@@ -48,6 +48,9 @@ TUPLE: html-sub-stream < html-stream style parent ;
         ] [ call ] if*
     ] [ call ] if* ; inline
 
+: href-link-tag ( style quot -- )
+    href pick at [ <a =href a> call </a> ] [ call ] if* ; inline
+
 : hex-color, ( color -- )
     [ red>> ] [ green>> ] [ blue>> ] tri
     [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] tri@ ;
@@ -95,7 +98,7 @@ TUPLE: html-sub-stream < html-stream style parent ;
 
 : format-html-span ( string style stream -- )
     stream>> [
-        [ [ drop write ] span-tag ] object-link-tag
+        [ [ [ drop write ] span-tag ] href-link-tag ] object-link-tag
     ] with-output-stream* ;
 
 TUPLE: html-span-stream < html-sub-stream ;
@@ -192,5 +195,5 @@ M: html-stream stream-write-table
 
 M: html-stream dispose stream>> dispose ;
 
-: with-html-stream ( quot -- )
+: with-html-writer ( quot -- )
     output-stream get <html-stream> swap with-output-stream* ; inline
diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor
index b0eb327927..c9ba8f66df 100644
--- a/basis/io/styles/styles.factor
+++ b/basis/io/styles/styles.factor
@@ -20,6 +20,8 @@ SYMBOL: presented
 SYMBOL: presented-path
 SYMBOL: presented-printer
 
+SYMBOL: href
+
 ! Paragraph styles
 SYMBOL: page-color
 SYMBOL: border-color