Hello!
Currently I'm working on Rabbit again (you remember the documentation
generating animal for atoms and definitions of Joy?).
The following module is a spin off of that work: a module dealing with
functions for XML access. It's in no ways complet but it fits so far
the needs of Rabbit. It's still under construction, that's why I don't
put it to yahoo/files but dump it into this mailing list as an
intermediate snapshot.
I'm sure this is exactly what you have always been looking for;)
Apart from the common libs XMLmod.joy needs some.joy .
http://groups.yahoo.com/group/concatenative/files/rabbit/some.joy
xm[l]as regards
--Heiko
(*==========================================================================*)
(* xmlgen.joy *)
(* Heiko Kuhrt,
Heiko.Kuhrt@... *)
(* November 2003 *)
(* 11/03 - 11/03 *)
#:==== xml-basics
============================================================
#:.make name atts contents -- XE:[name atts contents]
#:.makehead name atts -- [name atts]
#:.maketail atts contents -- [atts contents]
#:.makecn contents name -- XE:[name [] contents]
#:
#:.addName [ atts contents] name -- XE
#:.addAtts [name contents] atts -- XE
#:.addContents [name atts ] contents -- XE
#:
#:.maybe XE -- bool
#:
#:.unmake XE -- name atts contents
#:.getName XE -- name
#:.getAtts XE -- atts
#:.getContents XE -- contents
#:.giveName [name atts contents] -- name [atts
contents]
#:.giveAtts [ atts contents] -- atts [
contents]
#:.giveContents [ contents] -- contents
#:
#:.initAtts -- []
#:.addAtt [[]..] name value -- [[name value] []..]
#:.hasAtt XE attname -- bool
#:.getAtt XE attname -- attvalue
#:
#:.initContents -- []
#:.addContents [..] X -- [X..]
#:
#:
#:.makeEmpty name atts -- [name atts[]]
#:.isEmpty XE -- bool
#:.isNotEmpty XE -- bool
#:
#:.hasna XE [name[atts]] -- bool
#:.add XE X -- XE
#:
#:.mapContents XE [P] -- XE
#:.sortContentsWith XE [P] -- XE
#:.getXEsbyName XE name -- [XEs]
#:.getXEbyName XE name -- XE
#:==== writeXML
==============================================================
#:__testdoc1 -- xmlTestTree
#: versionTag -- tagstr
#: timeStamp -- tagstr
#: starttag Tag Atts -- tagstr
#: stoptag Tag -- tagstr
#: emptytag name atts -- tagstr
#: indentElements -- []
#: adjustIndent oldind tag -- oldind newind
#: mapSpecialChars str -- str
#: strAtt [name value] -- str
#: strAtts [atts] -- str
#: strElement indent element -- str
#:.strTree XmlTree -- str
#:.writeDoc XmlTree --
#:__writeDoc -- !__testdoc1
writeDoc
#:
#:==== printXML
==============================================================
#:.print XE -- XE !print XE
#:.cpx XE -- XE !print XE and
wait
#:==== readXML
===============================================================
#: parsErr str --
#: skipSpaces R -- R
#: popTrailingSpaces R --
#: comesnoNameChr R -- bool
#: comesnoDQChr R -- bool
#: comesnoSQChr R -- bool
#: comesGTorDIV R -- bool
#: comesLT R -- bool
#: comesGT R -- bool
#: comesLTDIV R -- bool
#: checkndrop R chr -- R
#: readName R -- name R
#: readAttValueDQ R -- value R
#: readAttValueSQ R -- value R
#: readAtt R -- [name value] R
#: readAtts R -- [atts] R
#: readStarttag R -- name [atts] R
#: readStoptag R -- name R
#: spaces2 c str -- bool
#: cons-nopreserve c str -- str
#: readPlain R -- Str R
#: skipDoctype docstr -- treestr
#: readElement R -- [name [atts] [children]] R
#:.readDoc filename -- xmlTree
#:__readDoc -- !"first.xml"readDoc
writeXmlDoc
#:!readMainDoc -- !"maindoc.xml"readDoc
writeXmlDoc
#:==== buildXML
==============================================================
#: checkisString x -- x
#: checkisValidName name -- name
#: checkisPlain string -- string
#: getName element -- name
#: checkTagMatch name attlist contents name -- name attlist
contents
#: makeAttsList attsquote -- atts
#: foldChildren X Element Concat Element Concat ...--
ElementList
#: openElement --
#:.Plain -- Constuctor
#:.Enclose -- Constuctor
#:.Begin -- Constuctor
#:.End -- Constuctor
#:.Empty -- Constuctor
#:.Next -- Constuctor
#:.Concat -- Constuctor
#: asRoot str -- str
#:.mux | text Plain -- mu
#: |name attlist Begin -- mu
#: |name attlist contents Enclose -- mu
#: |name attlist Empty -- mu
#: |name attlist Next -- mu
#: |name attlist contents name End -- mu
#: | others -- error
#:__xmlgentest -- !print
xmtreestring_of_testmu
##############################################################################
##############################################################################
MODULE XE
PUBLIC
#===== xml-basics
============================================================
make ==
pair cons
;
makehead ==
pair
;
maketail ==
pair
;
makecn ==
swap []swap make
;
addName ==
swons
;
addAtts ==
[unpair]dip swap make
;
addContents ==
unitlist concat
;
maybe ==
[ #[list]
[first string]
[second list]
[third list]
] 1 fold-andconds
;
unmake ==
uncons uncons first
;
getName ==
first
;
getAtts ==
second
;
getContents ==
third
;
giveName ==
uncons
;
giveAtts ==
uncons
;
giveContents ==
first
;
initAtts ==
[]
;
addAtt ==
pair swons
;
hasAtt ==
[getAtts]dip
# [atts] name
[first] makeEqualTest some
;
--hasAtt ==["root"[["a""1"]["b""2"]["c""3"]["c""3"]] []] "a"hasAtt
v
;
getAtt ==
dup
[ [getAtts]dip
[first]makeEqualTest
filter
]dip
[pop null ]
["getAttXE: att not found."error]
[ [pop small] [pop] ["getAttXE: att multiple."error]ifte ]
ifte
first second
;
--getAtt == ["root"[["a""1"]["b""2"]["c""3"]["c""3"]] []] "b"getAtt v;
initContents ==
[]
;
addContents ==
swons
;
makeEmpty ==
pair
;
isEmpty ==
size 2 =
;
isNotEmpty ==
size 3 =
;
hasna ==
[getContents [2 take]map ]dip
[equal]cons some
;
--hasna == ["root"[atts][
["a"["a""1"][some]]
["b"[][thing]]
["a"["a""2"][conts]]
["c"[][]]
]]
["a"["a""2"]] hasna v;
add ==
[unmake]dip
swons
make
;
--add == ["root"[["a" "9"]][
["a"[]["some" ]]
]]
["a"[]["new" ]] add
v
;
mapContents ==
[unmake]dip
# ...X name [atts] [contents] [P]
swap2
[map]dipd
rolldown
make
;
--mapContents ==
["testmap"[][ ]] [10 +] mapContents
["testmap"[][1 2 3]] [10 +] mapContents
10 ["testmap"[][1 2 3]] [ + ] mapContents
v
;
sortContentsWith ==
[unmake]dip
mk_qsort
make
;
--sortContentsWith ==
#10 ["root"[][1 4 7 2 9 1 ]] [+ ]sortContentsWith
#not with mk_qsort (but poss. with map)
["root"[][1 4 7 2 9 1 ]] [ ]sortContentsWith
["root"[][ [2 1][6 4][3 4] ]] [first ]sortContentsWith
["root"[][ [2 1][6 4][3 4] ]] [second]sortContentsWith
v
;
getXEsbyName ==
[getContents]dip
[equal]cons [getName]first swons
filter
;
--getXEsbyName ==
["root"[][
["a"[][some]]
["b"[][thing]]
["a"[][conts]]
["c"[][]]
]]
"a" getXEsbyName v;
getXEbyName ==
getXEsbyName first
;
#==== xml-basics
============================================================
#===== writeXML
==============================================================
__testdoc1 ==
["mails"[["id" "1"]["date" "031122"]][
["note"[["id" "1"]]
[["from" []["Jan"]]
["to" []["Heiko"]]
["message"[]["coming soon"]]
]]
["note" [["id" "2"]]
[["from" []["Jan"]]
["to" []["Heiko"]]
"inlay of text"
["message"[]["coming soon"]]
]]
["note" [["id" "3"]]
[["from" []["Jan"]]
["to" []["Heiko"]]
["message"[]["coming" ["strong"[]["ho<>pefull"]] "soon"]]
]]
]]
;
versionTag ==
"<?xml version='1.0' encoding='ISO-8859-1'?>\n"
;
timeStamp ==
[ "<!-- Created at " today " " now
" with Programming Language Joy. -->\n"
]docca
;
starttag ==
concat "<" ">" wrapconcat
;
stoptag ==
"</" ">" wrapconcat
;
emptytag ==
concat "<" " />"wrapconcat
;
#indentElements == ["message" "mess" "from" "to" "text"];
#indentElements == ["message" "mess" "from" "to" "text"];
indentElements ==
[]
;
adjustIndent ==
[indentElements isnotin][ pop dup 1 +][pop 0]ifte
;
mapSpecialChars ==
cp id
;
strAtt ==
unpair "'" "'"wrapconcat "="swap concat3 " "swoncat
;
--strAtt ==
["name" "value"]strAtt v
;
strAtts ==
""swap [null] [pop] [uncons [strAtt concat]dip]tailrec
;
--strAtts ==
[["name" "value"]["name2" "value2"]]strAtts
[]strAtts
v
;
xmlrse == (* Replace Special Entities *)
(** Str -> Str *)
[""]dip
[ [ [['> =] pop ";tg&" ]
[['< =] pop ";tl&" ]
[['& =] pop ";pma&"]
[""cons]
]cond
swoncat]step
reverse;
strElement ==
[first adjustIndent]dudip
[isNotEmpty]
[ uncons
[dup stoptag]dip
unpair [strAtts swap [starttag]dip ]dip
rolldownd
#strElements
""rollup
[ (*"" indent element*)
[list][strElement][xmlrse]ifte
swap [concat]dip
]step
[swap concat3]dip ]
[unpair strAtts emptytag swap]
ifte
[]["\n"swap [" "concat]times ""wrapconcat][pop]ifte
;
strTree ==
-1 swap strElement popd
;
--strTree ==
__testdoc1 strTree
v
;
writeDoc ==
strTree
timeStamp swoncat
versionTag swoncat
"doc.xml" write-file-contents
;
__writeDoc ==
__testdoc1 writeDoc
;
#==== writeXML
==============================================================
#===== print
=================================================================
print ==
"---------------------------------------"newputline
dup strTree putline
"======================================="putline
;
cpx ==
print
"XE.cpx:"putline stdin fgets pop2;
#==== print
=================================================================
#===== readXML
===============================================================
parsErr ==
"XLM parsing failed: "error
;
skipSpaces ==
[ [null]["skipspaces"parsErr][first " \n\t"in not]ifte ]
[]
[rest]
tailrec
;
--skipSpaces ==
"x"skipSpaces " xx"skipSpaces "xx"skipSpaces
" \n\n\t\t xx"skipSpaces
v
;
popTrailingSpaces ==
[null]
[pop]
[unswons
[" \t\n"in not]
["At docend only spaces expected."parsErr]
[pop]
ifte
]
tailrec
;
comesnoNameChr ==
first "></ \t\n=\"'"in
;
comesnoDQChr ==
first "\"" in
;
comesnoSQChr ==
first "'" in
;
comesGTorDIV ==
first ">/" in
;
comesLT ==
first '< =
;
comesGT ==
first '> =
;
comesLTDIV ==
2 take "</" =
;
checkndrop ==
unswonsd [=][pop2]["checkndrop"parsErr]ifte
;
readName ==
[comesnoNameChr]
[""swap]
[uncons][consd]
linrec
skipSpaces
;
--readName ==
"abcde>"readName "x y"readName
v
;
readAttValueDQ ==
[comesnoDQChr ][rest ""swap] [uncons][consd]linrec
;
readAttValueSQ ==
[comesnoSQChr ][rest ""swap] [uncons][consd]linrec
;
readAtt ==
readName
'= checkndrop
skipSpaces
unswons
[['' readAttValueSQ]
['" readAttValueDQ]
["readAtt"parsErr]
]case
[pair]dip
skipSpaces
;
--readAtt ==
"name='value'>"readAtt "n=''>"readAtt "n2 = ''>"readAtt
v
;
readAtts ==
[comesGTorDIV][[]swap][readAtt][consd]linrec
;
--readAtts ==
">"readAtts "n='7'>"readAtts
"n='7' n2 = '700' n50=\"something attsvalue\" >"readAtts
v
;
readStarttag ==
rest readName readAtts
;
--readStarttag ==
"<t>"readStarttag "<tag />"readStarttag
"<name a1='0' a2='7'>more"readStarttag
v
;
readStoptag ==
2 drop readName rest
;
spaces2 ==
first[=][pop 32 chr =]conjoin i
;
cons-nopreserve ==
[ ["\t\n"in][pop 32 chr][]ifte ]dip
[ [null not][spaces2]conjoin i] [popd][cons]ifte
;
readPlain == skipSpaces
[comesLT][""swap][uncons]
[[cons-nopreserve]dip]linrec
;
--readPlain ==
"Any text or what ever.<more>"readPlain v
;
skipDoctype ==
[ [null]
["skipdoctype"parsErr]
[[first '< =][second "?!" in not][false]ifte]
ifte
]
[][rest]tailrec
;
--skipDoctype ==
"<?...?> <?...?> <tag>"skipDoctype v
;
readElement ==
#__memoryindex formatx putline
readStarttag
[comesGT]
[ rest
#readChildren:
[ [ [comesLTDIV] [[]swap] ]
[ [comesLT] [readElement] [consd] ]
[ [readPlain] [consd] ]
]condlinrec
readStoptag
[ #name [atts] [children] name
[[pop2]dip =]
[]
[ [pop2]dip
stack size put " "swap concat3
"Start- and Stoptag don't match: "swoncat
parsErr]
ifte
pop
pair cons
]dip
]
[ 2 drop
[pair]dip]
ifte
;
--readElement ==
"<tag>..</tag>..."readElement
"<tag att='1002'></tag>..."readElement
"<t><d><c-l color=\"#000000\" /></d></t>."readElement
"<t>pre<d>in<inner i='some'>in inner</inner></d>post</t>."readElement
v
;
readDoc ==
dup " reading."concat putline
get-file-contents
skipDoctype
readElement
popTrailingSpaces
"ready"putline
;
__readDoc ==
"first.xml"readDoc writeDoc
;
!readMaindoc ==
"maindoc.xml"readDoc writeXmlDoc
__memorymax put __memoryindex put "Memorymax/index"putline
;
#==== readXML
===============================================================
#===== buildXML
==============================================================
Plain == "Plain";
Enclose == "Enclose";
Begin == [Begin]first;
End == [End]first;
Empty == "Empty";
Next == [Next]first;
Concat == "Concat";
checkisString ==
[string][]["mux: string expected: "error]ifte
;
checkisValidName ==
checkisString
;
checkisPlain ==
checkisString
;
getName ==
first
;
checkTagMatch ==
[[getName]dip =]
[pop]
[[first]dip " "swoncat concat "mux: tags don't match: "error]
ifte
;
makeAttsList ==
dequote
[size even] []["Attribute without value:"error]ifte
[[string not]some]["Att-value-pairs must be strings."error][]ifte
[null] [] [uncons uncons]
[[pair]dip cons]linrec
;
foldChildren ==
[]
[pop [string][Concat = not][true]ifte]
[]
[popd cons]
tailrec
;
openElement ==
id
;
asRoot ==
pop
;
mux ==
[ [ [(* text what*)Plain =] pop
checkisPlain Concat]
[ [(*name attlist what*)Begin =] pop
makeAttsList pair]
[ [(*name attlist contents what*)Enclose =] pop
[makeAttsList]dip dequote pair cons Concat]
[ [(*name attlist what*)Empty =] pop makeAttsList
pair Concat]
[ [(*name attlist what*)Next =] pop dupd [End
mux]dipd Begin mux]
[ [(*name attlist contents name what*)End =] pop [foldChildren
unitlist concat]dip
checkTagMatch Concat]
[ "mux: no valid constructor."error]
]cond
;
__xmlgentest ==
"root" [] Begin mux
"mails"["folder""concatenative"]Begin mux
"mail"["id" "1"]Begin mux
"from"["sender""e1t"][] Enclose mux
"Just a plain string." Plain mux
"to" ["getter""cowan"][] Enclose mux
"text"[]["Some nice greeting and so on."] Enclose mux
"date"["year" "2003"]Empty mux
"mail"["id""2"]Next mux
"from"["sender""e1t"][] Enclose mux
"to" ["getter""cowan"][] Enclose mux
"text"[]["Some nice greeting and so on."] Enclose mux
"date"["year" "2003"]Empty mux
"mail"End mux
"mails"["folder""forth"]Next mux
"mail"["id" "1"]Begin mux
"from"[]["sender""e1t"] Enclose mux
"to" []["getter""cowan"] Enclose mux
"text"[][ "Some " "very " dup dup"nice "
["strong"[]["greeting "]]
"and so on."
] Enclose mux
"date"["year" "2003"]Empty mux
"mail"["id" "1"]Next mux
"from"[]["sender""e1t"] Enclose mux
"to" []["getter""cowan"] Enclose mux
"text"[]["Some nice greeting and so on."] Enclose mux
"date"["year" "2003"]Empty mux
"mail"End mux
"mails"End mux
"root"End mux
asRoot
print
;
END.
#==== buildXML
==============================================================
"xml is loaded."putline.
(*==========================================================================*)