Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file attribute_value.ml
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556(* TyXML
* http://www.ocsigen.org/tyxml
* Copyright (C) 2016 Anton Bachin
*
* 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.
*)[@@@ocaml.warning"-3"]openAst_helpertype'agparser=?separated_by:string->?default:string->Location.t->string->'a->Parsetree.expressionoptiontypeparser=stringgparsertypevparser=stringCommon.valuegparser(* Handle expr *)letexpr(parser:parser):vparser=fun?separated_by?defaultlocnamev->matchvwith|Antiquote->Somee|Vals->parser?separated_by?defaultlocnames(* Options. *)letoptionnone(parser:parser)?separated_by:_?default:_locnames=ifs=nonethenSome[%exprNone][@metalocloc]elsematchparser~default:nonelocnameswith|None->None|Somee->Some[%exprSome[%ee]][@metalocloc](* Lists. *)letfilter_mapfl=l|>List.fold_left(funaccv->matchfvwith|None->acc|Somev'->v'::acc)[]|>List.rev(* Splits the given string on the given delimiter (a regular expression), then
applies [element_parser] to each resulting component. Each such application
resulting in [Some expr] is included in the resulting expression list. *)letexp_listdelimiterseparated_by(element_parser:parser)locnames=Re_str.splitdelimiters|>filter_map(element_parser~separated_bylocname)(* Behaves as _expr_list, but wraps the resulting expression list as a list
expression. *)letlistdelimiterseparated_byelement_parser?separated_by:_?default:_locnames=exp_listdelimiterseparated_byelement_parserlocnames|>Common.listloc|>fune->Someeletspaces=list(Re_str.regexp" +")"space"letcommas=list(Re_str.regexp" *, *")"comma"letsemicolons=list(Re_str.regexp" *; *")"semicolon"letspaces_or_commas_regexp=Re_str.regexp"\\( *, *\\)\\| +"letspaces_or_commas_=exp_listspaces_or_commas_regexp"space- or comma"letspaces_or_commas=listspaces_or_commas_regexp"space- or comma"(* Wrapping. *)letwrap(parser:parser)implementation=expr@@fun?separated_by:_?default:_locnames->matchparserlocnameswith|None->Common.errorloc"wrap applied to presence; nothing to wrap"|Somee->Some(Common.wrapimplementationloce)letnowrap(parser:parser)_=expr@@fun?separated_by:_?default:_locnames->parserlocnames(* Error reporting for values in lists and options. *)letmust_be_asingular_descriptionplural_descriptionseparated_bydefaultlocname=letdescription=matchseparated_bywith|Someseparated_by->Printf.sprintf"a %s-separated list of %s"separated_byplural_description|None->matchdefaultwith|Somedefault->Printf.sprintf"%s or %s"singular_descriptiondefault|None->singular_descriptioninCommon.errorloc"Value of %s must be %s"namedescription(* General helpers. *)(* Checks that the given string matches the given regular expression exactly,
i.e. the match begins at position 0 and ends at the end of the string. *)letdoes_matchregexps=Re_str.string_matchregexps0&&Re_str.match_end()=String.lengths(* Checks that the group with the given index was matched in the given
string. *)letgroup_matchedindexs=tryRe_str.matched_groupindexs|>ignore;truewithNot_found->falseletint_explocs=trySome(Common.intloc(int_of_strings))withFailure_->Noneletfloat_explocs=trySome(Common.floatloc@@float_of_strings)withFailure_->Noneletbool_explocb=lets=ifbthen"true"else"false"inExp.construct~loc(Location.mkloc(Longident.Lidents)loc)None(* Numeric. *)letchar?separated_by:_?default:_locnames=letopenMarkupinletopenMarkup.Encodinginletreport_error=Common.errorloc"%s in attribute %s"(Markup.Error.to_stringerror|>String.capitalize)nameinletdecoded=strings|>decode~reportutf_8inletc=matchnextdecodedwith|None->Common.errorloc"No character in attribute %s"name|Someiwheni<=255->Char.chri|Some_->Common.errorloc"Character out of range in attribute %s"nameinbeginmatchnextdecodedwith|None->()|Some_->Common.errorloc"Multiple characters in attribute %s"nameend;Some(with_default_locloc@@fun()->Ast_convenience.charc)letonoff?separated_by:_?default:_locnames=letb=matchswith|""|"on"->true|"off"->false|_->Common.errorloc{|Value of %s must be "on", "" or "off"|}nameinSome(bool_explocb)letbool?separated_by:_?default:_locnames=letb=matchswith|""|"true"->true|"false"->false|_->Common.errorloc{|Value of %s must be "true", "" or "false"|}nameinSome(bool_explocb)letunit?separated_by:_?default:_locnames=ifs=""||s=namethenSome(Ast_convenience.(with_default_loclocunit))elseCommon.errorloc{|Value of %s must be %s or "".|}namenameletint?separated_by?defaultlocnames=matchint_explocswith|Some_ase->e|None->must_be_a"a whole number""whole numbers"separated_bydefaultlocnameletfloat?separated_by?defaultlocnames=matchfloat_explocswith|Some_ase->e|None->must_be_a"a number (decimal fraction)""numbers (decimal fractions)"separated_bydefaultlocnameletpoints?separated_by:_?default:_locnames=letexpressions=spaces_or_commas_floatlocnamesinletrecpairacc=function|[]->List.revacc|>Common.listloc|[_]->Common.errorloc"Unpaired coordinate in %s"name|ex::ey::rest->pair(([%expr[%eex],[%eey]][@metalocloc])::acc)restinSome(pair[]expressions)letnumber_pair?separated_by:_?default:_locnames=lete=beginmatchspaces_or_commas_floatlocnameswith|[orderx]->[%expr[%eorderx],None]|[orderx;ordery]->[%expr[%eorderx],Some[%eordery]]|_->Common.errorloc"%s requires one or two numbers"nameend[@metalocloc]inSomeeletfourfloats?separated_by:_?default:_locnames=matchspaces_or_commas_floatlocnameswith|[min_x;min_y;width;height]->Some[%expr([%emin_x],[%emin_y],[%ewidth],[%eheight])][@metalocloc]|_->Common.errorloc"Value of %s must be four numbers"name(* These are always in a list; hence the error message. *)leticon_size=letregexp=Re_str.regexp"\\([0-9]+\\)[xX]\\([0-9]+\\)"infun?separated_by:_?default:_locnames->ifnot@@does_matchregexpsthenCommon.errorloc"Value of %s must be a %s, or %s"name"space-separated list of icon sizes, such as 16x16""any";letwidth,height=tryint_of_string(Re_str.matched_group1s),int_of_string(Re_str.matched_group2s)withInvalid_argument_->Common.errorloc"Icon dimension out of range in %s"nameinSome[%expr[%eCommon.intlocwidth],[%eCommon.intlocheight]][@metalocloc](* Dimensional. *)letsvg_quantity=letinteger="[+-]?[0-9]+"inletinteger_scientific=Printf.sprintf"%s\\([Ee]%s\\)?"integerintegerinletfraction=Printf.sprintf"[+-]?[0-9]*\\.[0-9]+\\([Ee]%s\\)?"integerinletnumber=Printf.sprintf"%s\\|%s"integer_scientificfractioninletquantity=Printf.sprintf"\\(%s\\)\\([^0-9]*\\)$"numberinletregexp=Re_str.regexpquantityinfunkind_singularkind_pluralparse_unit?separated_by?defaultlocnames->ifnot@@does_matchregexpsthenmust_be_akind_singularkind_pluralseparated_bydefaultlocname;letn=matchfloat_exploc(Re_str.matched_group1s)with|Somen->n|None->Common.errorloc"Number out of range in %s"nameinletunit_string=Re_str.matched_group4sinletunit=(ifunit_string=""then[%exprNone]else[%exprSome[%eparse_unitlocnameunit_string]])[@metalocloc]in[%expr[%en],[%eunit]][@metalocloc]letsvg_length=letparse_unitlocnameunit=beginmatchunitwith|"cm"->[%expr`Cm]|"em"->[%expr`Em]|"ex"->[%expr`Ex]|"in"->[%expr`In]|"mm"->[%expr`Mm]|"pc"->[%expr`Pc]|"pt"->[%expr`Pt]|"px"->[%expr`Px]|"%"->[%expr`Percent]|s->Common.errorloc"Invalid length unit %s in %s"snameend[@metalocloc]infun?separated_by?defaultlocnames->Some(svg_quantity"an SVG length""SVG lengths"parse_unit?separated_by?defaultlocnames)letangle_=letparse_unitlocnameunit=beginmatchunitwith|"deg"->[%expr`Deg]|"rad"->[%expr`Rad]|"grad"->[%expr`Grad]|s->Common.errorloc"Invalid angle unit %s in %s"snameend[@metalocloc]insvg_quantity"an SVG angle""SVG angles"parse_unitletangle?separated_by?defaultlocnames=Some(angle_?separated_by?defaultlocnames)letoffset=letbad_formnameloc=Common.errorloc"Value of %s must be a number or percentage"nameinletregexp=Re_str.regexp"\\([-+0-9eE.]+\\)\\(%\\)?"infun?separated_by:_?default:_locnames->ifnot@@does_matchregexpsthenbad_formnameloc;beginletn=matchfloat_exploc(Re_str.matched_group1s)with|Somen->n|None->bad_formnamelocinifgroup_matched2sthenSome[%expr`Percentage[%en]]elseSome[%expr`Number[%en]]end[@metalocloc]lettransform=letregexp=Re_str.regexp"\\([^(]+\\)(\\([^)]*\\))"infun?separated_by:_?default:_locnames->ifnot@@does_matchregexpsthenCommon.errorloc"Value of %s must be an SVG transform"name;letkind=Re_str.matched_group1sinletvalues=Re_str.matched_group2sinlete=beginmatchkindwith|"matrix"->beginmatchspaces_or_commas_floatloc"matrix"valueswith|[a;b;c;d;e;f]->[%expr`Matrix([%ea],[%eb],[%ec],[%ed],[%ee],[%ef])]|_->Common.errorloc"%s: matrix requires six numbers"nameend|"translate"->beginmatchspaces_or_commas_floatloc"translate"valueswith|[tx;ty]->[%expr`Translate([%etx],Some[%ety])]|[tx]->[%expr`Translate([%etx],None)]|_->Common.errorloc"%s: translate requires one or two numbers"nameend|"scale"->beginmatchspaces_or_commas_floatloc"scale"valueswith|[sx;sy]->[%expr`Scale([%esx],Some[%esy])]|[sx]->[%expr`Scale([%esx],None)]|_->Common.errorloc"%s: scale requires one or two numbers"nameend|"rotate"->beginmatchRe_str.bounded_splitspaces_or_commas_regexpvalues2with|[a]->[%expr`Rotate([%eangle_loc"rotate"a],None)]|[a;axis]->beginmatchspaces_or_commas_floatloc"rotate axis"axiswith|[cx;cy]->[%expr`Rotate([%eangle_loc"rotate"a],Some([%ecx],[%ecy]))]|_->Common.errorloc"%s: rotate center requires two numbers"nameend|_->Common.errorloc"%s: rotate requires an angle and an optional center"nameend|"skewX"->[%expr`SkewX[%eangle_loc"skewX"values]]|"skewY"->[%expr`SkewY[%eangle_loc"skewY"values]]|s->Common.errorloc"%s: %s is not a valid transform type"namesend[@metalocloc]inSomee(* String-like. *)letstring?separated_by:_?default:_loc_s=Some(with_default_locloc@@fun()->Ast_convenience.strs)letvariands=letwithout_backticks=letlength=String.lengthsinString.subs1(length-1)ins|>Tyxml_name.polyvar|>without_backtickletvariant?separated_by:_?default:_loc_s=Some(Exp.variant~loc(variands)None)lettotal_variant(unary,nullary)?separated_by:_?default:_loc_names=letvariand=variandsinifList.memvariandnullarythenSome(Exp.variant~locvariandNone)elseSome(Exp.variant~locunary(Some(Common.stringlocs)))(* Miscellaneous. *)letpresence?separated_by:_?default:____=Noneletpaint_without_iccloc_names=beginmatchswith|"none"->[%expr`None]|"currentColor"->[%expr`CurrentColor]|_->leticc_color_start=trySome(Re_str.search_forward(Re_str.regexp"icc-color(\\([^)]*\\))")s0)withNot_found->Noneinmatchicc_color_startwith|None->[%expr`Color([%eCommon.stringlocs],None)]|Somei->leticc_color=Re_str.matched_group1sinletcolor=String.subs0iin[%expr`Color([%eCommon.stringloccolor],Some[%eCommon.stringlocicc_color])]end[@metalocloc]letpaint?separated_by:_?default:_locnames=ifnot@@Re_str.string_match(Re_str.regexp"url(\\([^)]+\\))")s0thenSome(paint_without_icclocnames)elseletiri=Re_str.matched_group1s|>Common.stringlocinletremainder_start=Re_str.group_end0inletremainder_length=String.lengths-remainder_startinletremainder=String.subsremainder_startremainder_length|>String.triminbeginifremainder=""thenSome[%expr`Icc([%eiri],None)]elseSome[%expr`Icc([%eiri],Some[%epaint_without_icclocnameremainder])]end[@metalocloc]letsrcset_element=letspace=Re_str.regexp" +"infun?separated_by:_?default:_locnames->lete=beginmatchRe_str.bounded_splitspaces2with|[url]->[%expr`Url[%eCommon.stringlocurl]]|[url;descriptor]->letbad_descriptor()=Common.errorloc"Bad width or density descriptor in %s"nameinleturl=Common.stringlocurlinletsuffix_index=String.lengthdescriptor-1inletis_width=matchdescriptor.[suffix_index]with|'w'->true|'x'->false|_->bad_descriptor()|exceptionInvalid_argument_->bad_descriptor()inifis_widththenletn=matchint_exploc(String.subdescriptor0suffix_index)with|Somen->n|None->Common.errorloc"Bad number for width in %s"namein[%expr`Url_width([%eurl],[%en])]elseletn=matchfloat_exploc(String.subdescriptor0suffix_index)with|Somen->n|None->Common.errorloc"Bad number for pixel density in %s"namein[%expr`Url_pixel([%eurl],[%en])]|_->Common.errorloc"Missing URL in %s"nameend[@metalocloc]inSomeeletnumber_or_datetime?separated_by:_?default:_loc_s=matchint_explocswith|Somen->Some[%expr`Number[%en]]|None->Some[%expr`Datetime[%eCommon.stringlocs]][@metalocloc](* Special-cased. *)letsandbox=spacesvariantletin_=total_variantSvg_types_reflected.in_valueletin2=in_letxmlns?separated_by:_?default:_locnames=ifs<>Markup.Ns.htmlthenCommon.errorloc"%s: namespace must be %s"nameMarkup.Ns.html;Some[%expr`W3_org_1999_xhtml][@metalocloc]