Merge git://factorcode.org/git/factor
U-C4\Administrator
commit
a039910d01
|
|
@ -35,8 +35,11 @@ TUPLE: html-sub-stream style stream ;
|
|||
stdio get delegate stream-write ;
|
||||
|
||||
: object-link-tag ( style quot -- )
|
||||
presented pick at browser-link-href
|
||||
[ <a =href a> call </a> ] [ call ] if* ; inline
|
||||
presented pick at [
|
||||
browser-link-href [
|
||||
<a =href a> call </a>
|
||||
] [ call ] if*
|
||||
] [ call ] if* ; inline
|
||||
|
||||
: hex-color, ( triplet -- )
|
||||
3 head-slice
|
||||
|
|
|
|||
|
|
@ -83,7 +83,7 @@ HELP: filter
|
|||
{ $examples
|
||||
"The following code displays a label showing the result of applying " { $link sq } " to the value 5:"
|
||||
{ $code
|
||||
"USING: models gadgets-labels gadgets-panes ;"
|
||||
"USING: models ui.gadgets.labels ui.gadgets.panes ;"
|
||||
"5 <model> [ sq ] <filter> [ number>string ] <filter>"
|
||||
"<label-control> gadget."
|
||||
}
|
||||
|
|
@ -142,7 +142,7 @@ HELP: delay
|
|||
{ $examples
|
||||
"The following code displays a sliders and a label which is updated half a second after the slider stops changing:"
|
||||
{ $code
|
||||
"USING: models gadgets-labels gadgets-sliders gadgets-panes ;"
|
||||
"USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes ;"
|
||||
": <funny-slider>"
|
||||
" 0 0 0 100 <range> <x-slider> 500 over set-slider-max ;"
|
||||
"<funny-slider> dup gadget."
|
||||
|
|
|
|||
|
|
@ -137,7 +137,7 @@ M: interactor stream-read-partial
|
|||
[ restore-vars parse ] keep save-vars
|
||||
] [
|
||||
>r f swap set-interactor-busy? drop r>
|
||||
dup [ unexpected-eof? ] is? [ drop f ] when
|
||||
dup delegate unexpected-eof? [ drop f ] when
|
||||
] recover
|
||||
] with-scope ;
|
||||
|
||||
|
|
|
|||
|
|
@ -20,8 +20,8 @@ IN: webapps.help
|
|||
} define-action
|
||||
|
||||
M: link browser-link-href
|
||||
link-name
|
||||
dup word? [
|
||||
link-name
|
||||
dup word? over f eq? or [
|
||||
browser-link-href
|
||||
] [
|
||||
dup array? [ " " join ] when
|
||||
|
|
@ -32,10 +32,13 @@ M: link browser-link-href
|
|||
lookup show-help ;
|
||||
|
||||
\ show-word {
|
||||
{ "vocab" "kernel" v-default }
|
||||
{ "word" "call" v-default }
|
||||
{ "vocab" "kernel" v-default }
|
||||
} define-action
|
||||
|
||||
M: f browser-link-href
|
||||
drop \ f browser-link-href ;
|
||||
|
||||
M: word browser-link-href
|
||||
dup word-name swap word-vocabulary
|
||||
[ show-word ] 2curry quot-link ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,118 @@
|
|||
USING: sequences rss arrays concurrency kernel sorting
|
||||
html.elements io assocs namespaces math threads vocabs html
|
||||
furnace http.server.templating calendar math.parser splitting ;
|
||||
IN: webapps.planet
|
||||
|
||||
TUPLE: posting author title date link body ;
|
||||
|
||||
: diagnostic write print flush ;
|
||||
|
||||
: fetch-feed ( pair -- feed )
|
||||
second
|
||||
dup "Fetching " diagnostic
|
||||
dup news-get 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 [ ] subset
|
||||
[ [ >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/>
|
||||
"- " write
|
||||
dup posting-author write bl
|
||||
<a posting-link =href "more" =class a>
|
||||
"Read More..." write
|
||||
</a>
|
||||
</p> ;
|
||||
|
||||
: print-posting-summaries ( postings -- )
|
||||
[ print-posting-summary ] each ;
|
||||
|
||||
: print-blogroll ( blogroll -- )
|
||||
<ul "description" =class ul>
|
||||
[
|
||||
<li> <a dup third =href a> first write </a> </li>
|
||||
] each
|
||||
</ul> ;
|
||||
|
||||
: format-date ( date -- string )
|
||||
10 head "-" split [ string>number ] map
|
||||
first3 0 0 0 0 <timestamp>
|
||||
[
|
||||
dup timestamp-day #
|
||||
" " %
|
||||
dup timestamp-month month-abbreviations nth %
|
||||
", " %
|
||||
timestamp-year #
|
||||
] "" make ;
|
||||
|
||||
: print-posting ( posting -- )
|
||||
<h2 "posting-title" =class h2>
|
||||
<a dup posting-link =href a>
|
||||
dup posting-title write
|
||||
" - " write
|
||||
dup posting-author write
|
||||
</a>
|
||||
</h2>
|
||||
<p "posting-body" =class p> dup posting-body write-html </p>
|
||||
<p "posting-date" =class p> posting-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 ( -- )
|
||||
[
|
||||
"resource:extra/webapps/planet/planet.fhtml"
|
||||
run-template-file
|
||||
] with-html-stream ;
|
||||
|
||||
\ planet-factor { } define-action
|
||||
|
||||
{
|
||||
{ "Chris Double" "http://www.bluishcoder.co.nz/atom.xml" "http://www.bluishcoder.co.nz/" }
|
||||
{ "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
|
||||
{ "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/" }
|
||||
{ "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
|
||||
|
||||
: update-thread ( -- )
|
||||
[ update-cached-postings ] try
|
||||
10 60 * 1000 * sleep
|
||||
update-thread ;
|
||||
|
||||
: start-update-thread ( -- )
|
||||
[ update-thread ] in-thread ;
|
||||
|
||||
"planet" "planet-factor" "extra/webapps/planet" web-app
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
<% USING: namespaces html.elements webapps.planet sequences ; %>
|
||||
|
||||
<!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>planet-factor</title>
|
||||
<link rel="stylesheet" href="/responder/file/css/news.css" type="text/css" media="screen" title="no title" charset="utf-8" />
|
||||
</head>
|
||||
|
||||
<body id="index">
|
||||
<h1 class="planet-title">[ planet-factor ]</h1>
|
||||
<table width="100%" cellpadding="10">
|
||||
<tr>
|
||||
<td> <% cached-postings get 20 head print-postings %> </td>
|
||||
<td valign="top" width="25%" class="infobox">
|
||||
<p>
|
||||
<b>planet-factor</b> is an Atom/RSS aggregator that collects the
|
||||
contents of <a href="http://factorcode.org/">Factor</a>-related blogs. It is inspired by
|
||||
<a href="http://planet.lisp.org">Planet Lisp</a>.
|
||||
</p>
|
||||
<p>
|
||||
This webapp is written in <a href="http://factorcode.org/">Factor</a>.
|
||||
<% "webapps.planet" browse-webapp-source %>
|
||||
</p>
|
||||
<h2 class="blogroll-title">Blogroll</h2>
|
||||
<% default-blogroll get print-blogroll %>
|
||||
<p>
|
||||
If you want your weblog added to the blogroll, <a href="http://factorcode.org/gethelp.fhtml">just ask</a>.
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
</table>
|
||||
</body>
|
||||
|
||||
</html>
|
||||
|
|
@ -42,3 +42,4 @@ SYMBOL: xml-file
|
|||
] unit-test
|
||||
[ "foo" ] [ "<x y='foo'/>" string>xml "y" <name-tag> over
|
||||
at swap "z" <name-tag> >r tuck r> swap set-at T{ name f "blah" "z" f } swap at ] unit-test
|
||||
[ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test
|
||||
|
|
|
|||
|
|
@ -137,7 +137,7 @@ SYMBOL: ns-stack
|
|||
CHAR: > expect ;
|
||||
|
||||
: take-cdata ( -- string )
|
||||
"[CDATA[" expect-string "]]>" take-string next ;
|
||||
"[CDATA[" expect-string "]]>" take-string ;
|
||||
|
||||
: take-directive ( -- directive )
|
||||
CHAR: > take-char <directive> next ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue