# XLMmod.joy

## Heiko.Kuhrt@t-online.de — 2003-12-11 13:45:44

    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.

    (*==========================================================================*)