Merge git://factorcode.org/git/factor

core/compiler/compiler.factor

@@ -16,9 +16,10 @@ M: object inference-error-major? drop t ;
 
 : begin-batch ( seq -- )
     batch-mode on
-    [
+    "quiet" get [ drop ] [
-        "Compiling " % length # " words..." %
+        [ "Compiling " % length # " words..." % ] "" make
-    ] "" make print flush
+        print flush
+    ] if
     V{ } clone compile-errors set-global ;
 
 : compile-error. ( pair -- )

extra/furnace/furnace.factor

@@ -5,7 +5,7 @@ USING: kernel vectors io assocs quotations splitting strings
        continuations tuples classes io.files 
        http http.server.templating http.basic-authentication 
        webapps.callback html html.elements 
-       http.server.responders furnace.validator ;
+       http.server.responders furnace.validator vocabs ;
 IN: furnace
 
 SYMBOL: default-action
@@ -101,36 +101,14 @@ SYMBOL: request-params
 
 : service-post ( url -- ) "response" get swap service-request ;
 
-: explode-tuple ( tuple -- )
+: send-resource ( name -- )
-    dup tuple-slots swap class "slot-names" word-prop
+    template-path get swap path+ resource-path <file-reader>
-    [ set ] 2each ;
+    stdio get stream-copy ;
 
-SYMBOL: model
+: render-template ( template -- )
-
+    template-path get swap path+
-: call-template ( model template -- )
+    ".furnace" append resource-path
-    [
+    run-template-file ;
-        >r [ dup model set explode-tuple ] when* r>
-        ".furnace" append resource-path run-template-file
-    ] with-scope ;
-
-: render-template ( model template -- )
-    template-path get swap path+ call-template ;
-
-: render-page* ( model body-template head-template -- )
-    [
-        [ render-template ] [ f rot render-template ] html-document 
-    ] serve-html ;
-
-: render-titled-page* ( model body-template head-template title -- )
-    [ 
-        [ render-template ] swap [ <title> write </title> f rot render-template ] curry html-document
-    ] serve-html ;
-
-
-: render-page ( model template title -- )
-    [
-        [ render-template ] simple-html-document
-    ] serve-html ;
 
 : web-app ( name default path -- )
     [
@@ -141,3 +119,22 @@ SYMBOL: model
         [ service-post ] "post" set
         ! [ service-head ] "head" set
     ] make-responder ;
+
+: explode-tuple ( tuple -- )
+    dup tuple-slots swap class "slot-names" word-prop
+    [ set ] 2each ;
+
+SYMBOL: model
+
+: with-slots ( model quot -- )
+    [
+        >r [ dup model set explode-tuple ] when* r> call
+    ] with-scope ;
+
+: render-component ( model template -- )
+    swap [ render-template ] with-slots ;
+
+: browse-webapp-source ( vocab -- )
+    <a f >vocab-link browser-link-href =href a>
+        "Browse source" write
+    </a> ;

extra/http/http.factor

@@ -20,7 +20,7 @@ IN: http
     dup letter?
     over LETTER? or
     over digit? or
-    swap "/_?." member? or ; foldable
+    swap "/_-?." member? or ; foldable
 
 : url-encode ( str -- str )
     [

extra/io/windows/launcher/launcher.factor

@@ -87,9 +87,9 @@ TUPLE: CreateProcess-args
     pass-environment? [
         [
             get-environment
-            [ swap % "=" % % "\0" % ] assoc-each
+            [ "=" swap 3append string>u16-alien % ] assoc-each
             "\0" %
-        ] "" make >c-ushort-array
+        ] { } make >c-ushort-array
         over set-CreateProcess-args-lpEnvironment
     ] when ;
 

extra/rss/rss.factor

@@ -74,7 +74,7 @@ C: <entry> entry
 
 : download-feed ( url -- feed )
     #! Retrieve an news syndication file, return as a feed tuple.
-    http-get rot 200 = [
+    http-get-stream rot 200 = [
         nip read-feed
     ] [
         2drop "Error retrieving newsfeed file" throw
@@ -84,12 +84,15 @@ C: <entry> entry
 : simple-tag, ( content name -- )
     [ , ] tag, ;
 
+: simple-tag*, ( content name attrs -- )
+    [ , ] tag*, ;
+
 : entry, ( entry -- )
     "entry" [
-        dup entry-title "title" simple-tag,
+        dup entry-title "title" { { "type" "html" } } simple-tag*,
         "link" over entry-link "href" associate contained*,
         dup entry-pub-date "published" simple-tag,
-        entry-description "content" simple-tag,
+        entry-description "content" { { "type" "html" } } simple-tag*,
     ] tag, ;
 
 : feed>xml ( feed -- xml )

extra/webapps/article-manager/article-manager.factor

@@ -4,12 +4,17 @@
 USING: kernel furnace sqlite.tuple-db webapps.article-manager.database 
        sequences namespaces math arrays assocs quotations io.files
        http.server http.basic-authentication http.server.responders 
-       webapps.file ;
+       webapps.file html html.elements io ;
 IN: webapps.article-manager
 
 : current-site ( -- site )
   host get-site* ;
 
+: render-titled-page* ( model body-template head-template title -- )
+  [ 
+      [ render-component ] swap [ <title> write </title> f rot render-component ] curry html-document
+  ] serve-html ;
+
 TUPLE: template-args arg1 ;
   
 C: <template-args> template-args

extra/webapps/article-manager/furnace/article.furnace

@@ -1,12 +1,12 @@
 <% USING: kernel io http.server namespaces sequences math html.elements random furnace webapps.article-manager webapps.article-manager.database html.elements ; %>
     <div id="banner"><h1><% "arg1" get second article-title write %></h1></div>
-    <% f "navigation" render-template %>
+    <% "navigation" render-template %>
     <div id="article">
     <% 100 random 25 > [ "arg1" get first 100 random 50 > [ site-ad2 ] [ site-ad3 ] if write-html ] when %>
     <% "arg1" get second article-body write-html %>
 
 	<h1>Tags</h1>
-        <% "arg1" get second tags-for-article <template-args> "tags" render-template %>
+        <% "arg1" get second tags-for-article <template-args> "tags" render-component %>
 </div>
 <p class="footer"></p>
 <p id="copyright"><% "arg1" get first site-footer write %></p>

extra/webapps/article-manager/furnace/index.furnace

@@ -6,7 +6,7 @@
 </head>
     <body>
 	<div id="banner"><h1><% "title" get write %></h1></div>
-    <% f "navigation" render-template %>
+    <% "navigation" render-template %>
 <div id="article">
   <% "intro" get write-html %>
     <h1>Recent Articles</h1>
@@ -23,7 +23,7 @@
 	    but in the meantime, Google is likely to provide
 	    reasonable results.
 	</p>
-        <% host all-tags <template-args> "tags" render-template %>
+        <% host all-tags <template-args> "tags" render-component %>
 </div>
 <p class="footer"></p>
 <p id="copyright"><% "footer" get write %></p>

extra/webapps/article-manager/furnace/navigation.furnace

@@ -5,5 +5,5 @@
     </ul>
     <% current-site site-ad1 write-html %>
     <h1>Tags</h1>
-    <% host all-tags <template-args> "tags" render-template %>
+    <% host all-tags <template-args> "tags" render-component %>
     </div>

extra/webapps/article-manager/furnace/tag.furnace

@@ -1,7 +1,7 @@
 <% USING: kernel io http.server namespaces sequences math html furnace webapps.article-manager.database webapps.article-manager html.elements ; %>
 
 	<div id="banner"><h1><% "arg1" get second tag-title write %></h1></div>
-    <% f "navigation" render-template %>
+    <% "navigation" render-component %>
 	<div id="article">
 	<h1><% "arg1" get second tag-title write %></h1>
         <% "arg1" get second tag-description write-html %>

extra/webapps/file/file.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2006 Slava Pestov.
+! Copyright (C) 2004, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: calendar html io io.files kernel math math.parser
 http.server.responders http.server.templating namespaces parser
@@ -31,15 +31,23 @@ IN: webapps.file
     "304 Not Modified" response
     now timestamp>http-string "Date" associate print-header ;  
 
+! You can override how files are served in a custom responder
+SYMBOL: serve-file-hook
+
+[
+    file-response
+    stdio get stream-copy
+] serve-file-hook set-global
+
 : serve-static ( filename mime-type -- )
     over last-modified-matches? [
         2drop not-modified-response
     ] [
-        dupd file-response
         "method" get "head" = [
-            drop
+            file-response
         ] [
-            <file-reader> stdio get stream-copy
+            >r dup <file-reader> swap r>
+            serve-file-hook get call
         ] if 
     ] if ;
 
@@ -53,9 +61,13 @@ SYMBOL: page
 : include-page ( filename -- )
     "doc-root" get swap path+ run-page ;
 
+: serve-fhtml ( filename -- )
+    serving-html
+    "method" get "head" = [ drop ] [ run-page ] if ;
+
 : serve-file ( filename -- )
     dup mime-type dup "application/x-factor-server-page" =
-    [ drop serving-html run-page ] [ serve-static ] if ;
+    [ drop serve-fhtml ] [ serve-static ] if ;
 
 : file. ( name dirp -- )
     [ "/" append ] when

extra/webapps/fjsc/fjsc.factor

@@ -4,7 +4,7 @@
 USING: kernel furnace fjsc  parser-combinators namespaces
        lazy-lists io io.files furnace.validator sequences
        http.client http.server http.server.responders
-       webapps.file ;
+       webapps.file html ;
 IN: webapps.fjsc
 
 : compile ( code -- )
@@ -31,6 +31,11 @@ IN: webapps.fjsc
   { "url" v-required }
 } define-action
 
+: render-page* ( model body-template head-template -- )
+  [
+      [ render-component ] [ f rot render-component ] html-document 
+  ] serve-html ;
+
 : repl ( -- )
   #! The main 'repl' page.
   f "repl" "head" render-page* ;

extra/webapps/help/help.factor

@@ -82,4 +82,4 @@ PREDICATE: pathname resource-pathname
 M: resource-pathname browser-link-href
     pathname-string
     "resource:" ?head drop
-    "/responder/resources/" swap append ;
+    "/responder/source/" swap append ;

extra/webapps/pastebin/annotate-paste.furnace

@@ -1,4 +1,4 @@
-<% USING: io math math.parser namespaces ; %>
+<% USING: io math math.parser namespaces furnace ; %>
 
 <h1>Annotate</h1>
 
@@ -9,17 +9,22 @@
 <input type="hidden" name="n" value="<% "n" get number>string write %>" />
 
 <tr>
-<th>Your name:</th>
+<th align="right">Summary:</th>
-<td><input type="TEXT" name="author" value="" /></td>
-</tr>
-
-<tr>
-<th>Summary:</th>
 <td><input type="TEXT" name="summary" value="" /></td>
 </tr>
 
 <tr>
-<th valign="top">Contents:</th>
+<th align="right">Your name:</th>
+<td><input type="TEXT" name="author" value="" /></td>
+</tr>
+
+<tr>
+<th align="right">File type:</th>
+<td><% "modes" render-template %></td>
+</tr>
+
+<tr>
+<th align="right" valign="top">Content:</th>
 <td><textarea rows="24" cols="60" name="contents"></textarea></td>
 </tr>
 </table>

extra/webapps/pastebin/annotation.furnace

@@ -8,4 +8,4 @@
 <tr><th>Created:</th><td><% "date" get write %></td></tr>
 </table>
 
-<pre><% "contents" get write %></pre>
+<% "syntax" render-template %>

extra/webapps/pastebin/footer.furnace

@@ -0,0 +1,3 @@
+</body>
+
+</html>

extra/webapps/pastebin/header.furnace

@@ -0,0 +1,23 @@
+<% USING: namespaces io furnace sequences xmode.code2html webapps.pastebin ; %>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+	<meta http-equiv="Content-type" content="text/html; charset=utf-8" />
+
+	<title><% "title" get write %></title>
+	<link rel="stylesheet" href="style.css" type="text/css" media="screen" title="no title" charset="utf-8" />
+	<% default-stylesheet %>
+    <link rel="alternate" type="application/atom+xml" title="Pastebin - Atom" href="feed.xml" />
+</head>
+
+<body id="index">
+
+    <div class="navbar">
+        <% [ paste-list ] "Paste list" render-link %> |
+        <% [ new-paste ] "New paste" render-link %> |
+        <% [ feed.xml ] "Syndicate" render-link %>
+    </div>
+    <h1 class="pastebin-title"><% "title" get write %></h1>

extra/webapps/pastebin/modes.furnace

@@ -0,0 +1,7 @@
+<% USING: xmode.catalog sequences kernel html.elements assocs io sorting ; %>
+
+<select name="mode">
+    <% modes keys natural-sort [
+        <option dup "factor" = [ "true" =selected ] when option> write </option>
+    ] each %>
+</select>

extra/webapps/pastebin/new-paste.furnace

@@ -1,27 +1,41 @@
+<% USING: furnace namespaces ; %>
+
+<%
+    "new paste" "title" set
+    "header" render-template
+%>
+
 <form method="POST" action="/responder/pastebin/submit-paste">
 
 <table>
 
 <tr>
-<th>Your name:</th>
+<th align="right">Summary:</th>
-<td><input type="TEXT" name="author" value="" /></td>
-</tr>
-
-<tr>
-<th>Summary:</th>
 <td><input type="TEXT" name="summary" value="" /></td>
 </tr>
 
 <tr>
-<th>Channel:</th>
+<th align="right">Your name:</th>
+<td><input type="TEXT" name="author" value="" /></td>
+</tr>
+
+<tr>
+<th align="right">File type:</th>
+<td><% "modes" render-template %></td>
+</tr>
+
+<tr>
+<th align="right">Channel:</th>
 <td><input type="TEXT" name="channel" value="#concatenative" /></td>
 </tr>
 
 <tr>
-<th valign="top">Contents:</th>
+<th align="right" valign="top">Content:</th>
 <td><textarea rows="24" cols="60" name="contents"></textarea></td>
 </tr>
 </table>
 
 <input type="SUBMIT" value="Submit paste" />
 </form>
+
+<% "footer" render-template %>

extra/webapps/pastebin/paste-list.furnace

@@ -1,7 +1,31 @@
 <% USING: namespaces furnace sequences ; %>
 
-<table  width="100%">
+<%
-<% "new-paste-quot" get "New paste" render-link %>
+    "Pastebin" "title" set
-<tr align="left"><th>&nbsp;</th><th>Summary:</th><th>Paste by:</th><th>Link</th><th>Date</th></tr>
+    "header" render-template
-<% "pastes" get <reversed> [ "paste-summary" render-template ] each %></table>
+%>
 
+<table width="100%" cellspacing="10">
+    <tr>
+        <td valign="top">
+            <table width="100%">
+                <tr align="left" class="pastebin-headings">
+                    <th width="50%">Summary:</th>
+                    <th width="100">Paste by:</th>
+                    <th width="200">Date:</th>
+                </tr>
+                <% "pastes" get <reversed> [ "paste-summary" render-component ] each %>
+            </table>
+        </td>
+        <td valign="top" width="25%" class="infobox">
+            <p>This pastebin is written in <a href="http://factorcode.org/">Factor</a>. It is inspired by <a href="http://paste.lisp.org">lisppaste</a>.
+            </p>
+            <p>It can be used for collaborative development over IRC. You can post code for review, and annotate other people's code. Syntax highlighting for over a hundred file types is supported.
+            </p>
+            <p>
+            <% "webapps.pastebin" browse-webapp-source %></p>
+        </td>
+    </tr>
+</table>
+
+<% "footer" render-template %>

extra/webapps/pastebin/paste-summary.furnace

@@ -1,9 +1,11 @@
-<% USING: continuations namespaces io kernel math math.parser furnace ; %>
+<% USING: continuations namespaces io kernel math math.parser furnace webapps.pastebin ; %>
 
 <tr>
-<td><% "n" get number>string write %></td>
+    <td>
-<td><% "summary" get write %></td>
+        <a href="<% model get paste-link write %>">
-<td><% "author" get write %></td>
+            <% "summary" get write %>
-<td><% "n" get number>string "show-paste-quot" get curry "Show" render-link %></td>
+        </a>
-<td><% "date" get print %></td>
+    </td>
+    <td><% "author" get write %></td>
+    <td><% "date" get print %></td>
 </tr>

extra/webapps/pastebin/pastebin.factor

@@ -1,5 +1,6 @@
-USING: calendar furnace furnace.validator io.files kernel namespaces
+USING: calendar furnace furnace.validator io.files kernel
-sequences store ;
+namespaces sequences store http.server.responders html
+math.parser rss xml.writer ;
 IN: webapps.pastebin
 
 TUPLE: pastebin pastes ;
@@ -7,23 +8,17 @@ TUPLE: pastebin pastes ;
 : <pastebin> ( -- pastebin )
     V{ } clone pastebin construct-boa ;
 
-TUPLE: paste n summary article author channel contents date annotations ;
+TUPLE: paste
+summary author channel mode contents date
+annotations n ;
 
-: <paste> ( summary author channel contents -- paste )
+: <paste> ( summary author channel mode contents -- paste )
-    V{ } clone
+    f V{ } clone f paste construct-boa ;
-    {
-        set-paste-summary
-        set-paste-author
-        set-paste-channel
-        set-paste-contents
-        set-paste-annotations
-    } paste construct ;
 
-TUPLE: annotation summary author contents ;
+TUPLE: annotation summary author mode contents ;
 
 C: <annotation> annotation
 
-
 SYMBOL: store
 
 "pastebin.store" resource-path load-store store set-global
@@ -34,35 +29,56 @@ SYMBOL: store
     pastebin get pastebin-pastes nth ;
 
 : show-paste ( n -- )
-    get-paste "show-paste" "Paste" render-page ;
+    serving-html
+    get-paste
+    [ "show-paste" render-component ] with-html-stream ;
 
 \ show-paste { { "n" v-number } } define-action
 
 : new-paste ( -- )
-    f "new-paste" "New paste" render-page ;
+    serving-html
+    [ "new-paste" render-template ] with-html-stream ;
 
 \ new-paste { } define-action
 
 : paste-list ( -- )
+    serving-html
     [
         [ show-paste ] "show-paste-quot" set
         [ new-paste ] "new-paste-quot" set
-        pastebin get "paste-list" "Pastebin" render-page
+        pastebin get "paste-list" render-component
-    ] with-scope ;
+    ] with-html-stream ;
 
 \ paste-list { } define-action
 
+: paste-link ( paste -- link )
+    paste-n number>string [ show-paste ] curry quot-link ;
 
+: paste-feed ( -- entries )
+    pastebin get pastebin-pastes [
+        {
+            paste-summary
+            paste-link
+            paste-date
+        } get-slots "" swap <entry>
+    ] map ;
+
+: feed.xml ( -- )
+    "text/xml" serving-content
+    "pastebin"
+    "http://pastebin.factorcode.org"
+    paste-feed <feed> feed>xml write-xml ;
+
+\ feed.xml { } define-action
 
 : save-pastebin-store ( -- )
     store get-global save-store ;
 
 : add-paste ( paste pastebin -- )
     >r now timestamp>http-string over set-paste-date r>
-    pastebin-pastes
+    pastebin-pastes 2dup length swap set-paste-n push ;
-    [ length over set-paste-n ] keep push ;
 
-: submit-paste ( summary author channel contents -- )
+: submit-paste ( summary author channel mode contents -- )
     <paste>
     \ pastebin get-global add-paste
     save-pastebin-store ;
@@ -71,12 +87,13 @@ SYMBOL: store
     { "summary" v-required }
     { "author" v-required }
     { "channel" "#concatenative" v-default }
+    { "mode" "factor" v-default }
     { "contents" v-required }
 } define-action
 
 \ submit-paste [ paste-list ] define-redirect
 
