Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file xml_print.ml
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511(* TyXML
* http://www.ocsigen.org/tyxml
* Copyright (C) 2008 Vincent Balat, Mauricio Fernandez
* Copyright (C) 2011 Pierre Chambart, Grégoire Henry
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published by
* the Free Software Foundation, with linking exception;
* either version 2.1 of the License, or (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02111-1307, USA.
*)letis_controlc=letcc=Char.codecin(cc<=8||cc=11||cc=12||(14<=cc&&cc<=31)||cc=127)letadd_unsafe_charb=function|'<'->Buffer.add_stringb"<"|'>'->Buffer.add_stringb">"|'"'->Buffer.add_stringb"""|'&'->Buffer.add_stringb"&"|cwhenis_controlc->Buffer.add_stringb"&#";Buffer.add_stringb(string_of_int(Char.codec));Buffer.add_stringb";"|c->Buffer.add_charbcletencode_unsafe_chars=letb=Buffer.create(String.lengths)inString.iter(add_unsafe_charb)s;Buffer.contentsbletencode_unsafe_char_and_ats=letb=Buffer.create(String.lengths)inletf=function|'@'->Buffer.add_stringb"@"|c->add_unsafe_charbcinString.iterfs;Buffer.contentsbletcompose_decl?(version="1.0")?(encoding="UTF-8")()=Format.sprintf{|<?xml version="%s" encoding="%s"?>\n|}versionencodingletcompose_doctypedtargs=letpp_argsfmt=function|[]->()|l->Format.fprintffmt" PUBLIC %a"(Format.pp_print_list~pp_sep:Format.pp_print_space(funfmt->Format.fprintffmt"\"%s\""))linFormat.asprintf"<!DOCTYPE %s%a>"dtpp_argsargsletre_end_comment=Re.(compile@@alt[seq[bos;str">"];seq[bos;str"->"];str"-->";str"--!>";])letescape_comments=letfg=matchRe.Group.getg0with|">"->">"|"->"->"->"|"-->"->"-->"|"--!>"->"--!>"|s->sinRe.replace~all:truere_end_comment~fs(* copied form js_of_ocaml: compiler/javascript.ml *)letpp_numberfmtv=ifv=infinitythenFormat.pp_print_stringfmt"Infinity"elseifv=neg_infinitythenFormat.pp_print_stringfmt"-Infinity"elseifv<>vthenFormat.pp_print_stringfmt"NaN"elseletvint=int_of_floatvin(* compiler 1000 into 1e3 *)iffloat_of_intvint=vthenletrecdivni=ifn<>0&&nmod10=0thendiv(n/10)(succi)elseifi>2thenFormat.fprintffmt"%de%d"nielseFormat.pp_print_intfmtvintindivvint0elselets1=Printf.sprintf"%.12g"vinifv=float_of_strings1thenFormat.pp_print_stringfmts1elselets2=Printf.sprintf"%.15g"vinifv=float_of_strings2thenFormat.pp_print_stringfmts2elseFormat.fprintffmt"%.18g"vletstring_of_numberv=Format.asprintf"%a"pp_numbervmoduleUtf8=structtypeutf8=stringletnormalizesrc=letwarn=reffalseinletbuffer=Buffer.create(String.lengthsrc)inUutf.String.fold_utf_8(fun__d->matchdwith|`Ucharcode->Uutf.Buffer.add_utf_8buffercode|`Malformed_->Uutf.Buffer.add_utf_8bufferUutf.u_rep;warn:=true)()src;(Buffer.contentsbuffer,!warn)letnormalization_neededsrc=letrecloopsrcil=i<l&&matchsrc.[i]with(* Characters that need to be encoded in HTML *)|'\034'|'\038'|'\060'|'\062'->true(* ASCII characters *)|'\009'|'\010'|'\013'|'\032'..'\126'->loopsrc(i+1)l|_->trueinloopsrc0(String.lengthsrc)letnormalize_htmlsrc=ifnormalization_neededsrcthenbeginletwarn=reffalseinletbuffer=Buffer.create(String.lengthsrc)inUutf.String.fold_utf_8(fun__d->matchdwith|`Ucharu->beginmatchUchar.to_intuwith|34->Buffer.add_stringbuffer"""|38->Buffer.add_stringbuffer"&"|60->Buffer.add_stringbuffer"<"|62->Buffer.add_stringbuffer">"|code->letu=(* Illegal characters in html
http://en.wikipedia.org/wiki/Character_encodings_in_HTML
http://www.w3.org/TR/html5/syntax.html *)if(* A. control C0 *)(code<=31&&code<>9&&code<>10&&code<>13)(* B. DEL + control C1
- invalid in html
- discouraged in xml;
except 0x85 see http://www.w3.org/TR/newline
but let's discard it anyway *)||(code>=127&&code<=159)(* C. UTF-16 surrogate halves : already discarded
by uutf || (code >= 0xD800 && code <= 0xDFFF) *)(* D. BOM related *)||codeland0xFFFF=0xFFFE||codeland0xFFFF=0xFFFFthen(warn:=true;Uutf.u_rep)elseuinUutf.Buffer.add_utf_8bufferuend|`Malformed_->Uutf.Buffer.add_utf_8bufferUutf.u_rep;warn:=true)()src;(Buffer.contentsbuffer,!warn)endelse(src,false)endmoduletypeTagList=sigvalemptytags:stringlistend(** Format based printers *)letpp_noop_fmt_=()moduleMake_fmt(Xml:Xml_sigs.Iterable)(I:TagList)=structopenXmlletopen_boxindentfmt=ifindentthenFormat.pp_open_boxfmt0else()letclose_boxindentfmt=ifindentthenFormat.pp_close_boxfmt()else()letspindentfmt=ifindentthenFormat.pp_print_spacefmt()elseFormat.pp_print_stringfmt" "letcutindentfmt=ifindentthenFormat.pp_print_cutfmt()else()moduleS=Set.Make(String)letis_emptytag=matchI.emptytagswith|[]->fun_->false|l->letset=List.fold_left(funsx->S.addxs)S.emptylinfunx->S.memxsetletpp_encodeencodeindentfmts=lets=encodesinifindentthenFormat.fprintffmt"@[%a@]"Format.pp_print_textselseFormat.pp_print_stringfmtsletpp_sepindent=function|Space->funfmt()->spindentfmt|Comma->funfmt()->Format.fprintffmt",%t"(spindent)letpp_attrib_valueencodeindentfmta=matchacontentawith|AFloatf->Format.fprintffmt"\"%a\""pp_numberf|AInti->Format.fprintffmt"\"%d\""i|AStrs->Format.fprintffmt"\"%s\""(encodes)|AStrL(sep,slist)->Format.fprintffmt"\"%a\""(Format.pp_print_list~pp_sep:(pp_sepindentsep)(pp_encodeencodeindent))slistletpp_attribencodeindentfmta=Format.fprintffmt"%t%s=%a"(spindent)(anamea)(pp_attrib_valueencodeindent)aletpp_attribsencodeindent=Format.pp_print_list~pp_sep:pp_noop(pp_attribencodeindent)letpp_tag_and_attribsencodeindentfmt(tag,attrs)=open_boxindentfmt;Format.fprintffmt"%s%a%t"tag(pp_attribsencodeindent)attrs(cutindent);close_boxindentfmtletpp_closedtagencodeindentfmttagattrs=ifis_emptytagtagthenFormat.fprintffmt"<%a/>"(pp_tag_and_attribsencodeindent)(tag,attrs)elsebeginopen_boxindentfmt;Format.fprintffmt"<%a>%t</%s>"(pp_tag_and_attribsencodeindent)(tag,attrs)(cutindent)tag;close_boxindentfmtendletrecpp_tagencodeindentfmttagattrschildren=matchchildrenwith|[]->pp_closedtagencodeindentfmttagattrs|_->open_boxindentfmt;Format.fprintffmt"<%t%a>%t%a%t%t</%s>"(open_boxindent)(pp_tag_and_attribsencodeindent)(tag,attrs)(cutindent)(pp_eltsencodeindent)children(close_boxindent)(cutindent)tag;close_boxindentfmtandpp_eltencodeindentfmtelt=matchcontenteltwith|Commenttexte->Format.fprintffmt"<!--%s-->"(escape_commenttexte)|Entitye->Format.fprintffmt"&%s;"e|PCDATAtexte->pp_encodeencodeindentfmttexte|EncodedPCDATAtexte->Format.pp_print_stringfmttexte|Node(name,xh_attrs,xh_taglist)->pp_tagencodeindentfmtnamexh_attrsxh_taglist|Leaf(name,xh_attrs)->pp_closedtagencodeindentfmtnamexh_attrs|Empty->()andpp_eltsencodeindent=Format.pp_print_list~pp_sep:(funfmt()->cutindentfmt)(pp_eltencodeindent)letpp?(encode=encode_unsafe_char)?(indent=false)()=pp_eltencodeindentendmoduleMake_typed_fmt(Xml:Xml_sigs.Iterable)(Typed_xml:Xml_sigs.Typed_xmlwithmoduleXml:=Xml)=structmoduleP=Make_fmt(Xml)(Typed_xml.Info)(* Add an xmlns tag on the html element if it's not already present *)letprepare_documentdoc=letdoc=Typed_xml.doc_toeltdocinmatchXml.contentdocwith|Xml.Node(n,a,c)->leta=ifList.exists(funa->Xml.anamea="xmlns")athenaelseXml.string_attrib"xmlns"Typed_xml.Info.namespace::ainXml.node~anc|_->docletpp_elt?(encode=encode_unsafe_char)?(indent=false)()fmtforet=P.pp_eltencodeindentfmt(Typed_xml.toeltforet)letpp?(encode=encode_unsafe_char)?(indent=false)?advert()fmtdoc=Format.pp_open_vboxfmt0;Format.fprintffmt"%s@,"Typed_xml.Info.doctype;beginmatchadvertwith|Somes->Format.fprintffmt"<!-- %s -->@,"s|None->()end;P.pp_eltencodeindentfmt(prepare_documentdoc);Format.pp_close_boxfmt();endmoduleMake(Xml:Xml_sigs.Iterable)(I:TagList)(O:Xml_sigs.Output)=structlet(++)=O.concatopenXmlletseparator_to_string=function|Space->" "|Comma->", "letattrib_value_to_stringencodea=matchacontentawith|AFloatf->Printf.sprintf"\"%s\""(string_of_numberf)|AInti->Printf.sprintf"\"%d\""i|AStrs->Printf.sprintf"\"%s\""(encodes)|AStrL(sep,slist)->Printf.sprintf"\"%s\""(encode(String.concat(separator_to_stringsep)slist))letattrib_to_stringencodea=Printf.sprintf"%s=%s"(anamea)(attrib_value_to_stringencodea)letrecxh_print_attrsencodeattrs=matchattrswith|[]->O.empty|attr::queue->O.put(" "^attrib_to_stringencodeattr)++xh_print_attrsencodequeueandxh_print_closedtagencodetagattrs=ifI.emptytags=[]||List.memtagI.emptytagsthen(O.put("<"^tag)++xh_print_attrsencodeattrs++O.put" />")else(O.put("<"^tag)++xh_print_attrsencodeattrs++O.put("></"^tag^">"))andxh_print_tagencodetagattrstaglist=iftaglist=[]thenxh_print_closedtagencodetagattrselse(O.put("<"^tag)++xh_print_attrsencodeattrs++O.put">"++xh_print_taglistencodetaglist++O.put("</"^tag^">"))andprint_nodesencodenamexh_attrsxh_taglistqueue=xh_print_tagencodenamexh_attrsxh_taglist++xh_print_taglistencodequeueandxh_print_taglistencodetaglist=matchtaglistwith|[]->O.empty|elt::queue->matchcontenteltwith|Commenttexte->O.put("<!--"^(encodetexte)^"-->")++xh_print_taglistencodequeue|Entitye->O.put("&"^e^";")(* no encoding *)++xh_print_taglistencodequeue|PCDATAtexte->O.put(encodetexte)++xh_print_taglistencodequeue|EncodedPCDATAtexte->O.puttexte++xh_print_taglistencodequeue|Node(name,xh_attrs,xh_taglist)->print_nodesencodenamexh_attrsxh_taglistqueue|Leaf(name,xh_attrs)->print_nodesencodenamexh_attrs[]queue|Empty->xh_print_taglistencodequeueletprint_list?(encode=encode_unsafe_char)foret=O.make(xh_print_taglistencodeforet)endmoduleMake_typed(Xml:Xml_sigs.Iterable)(Typed_xml:Xml_sigs.Typed_xmlwithmoduleXml:=Xml)(O:Xml_sigs.Output)=structmoduleP=Make(Xml)(Typed_xml.Info)(O)let(++)=O.concatletprint_list?(encode=encode_unsafe_char)foret=O.make(P.xh_print_taglistencode(List.mapTyped_xml.toeltforet))letprint?(encode=encode_unsafe_char)?(advert="")doc=letdoc=Typed_xml.doc_toeltdocinletdoc=matchXml.contentdocwith|Xml.Node(n,a,c)->leta=ifList.exists(funa->Xml.anamea="xmlns")athenaelseXml.string_attrib"xmlns"Typed_xml.Info.namespace::ainXml.node~anc|_->docinO.make(O.putTyped_xml.Info.doctype++O.put(ifadvert<>""then("<!-- "^advert^" -->\n")else"\n")++P.xh_print_taglistencode[doc])endmoduleSimple_output(M:sigvalput:string->unitend)=structtypeout=unittypem=unit->unitletempty()=()letconcatf1f2()=f1();f2()letputs()=M.putsletmakef=f()endmoduleMake_simple(Xml:Xml_sigs.Iterable)(I:TagList)=structletprint_list~output=letmoduleM=Make(Xml)(I)(Simple_output(structletput=outputend))inM.print_listendmoduleMake_typed_simple(Xml:Xml_sigs.Iterable)(Typed_xml:Xml_sigs.Typed_xmlwithmoduleXml:=Xml)=structletprint_list~output=letmoduleM=Make_typed(Xml)(Typed_xml)(Simple_output(structletput=outputend))inM.print_listletprint~output=letmoduleM=Make_typed(Xml)(Typed_xml)(Simple_output(structletput=outputend))inM.printend