New XML generation sytnax and word in sequences.lib
parent
c4666c8c2d
commit
0c3e6501fe
|
@ -42,7 +42,7 @@ M: tuple-class group-words
|
||||||
|
|
||||||
PROTOCOL: sequence-protocol
|
PROTOCOL: sequence-protocol
|
||||||
clone clone-like like new new-resizable nth nth-unsafe
|
clone clone-like like new new-resizable nth nth-unsafe
|
||||||
set-nth set-nth-unsafe length immutable set-length lengthen ;
|
set-nth set-nth-unsafe length set-length lengthen ;
|
||||||
|
|
||||||
PROTOCOL: assoc-protocol
|
PROTOCOL: assoc-protocol
|
||||||
at* assoc-size >alist assoc-find set-at
|
at* assoc-size >alist assoc-find set-at
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
|
! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
IN: rss
|
IN: rss
|
||||||
USING: xml.utilities kernel assocs
|
USING: xml.utilities kernel assocs xml.generator
|
||||||
strings sequences xml.data xml.writer
|
strings sequences xml.data xml.writer
|
||||||
io.streams.string combinators xml xml.entities io.files io
|
io.streams.string combinators xml xml.entities io.files io
|
||||||
http.client namespaces xml.generator hashtables ;
|
http.client namespaces xml.generator hashtables ;
|
||||||
|
@ -74,30 +74,29 @@ C: <entry> entry
|
||||||
|
|
||||||
: download-feed ( url -- feed )
|
: download-feed ( url -- feed )
|
||||||
#! Retrieve an news syndication file, return as a feed tuple.
|
#! Retrieve an news syndication file, return as a feed tuple.
|
||||||
http-get rot 200 = [
|
http-get-stream rot 200 = [
|
||||||
nip read-feed
|
nip read-feed
|
||||||
] [
|
] [
|
||||||
2drop "Error retrieving newsfeed file" throw
|
2drop "Error retrieving newsfeed file" throw
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
! Atom generation
|
! Atom generation
|
||||||
: simple-tag, ( content name -- )
|
|
||||||
[ , ] tag, ;
|
|
||||||
|
|
||||||
: entry, ( entry -- )
|
: entry, ( entry -- )
|
||||||
"entry" [
|
<< entry >> [
|
||||||
dup entry-title "title" simple-tag,
|
<< title >> [ dup entry-title , ]
|
||||||
"link" over entry-link "href" associate contained*,
|
<< link [ dup entry-link ] == href // >>
|
||||||
dup entry-pub-date "published" simple-tag,
|
<< published >> [ dup entry-pub-date , ]
|
||||||
entry-description "content" simple-tag,
|
<< content >> [ entry-description , ]
|
||||||
] tag, ;
|
] ;
|
||||||
|
|
||||||
: feed>xml ( feed -- xml )
|
: feed>xml ( feed -- xml )
|
||||||
"feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
|
<XML
|
||||||
dup feed-title "title" simple-tag,
|
<< feed [ "http://www.w3.org/2005/Atom" ] == xmlns >> [
|
||||||
"link" over feed-link "href" associate contained*,
|
<< title >> [ dup feed-title , ]
|
||||||
feed-entries [ entry, ] each
|
<< link [ dup feed-link ] == href // >>
|
||||||
] make-xml* ;
|
feed-entries [ entry, ] each
|
||||||
|
]
|
||||||
|
XML> ;
|
||||||
|
|
||||||
: write-feed ( feed -- xml )
|
: write-feed ( feed -- xml )
|
||||||
feed>xml write-xml ;
|
feed>xml write-xml ;
|
||||||
|
|
|
@ -62,3 +62,7 @@ IN: sequences.lib
|
||||||
|
|
||||||
: delete-random ( seq -- value )
|
: delete-random ( seq -- value )
|
||||||
[ length random ] keep [ nth ] 2keep delete-nth ;
|
[ length random ] keep [ nth ] 2keep delete-nth ;
|
||||||
|
|
||||||
|
: split-around ( seq quot -- before elem after )
|
||||||
|
dupd find over [ "Element not found" throw ] unless
|
||||||
|
>r cut-slice 1 tail r> swap ; inline
|
||||||
|
|
|
@ -1,4 +1,7 @@
|
||||||
USING: namespaces kernel xml.data xml.utilities ;
|
! Copyright (C) 2006, 2007 Daniel Ehrenberg
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: namespaces kernel xml.data xml.utilities assocs splitting
|
||||||
|
sequences parser quotations sequences.lib ;
|
||||||
IN: xml.generator
|
IN: xml.generator
|
||||||
|
|
||||||
: comment, ( string -- ) <comment> , ;
|
: comment, ( string -- ) <comment> , ;
|
||||||
|
@ -21,3 +24,59 @@ IN: xml.generator
|
||||||
(tag,) build-xml ; inline
|
(tag,) build-xml ; inline
|
||||||
: make-xml ( name quot -- xml )
|
: make-xml ( name quot -- xml )
|
||||||
f swap make-xml* ; inline
|
f swap make-xml* ; inline
|
||||||
|
|
||||||
|
SYMBOL: namespace-table
|
||||||
|
: with-namespaces ( table quot -- )
|
||||||
|
>r H{ } assoc-like namespace-table r> with-variable ; inline
|
||||||
|
|
||||||
|
: parsed-name ( accum -- accum )
|
||||||
|
scan ":" split1 [ f <name> ] [ <name-tag> ] if* parsed ;
|
||||||
|
|
||||||
|
: run-combinator ( accum quot1 quot2 -- accum )
|
||||||
|
>r [ ] like parsed r> [ parsed ] each ;
|
||||||
|
|
||||||
|
: parse-tag-contents ( accum contained? -- accum )
|
||||||
|
[ \ contained*, parsed ] [
|
||||||
|
scan-word \ [ =
|
||||||
|
[ POSTPONE: [ \ tag*, parsed ]
|
||||||
|
[ "Expected [ missing" <parse-error> throw ] if
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
DEFER: >>
|
||||||
|
|
||||||
|
: attributes-parsed ( accum quot -- accum )
|
||||||
|
dup empty? [ drop f parsed ] [
|
||||||
|
>r \ >r parsed r> parsed
|
||||||
|
[ H{ } make-assoc r> swap ] [ parsed ] each
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: <<
|
||||||
|
parsed-name [
|
||||||
|
\ >> parse-until >quotation
|
||||||
|
attributes-parsed \ contained? get
|
||||||
|
] with-scope parse-tag-contents ; parsing
|
||||||
|
|
||||||
|
: ==
|
||||||
|
\ call parsed parsed-name \ set parsed ; parsing
|
||||||
|
|
||||||
|
: //
|
||||||
|
\ contained? on ; parsing
|
||||||
|
|
||||||
|
: parse-special ( accum end-token word -- accum )
|
||||||
|
>r parse-tokens " " join parsed r> parsed ;
|
||||||
|
|
||||||
|
: <!-- "-->" \ comment, parse-special ; parsing
|
||||||
|
|
||||||
|
: <! ">" \ directive, parse-special ; parsing
|
||||||
|
|
||||||
|
: <? "?>" \ instruction, parse-special ; parsing
|
||||||
|
|
||||||
|
: >xml-document ( seq -- xml )
|
||||||
|
dup first prolog? [ unclip-slice ] [ standard-prolog ] if swap
|
||||||
|
[ tag? ] split-around <xml> ;
|
||||||
|
|
||||||
|
DEFER: XML>
|
||||||
|
|
||||||
|
: <XML
|
||||||
|
\ XML> [ >quotation ] parse-literal
|
||||||
|
{ } parsed \ make parsed \ >xml-document parsed ; parsing
|
||||||
|
|
|
@ -42,8 +42,11 @@ M: process-missing error.
|
||||||
: build-tag ( item name -- tag )
|
: build-tag ( item name -- tag )
|
||||||
>r 1array r> build-tag* ;
|
>r 1array r> build-tag* ;
|
||||||
|
|
||||||
|
: standard-prolog ( -- prolog )
|
||||||
|
T{ prolog f "1.0" "iso-8859-1" f } ;
|
||||||
|
|
||||||
: build-xml ( tag -- xml )
|
: build-xml ( tag -- xml )
|
||||||
T{ prolog f "1.0" "iso-8859-1" f } { } rot { } <xml> ;
|
standard-prolog { } rot { } <xml> ;
|
||||||
|
|
||||||
: children>string ( tag -- string )
|
: children>string ( tag -- string )
|
||||||
tag-children
|
tag-children
|
||||||
|
|
Loading…
Reference in New Issue