From bd424038350276b4c5d7e82305624716da06d4a8 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 12 Oct 2007 15:28:23 -0500 Subject: [PATCH 1/4] Fixed CDATA parsing bug --- extra/xml/test/test.factor | 1 + extra/xml/tokenize/tokenize.factor | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/xml/test/test.factor b/extra/xml/test/test.factor index d9c7ca7e9d..a2fd2813ed 100644 --- a/extra/xml/test/test.factor +++ b/extra/xml/test/test.factor @@ -42,3 +42,4 @@ SYMBOL: xml-file ] unit-test [ "foo" ] [ "" string>xml "y" over at swap "z" >r tuck r> swap set-at T{ name f "blah" "z" f } swap at ] unit-test +[ "foo" ] [ "" string>xml children>string ] unit-test diff --git a/extra/xml/tokenize/tokenize.factor b/extra/xml/tokenize/tokenize.factor index d89ae57de9..5e3bf1edfa 100644 --- a/extra/xml/tokenize/tokenize.factor +++ b/extra/xml/tokenize/tokenize.factor @@ -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 next ; From 18259cdaa4ec36eeb94b564c596c14c6d0ff154e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 15 Oct 2007 06:23:00 -0400 Subject: [PATCH 2/4] Fix interactor problem when loading a vocab which has a parse error --- extra/ui/tools/interactor/interactor.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index d0791ac5ab..ca70895b09 100644 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -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 ; From 35bd6202ef21ec5f4b9276413eb604126600053c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 15 Oct 2007 16:44:40 -0400 Subject: [PATCH 3/4] Fix webapps/help bug --- extra/html/html.factor | 7 +- extra/webapps/help/help.factor | 9 ++- extra/webapps/planet/planet.factor | 118 +++++++++++++++++++++++++++++ extra/webapps/planet/planet.fhtml | 39 ++++++++++ 4 files changed, 168 insertions(+), 5 deletions(-) create mode 100644 extra/webapps/planet/planet.factor create mode 100644 extra/webapps/planet/planet.fhtml diff --git a/extra/html/html.factor b/extra/html/html.factor index 9db97957a5..137cc473d3 100644 --- a/extra/html/html.factor +++ b/extra/html/html.factor @@ -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 - [ call ] [ call ] if* ; inline + presented pick at [ + browser-link-href [ + call + ] [ call ] if* + ] [ call ] if* ; inline : hex-color, ( triplet -- ) 3 head-slice diff --git a/extra/webapps/help/help.factor b/extra/webapps/help/help.factor index 366baffcb9..8456e499f1 100644 --- a/extra/webapps/help/help.factor +++ b/extra/webapps/help/help.factor @@ -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 ; diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor new file mode 100644 index 0000000000..bdbb1ccd29 --- /dev/null +++ b/extra/webapps/planet/planet.factor @@ -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 ; + +: ( 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 -- ) +

+ dup posting-title write
+ "- " write + dup posting-author write bl + + "Read More..." write + +

; + +: print-posting-summaries ( postings -- ) + [ print-posting-summary ] each ; + +: print-blogroll ( blogroll -- ) + ; + +: format-date ( date -- string ) + 10 head "-" split [ string>number ] map + first3 0 0 0 0 + [ + dup timestamp-day # + " " % + dup timestamp-month month-abbreviations nth % + ", " % + timestamp-year # + ] "" make ; + +: print-posting ( posting -- ) +

+ + dup posting-title write + " - " write + dup posting-author write + +

+

dup posting-body write-html

+

posting-date format-date write

; + +: print-postings ( postings -- ) + [ print-posting ] each ; + +: browse-webapp-source ( vocab -- ) + vocab-link browser-link-href =href a> + "Browse source" write + ; + +SYMBOL: default-blogroll +SYMBOL: cached-postings + +: update-cached-postings ( -- ) + default-blogroll get fetch-blogroll sort-entries + [ ] 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 diff --git a/extra/webapps/planet/planet.fhtml b/extra/webapps/planet/planet.fhtml new file mode 100644 index 0000000000..fb5a673077 --- /dev/null +++ b/extra/webapps/planet/planet.fhtml @@ -0,0 +1,39 @@ +<% USING: namespaces html.elements webapps.planet sequences ; %> + + + + + + + + planet-factor + + + + +

[ planet-factor ]

+ + + + + +
<% cached-postings get 20 head print-postings %> +

+ planet-factor is an Atom/RSS aggregator that collects the + contents of Factor-related blogs. It is inspired by + Planet Lisp. +

+

+ This webapp is written in Factor. + <% "webapps.planet" browse-webapp-source %> +

+

Blogroll

+ <% default-blogroll get print-blogroll %> +

+ If you want your weblog added to the blogroll, just ask. +

+
+ + + From 1306649c59cdbbe9666ed332680174cab88db6ef Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 15 Oct 2007 16:46:39 -0400 Subject: [PATCH 4/4] Fix from Sam --- extra/models/models-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/models/models-docs.factor b/extra/models/models-docs.factor index aaa7ee32ee..2b58381fe0 100644 --- a/extra/models/models-docs.factor +++ b/extra/models/models-docs.factor @@ -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 [ sq ] [ number>string ] " " 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 ;" ": " " 0 0 0 100 500 over set-slider-max ;" " dup gadget."