-: annotate-paste ( n summary author contents -- )
+: annotate-paste ( n summary author mode contents -- )
     <annotation> swap get-paste
     paste-annotations push
     save-pastebin-store ;
@@ -85,9 +102,16 @@ SYMBOL: store
     { "n" v-required v-number }
     { "summary" v-required }
     { "author" v-required }
+    { "mode" "factor" v-default }
     { "contents" v-required }
 } define-action
 
 \ annotate-paste [ "n" show-paste ] define-redirect
 
+: style.css ( -- )
+    "text/css" serving-content
+    "style.css" send-resource ;
+
+\ style.css { } define-action
+
 "pastebin" "paste-list" "extra/webapps/pastebin" web-app

extra/webapps/pastebin/show-paste.furnace

@@ -1,15 +1,21 @@
-<% USING: namespaces io furnace sequences ; %>
+<% USING: namespaces io furnace sequences xmode.code2html ; %>
 
-<h1>Paste: <% "summary" get write %></h1>
+<%
+    "Paste: " "summary" get append "title" set
+    "header" render-template
+%>
 
 <table>
 <tr><th>Paste by:</th><td><% "author" get write %></td></tr>
 <tr><th>Channel:</th><td><% "channel" get write %></td></tr>
 <tr><th>Created:</th><td><% "date" get write %></td></tr>
+<tr><th>File type:</th><td><% "mode" get write %></td></tr>
 </table>
 
-<pre><% "contents" get write %></pre>
+<% "syntax" render-template %>
 
-<% "annotations" get [ "annotation" render-template ] each %>
+<% "annotations" get [ "annotation" render-component ] each %>
 
-<% model get "annotate-paste" render-template %>
+<% model get "annotate-paste" render-component %>
+
+<% "footer" render-template %>

extra/webapps/pastebin/style.css

@@ -0,0 +1,37 @@
+body {
+	font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+	color:#888;
+}
+
+h1.pastebin-title {
+	font-size:300%;
+}
+
+a {
+	color:#222;
+	border-bottom:1px dotted #ccc;
+	text-decoration:none;
+}
+
+a:hover {
+	border-bottom:1px solid #ccc;
+}
+
+pre.code {
+	border:1px dashed #ccc;
+	background-color:#f5f5f5;
+	padding:5px;
+	font-size:150%;
+	color:#000000;
+}
+
+.navbar {
+	background-color:#eeeeee;
+	padding:5px;
+	border:1px solid #ccc;
+}
+
+.infobox {
+	border: 1px solid #C1DAD7;
+	padding: 10px;
+}

extra/webapps/pastebin/syntax.furnace

@@ -0,0 +1,3 @@
+<% USING: xmode.code2html splitting namespaces ; %>
+
+<pre class="code"><% "contents" get string-lines "mode" get htmlize-lines %></pre>

extra/webapps/planet/planet.factor

@@ -1,41 +1,14 @@
 USING: sequences rss arrays concurrency kernel sorting
 html.elements io assocs namespaces math threads vocabs html
 furnace http.server.templating calendar math.parser splitting
-continuations debugger system http.server.responders ;
+continuations debugger system http.server.responders
+xml.writer ;
 IN: webapps.planet
 
-TUPLE: posting author title date link body ;
-
-: diagnostic write print flush ;
-
-: fetch-feed ( pair -- feed )
-    second
-    dup "Fetching " diagnostic
-    dup download-feed feed-entries
-    swap "Done fetching " diagnostic ;
-
-: fetch-blogroll ( blogroll -- entries )
-    #! entries is an array of { author entries } pairs.
-    dup [
-        [ fetch-feed ] [ error. drop f ] recover
-    ] parallel-map
-    [ [ >r first r> 2array ] curry* map ] 2map concat ;
-
-: sort-entries ( entries -- entries' )
-    [ [ second entry-pub-date ] compare ] sort <reversed> ;
-
-: <posting> ( pair -- posting )
-    #! pair has shape { author entry }
-    first2
-    { entry-title entry-pub-date entry-link entry-description }
-    get-slots posting construct-boa ;
-
 : print-posting-summary ( posting -- )
     <p "news" =class p>
-        <b> dup posting-title write </b> <br/>
+        <b> dup entry-title write </b> <br/>
-        "- " write
+        <a entry-link =href "more" =class a>
-        dup posting-author write bl
-        <a posting-link =href "more" =class a>
             "Read More..." write
         </a>
     </p> ;
@@ -63,58 +36,79 @@ TUPLE: posting author title date link body ;
 
 : print-posting ( posting -- )
     <h2 "posting-title" =class h2>
-        <a dup posting-link =href a>
+        <a dup entry-link =href a>
-            dup posting-title write-html
+            dup entry-title write-html
-            " - " write
-            dup posting-author write
         </a>
     </h2>
-    <p "posting-body" =class p> dup posting-body write-html </p>
+    <p "posting-body" =class p>
-    <p "posting-date" =class p> posting-date format-date write </p> ;
+        dup entry-description write-html
+    </p>
+    <p "posting-date" =class p>
+        entry-pub-date format-date write
+    </p> ;
 
 : print-postings ( postings -- )
     [ print-posting ] each ;
 
-: browse-webapp-source ( vocab -- )
-    <a f >vocab-link browser-link-href =href a>
-        "Browse source" write
-    </a> ;
-
 SYMBOL: default-blogroll
 SYMBOL: cached-postings
 
-: update-cached-postings ( -- )
-    default-blogroll get fetch-blogroll sort-entries
-    [ <posting> ] map
-    cached-postings set-global ;
-
 : mini-planet-factor ( -- )
     cached-postings get 4 head print-posting-summaries ;
 
 : planet-factor ( -- )
-    serving-html [
+    serving-html [ "planet" render-template ] with-html-stream ;
-        "resource:extra/webapps/planet/planet.fhtml"
-        run-template-file
-    ] with-html-stream ;
 
 \ planet-factor { } define-action
 
-{
+: planet-feed ( -- feed )
-    { "Berlin Brown" "http://factorlang-fornovices.blogspot.com/feeds/posts/default" "http://factorlang-fornovices.blogspot.com" }
+    "[ planet-factor ]"
-    { "Chris Double" "http://www.bluishcoder.co.nz/atom.xml" "http://www.bluishcoder.co.nz/" }
+    "http://planet.factorcode.org"
-    { "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
+    cached-postings get 30 head <feed> ;
-    { "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
+
-    { "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
+: feed.xml ( -- )
-    { "Kio M. Smallwood"
+    "text/xml" serving-content
-    "http://sekenre.wordpress.com/feed/atom/"
+    planet-feed feed>xml write-xml ;
-    "http://sekenre.wordpress.com/" }
+
-    { "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" }
+\ feed.xml { } define-action
-    { "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
+
-    { "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
+: style.css ( -- )
-} default-blogroll set-global
+    "text/css" serving-content
+    "style.css" send-resource ;
+
+\ style.css { } define-action
 
 SYMBOL: last-update
 
+: diagnostic write print flush ;
+
+: fetch-feed ( triple -- feed )
+    second
+    dup "Fetching " diagnostic
+    dup download-feed feed-entries
+    swap "Done fetching " diagnostic ;
+
+: <posting> ( author entry -- entry' )
+    clone
+    [ ": " swap entry-title 3append ] keep
+    [ set-entry-title ] keep ;
+
+: ?fetch-feed ( triple -- feed/f )
+    [ fetch-feed ] [ error. drop f ] recover ;
+
+: fetch-blogroll ( blogroll -- entries )
+    dup 0 <column>
+    swap [ ?fetch-feed ] parallel-map
+    [ [ <posting> ] curry* map ] 2map concat ;
+
+: sort-entries ( entries -- entries' )
+    [ [ entry-pub-date ] compare ] sort <reversed> ;
+
+: update-cached-postings ( -- )
+    default-blogroll get
+    fetch-blogroll sort-entries
+    cached-postings set-global ;
+
 : update-thread ( -- )
     millis last-update set-global
     [ update-cached-postings ] in-thread
@@ -126,14 +120,16 @@ SYMBOL: last-update
 
 "planet" "planet-factor" "extra/webapps/planet" web-app
 
-: merge-feeds ( feeds -- feed )
+{
-    [ feed-entries ] map concat sort-entries ;
+    { "Berlin Brown" "http://factorlang-fornovices.blogspot.com/feeds/posts/default" "http://factorlang-fornovices.blogspot.com" }
-
+    { "Chris Double" "http://www.blogger.com/feeds/18561009/posts/full/-/factor" "http://www.bluishcoder.co.nz/" }
-: planet-feed ( -- feed )
+    { "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
-    default-blogroll get [ second download-feed ] map merge-feeds 
+    { "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
-    >r "[ planet-factor ]" "http://planet.factorcode.org" r> <entry>
+    { "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
-    feed>xml ;
+    { "Kio M. Smallwood"
-
+    "http://sekenre.wordpress.com/feed/atom/"
-: feed.xml planet-feed ;
+    "http://sekenre.wordpress.com/" }
-
+    ! { "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" }
-\ feed.xml { } define-action
+    { "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
+    { "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
+} default-blogroll set-global

extra/webapps/planet/planet.furnace

@@ -1,4 +1,5 @@
-<% USING: namespaces html.elements webapps.planet sequences ; %>
+<% USING: namespaces html.elements webapps.planet sequences
+furnace ; %>
 
 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
 	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
@@ -8,7 +9,8 @@
 	<meta http-equiv="Content-type" content="text/html; charset=utf-8" />
 
 	<title>planet-factor</title>
-	<link rel="stylesheet" href="/responder/file/css/news.css" type="text/css" media="screen" title="no title" charset="utf-8" />
+	<link rel="stylesheet" href="style.css" type="text/css" media="screen" title="no title" charset="utf-8" />
+    <link rel="alternate" type="application/atom+xml" title="Planet Factor - Atom" href="feed.xml" />
 </head>
 
 <body id="index">
@@ -23,7 +25,11 @@
                     <a href="http://planet.lisp.org">Planet Lisp</a>.
                 </p>
                 <p>
-                    This webapp is written in <a href="http://factorcode.org/">Factor</a>.
+                    <img src="http://planet.lisp.org/feed-icon-14x14.png" />
+                    <a href="feed.xml"> Syndicate </a>
+                </p>
+                <p>
+                    This webapp is written in <a href="http://factorcode.org/">Factor</a>.<br/>
                     <% "webapps.planet" browse-webapp-source %>
                 </p>
                 <h2 class="blogroll-title">Blogroll</h2>

extra/webapps/planet/style.css

@@ -0,0 +1,45 @@
+body {
+	font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+	color:#888;
+}
+
+h1.planet-title {
+	font-size:300%;
+}
+
+a {
+	color:#222;
+	border-bottom:1px dotted #ccc;
+	text-decoration:none;
+}
+
+a:hover {
+	border-bottom:1px solid #ccc;
+}
+
+.posting-title {
+	background-color:#f5f5f5;
+}
+
+pre, code {
+	color:#000000;
+	font-size:120%;
+}
+
+.infobox {
+	border-left: 1px solid #C1DAD7;
+}
+
+.posting-date {
+	text-align: right;
+	font-size:90%;
+}
+
+a.more {
+	display:block;
+	padding:0 0 5px 0;
+	color:#333;
+	text-decoration:none;
+	text-align:right;
+	border:none;
+}

extra/webapps/source/source.factor

@@ -0,0 +1,20 @@
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.files namespaces webapps.file http.server.responders
+xmode.code2html kernel ;
+IN: webapps.source
+
+global [
+    ! Serve up our own source code
+    "source" [
+        [
+            "" resource-path "doc-root" set
+            [
+                drop
+                serving-html
+                swap htmlize-stream
+            ] serve-file-hook set
+            file-responder
+        ] with-scope
+    ] add-simple-responder
+] bind

extra/xmode/README.txt

@@ -32,10 +32,10 @@ to depend on:
   it inherits the value of the NO_WORD_SEP attribute from the previous
   RULES tag.
 
-  The Factor implementation does not duplicate this behavior.
+  The Factor implementation does not duplicate this behavior. If you
+  find a mode file which depends on this flaw, please fix it and submit
+  the changes to the jEdit project.
 
-This is still a work in progress. If you find any behavioral differences
+If you wish to contribute a new or improved mode file, please contact
-between the Factor implementation and the original jEdit code, please
+the jEdit project. Updated mode files in jEdit will be periodically
-report them as bugs. Also, if you wish to contribute a new or improved
+imported into the Factor source tree.
-mode file, please contact the jEdit project. Updated mode files in jEdit
-will be periodically imported into the Factor source tree.

extra/xmode/catalog/catalog-tests.factor

@@ -5,5 +5,7 @@ kernel sequences io ;
 [ t ] [ modes hashtable? ] unit-test
 
 [ ] [
-    modes keys [ dup print load-mode drop reset-modes ] each
+    modes keys [
+        dup print flush load-mode drop reset-modes
+    ] each
 ] unit-test

extra/xmode/catalog/catalog.factor

@@ -26,7 +26,7 @@ TAGS>
     "extra/xmode/modes/catalog" resource-path
     <file-reader> read-xml parse-modes-tag ;
 
-: modes ( -- )
+: modes ( -- assoc )
     \ modes get-global [
         load-catalog dup \ modes set-global
     ] unless* ;

extra/xmode/code2html/code2html.factor

@@ -15,8 +15,8 @@ IN: xmode.code2html
 : htmlize-line ( line-context line rules -- line-context' )
     tokenize-line htmlize-tokens ;
 
-: htmlize-lines ( lines rules -- )
+: htmlize-lines ( lines mode -- )
-    <pre> f -rot [ htmlize-line nl ] curry each drop </pre> ;
+    f swap load-mode [ htmlize-line nl ] curry reduce drop ;
 
 : default-stylesheet ( -- )
     <style>
@@ -24,22 +24,22 @@ IN: xmode.code2html
         resource-path <file-reader> contents write
     </style> ;
 
-: htmlize-file ( path -- )
+: htmlize-stream ( path stream -- )
-    dup <file-reader> lines dup empty? [ 2drop ] [
+    lines swap
-        swap dup ".html" append <file-writer> [
-            [
     <html>
         <head>
-                        <title> dup write </title>
             default-stylesheet
+            <title> dup write </title>
         </head>
         <body>
-                        over first
+            <pre>
-                        find-mode
+                over empty?
-                        load-mode
+                [ 2drop ]
-                        htmlize-lines
+                [ over first find-mode htmlize-lines ] if
+            </pre>
         </body>
-                </html>
+    </html> ;
-            ] with-html-stream
+
-        ] with-stream
+: htmlize-file ( path -- )
-    ] if ;
+    dup <file-reader> over ".html" append <file-writer>
+    [ htmlize-stream ] with-stream ;

extra/xmode/loader/loader.factor

@@ -32,10 +32,13 @@ IN: xmode.loader
     swap [ at string>boolean ] curry map first3 ;
 
 : parse-literal-matcher ( tag -- matcher )
-    dup children>string swap position-attrs <matcher> ;
+    dup children>string
+    \ ignore-case? get [ <ignore-case> ] when
+    swap position-attrs <matcher> ;
 
 : parse-regexp-matcher ( tag -- matcher )
-    dup children>string <regexp> swap position-attrs <matcher> ;
+    dup children>string <regexp>
+    swap position-attrs <matcher> ;
 
 ! SPAN's children
 <TAGS: parse-begin/end-tag
@@ -130,22 +133,25 @@ RULE: MARK_FOLLOWING mark-following-rule
 RULE: MARK_PREVIOUS mark-previous-rule
     shared-tag-attrs match-type-attr literal-start ;
 
-: parse-keyword-tag
+: parse-keyword-tag ( tag keyword-map -- )
-    dup name-tag string>token swap children>string rot set-at ;
+    >r dup name-tag string>token swap children>string r> set-at ;
 
 TAG: KEYWORDS ( rule-set tag -- key value )
-    >r rule-set-keywords r>
+    \ ignore-case? get <keyword-map>
-    child-tags [ parse-keyword-tag ] curry* each ;
+    swap child-tags [ over parse-keyword-tag ] each
+    swap set-rule-set-keywords ;
 
 TAGS>
 
+: ?<regexp> dup [ <regexp> ] when ;
+
 : (parse-rules-tag) ( tag -- rule-set )
     <rule-set>
     {
         { "SET" string>rule-set-name set-rule-set-name }
         { "IGNORE_CASE" string>boolean set-rule-set-ignore-case? }
         { "HIGHLIGHT_DIGITS" string>boolean set-rule-set-highlight-digits? }
-        { "DIGIT_RE" <regexp> set-rule-set-digit-re } ! XXX
+        { "DIGIT_RE" ?<regexp> set-rule-set-digit-re }
         { "ESCAPE" f add-escape-rule }
         { "DEFAULT" string>token set-rule-set-default }
         { "NO_WORD_SEP" f set-rule-set-no-word-sep }
@@ -153,9 +159,10 @@ TAGS>
 
 : parse-rules-tag ( tag -- rule-set )
     dup (parse-rules-tag) [
-        swap child-tags [
+        [
-            parse-rule-tag
+            dup rule-set-ignore-case? \ ignore-case? set
-        ] curry* each
+            swap child-tags [ parse-rule-tag ] curry* each
+        ] with-scope
     ] keep ;
 
 : merge-rule-set-props ( props rule-set -- )

extra/xmode/marker/marker-tests.factor

@@ -109,3 +109,21 @@ IN: temporary
 ] [
     f "$FOO" "shellscript" load-mode tokenize-line nip
 ] unit-test
+
+[
+    {
+        T{ token f "AND" KEYWORD1 }
+    }
+] [
+    f "AND" "pascal" load-mode tokenize-line nip
+] unit-test
+
+[
+    {
+        T{ token f "Comment {" COMMENT1 }
+        T{ token f "XXX" COMMENT1 }
+        T{ token f "}" COMMENT1 }
+    }
+] [
+    f "Comment {XXX}" "rebol" load-mode tokenize-line nip
+] unit-test

extra/xmode/marker/marker.factor

@@ -15,8 +15,8 @@ assocs combinators combinators.lib strings regexp splitting ;
         [ dup [ digit? ] contains? ]
         [
             dup [ digit? ] all? [
-                current-rule-set rule-set-digit-re dup
+                current-rule-set rule-set-digit-re
-                [ dupd 2drop f ] [ drop f ] if
+                dup [ dupd matches? ] [ drop f ] if
             ] unless*
         ]
     } && nip ;
@@ -26,7 +26,7 @@ assocs combinators combinators.lib strings regexp splitting ;
 
 : resolve-delegate ( name -- rules )
     dup string? [
-        "::" split1 [ swap load-mode at ] [ rule-sets get at ] if*
+        "::" split1 [ swap load-mode ] [ rule-sets get ] if* at
     ] when ;
 
 : rule-set-keyword-maps ( ruleset -- seq )
@@ -45,13 +45,6 @@ assocs combinators combinators.lib strings regexp splitting ;
     dup mark-number [ ] [ mark-keyword ] ?if
     [ prev-token, ] when* ;
 
-: check-terminate-char ( -- )
-    current-rule-set rule-set-terminate-char [
-        position get <= [
-            terminated? on
-        ] when
-    ] when* ;
-
 : current-char ( -- char )
     position get line get nth ;
 
@@ -74,11 +67,22 @@ GENERIC: text-matches? ( position text -- match-count/f )
 M: f text-matches? 2drop f ;
 
 M: string text-matches?
-    ! XXX ignore case
     >r line get swap tail-slice r>
     [ head? ] keep length and ;
 
-! M: regexp text-matches? ... ;
+M: ignore-case text-matches?
+    >r line get swap tail-slice r>
+    ignore-case-string
+    2dup shorter? [
+        2drop f
+    ] [
+        [ length head-slice ] keep
+        [ [ >upper ] 2apply sequence= ] keep
+        length and
+    ] if ;
+
+M: regexp text-matches?
+    2drop f ; ! >r line get swap tail-slice r> match-head ;
 
 : rule-start-matches? ( rule -- match-count/f )
     dup rule-start tuck swap can-match-here? [
@@ -284,8 +288,6 @@ M: mark-previous-rule handle-rule-start
 
 : mark-token-loop ( -- )
     position get line get length < [
-        check-terminate-char
-
         {
             [ check-end-delegate ]
             [ check-every-rule ]
@@ -302,8 +304,7 @@ M: mark-previous-rule handle-rule-start
 
 : unwind-no-line-break ( -- )
     context get line-context-parent [
-        line-context-in-rule rule-no-line-break?
+        line-context-in-rule rule-no-line-break? [
-        terminated? get or [
             pop-context
             unwind-no-line-break
         ] when

extra/xmode/marker/state/state.factor

@@ -16,7 +16,6 @@ SYMBOL: seen-whitespace-end?
 SYMBOL: escaped?
 SYMBOL: process-escape?
 SYMBOL: delegate-end-escaped?
-SYMBOL: terminated?
 
 : current-rule ( -- rule )
     context get line-context-in-rule ;

extra/xmode/rules/rules.factor

@@ -1,7 +1,11 @@
 USING: xmode.tokens xmode.keyword-map kernel
-sequences vectors assocs strings memoize ;
+sequences vectors assocs strings memoize regexp ;
 IN: xmode.rules
 
+TUPLE: ignore-case string ;
+
+C: <ignore-case> ignore-case
+
 ! Based on org.gjt.sp.jedit.syntax.ParserRuleSet
 TUPLE: rule-set
 name
@@ -20,12 +24,11 @@ no-word-sep
 
 : init-rule-set ( ruleset -- )
     #! Call after constructor.
-    >r H{ } clone H{ } clone V{ } clone f <keyword-map> r>
+    >r H{ } clone H{ } clone V{ } clone r>
     {
         set-rule-set-rules
         set-rule-set-props
         set-rule-set-imports
-        set-rule-set-keywords
     } set-slots ;
 
 : <rule-set> ( -- ruleset )
@@ -46,8 +49,9 @@ MEMO: standard-rule-set ( id -- ruleset )
     ] when* ;
 
 : rule-set-no-word-sep* ( ruleset -- str )
-    dup rule-set-keywords keyword-map-no-word-sep*
+    dup rule-set-no-word-sep
-    swap rule-set-no-word-sep "_" 3append ;
+    swap rule-set-keywords dup [ keyword-map-no-word-sep* ] when
+    "_" 3append ;
 
 ! Match restrictions
 TUPLE: matcher text at-line-start? at-whitespace-end? at-word-start? ;
@@ -97,10 +101,20 @@ TUPLE: escape-rule ;
     escape-rule construct-rule
     [ set-rule-start ] keep ;
 
+GENERIC: text-hash-char ( text -- ch )
+
+M: f text-hash-char ;
+
+M: string text-hash-char first ;
+
+M: ignore-case text-hash-char ignore-case-string first ;
+
+M: regexp text-hash-char drop f ;
+
 : rule-chars* ( rule -- string )
     dup rule-chars
     swap rule-start matcher-text
-    dup string? [ first add ] [ drop ] if ;
+    text-hash-char [ add ] when* ;
 
 : add-rule ( rule ruleset -- )
     >r dup rule-chars* >upper swap

unmaintained/scaffold/scaffold.factor

@@ -2,7 +2,7 @@ USING: http.server help.markup help.syntax kernel prettyprint
 sequences parser namespaces words classes math tuples.private
 quotations arrays strings ;
 
-IN: furnace
+IN: furnace.scaffold
 
 TUPLE: furnace-model model ;
 C: <furnace-model> furnace-model
@@ -40,6 +40,11 @@ HELP: crud-lookup*
 { $values { "string" string } { "class" class } { "tuple" tuple } }
 "A CRUD utility function - same as crud-lookup, but always returns a tuple of the given class.  When the lookup fails, returns a tuple of the given class with all slots set to f." ;
 
+: render-page ( model template title -- )
+    [
+        [ render-component ] simple-html-document
+    ] serve-html ;
+
 : crud-page ( model template title -- )
     [ "libs/furnace/crud-templates" template-path set render-page ]
     with-scope ;