xhtml.opa

/*
    Copyright © 2011-2013 MLstate

    This file is part of Opa.

    Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

    The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

    THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
*/

import-plugin server
import stdlib.core.{web.core, rpc.core, parser, funaction, unification, js}

/**
 * {1 About this module}
 *
 * {1 where should i start?}
 *
 * {1 what if i need more?}
 */

/**
 * {1 Types defined in this module}
 */

/**
 * The content of a xhtml event handler
 *
 * To allow runtime manipulation of Xhtml, e.g. for (de)serialization, xhtml event handlers have two representations,
 * depending on where they are computed.
 */
@opacapi
type xhtml_event = { expr: FunAction.t /** An actual function. This can only ever happen if we're on the client, executing code generated by the client.*/
                   }
                 / { value: string     /** A pre-compiled JavaScript string containing the code. This happens when we're on the server,
                                           or when the code has been received from the server.*/
                   }

/*
 TODO:

 For better security (and performance?), we should replace the [value] case with the following

{ function: string;                          //The identifier of a toplevel function
  args:     list( {deserialize: (ty, string)}//Non-optimized case: we should perform full deserialization
                / {parse: string}            //Optimized case: we only need to deserialize using JSON.parse
                / {ident: string}            //Optimal case: the argument is already on the client
                )
*/

//TODO: Rename [xhtml_event] to Xhtml.event_handler
//TODO: We could possibly renormalize to always have [expr] on the client and [value] on the server. I'm not sure it would be useful, though.

/**
 * @param 'attributes A set of attributes specific to the XML dialect
 */
@opacapi
type xml('attributes,'extensions) =
  { text : string }         /**Text meant to be escaped before any insertion*/
/ { content_unsafe: string } /**Text meant to be inserted without any check or escaping. Absolutely unsafe, of course.*/
/ { fragment : list(xml('attributes,'extensions)) }
/ { namespace : string /** The namespace name */
    tag : string
    args : list(Xml.attribute)
    xmlns : list(Xml.binding)
    content : list(xml('attributes,'extensions))
    specific_attributes : option('attributes) }
/ { xml_dialect : option('extensions) }

@opacapi
type Xml.attribute = { namespace:string name:string value:string }

@opacapi
type Xml.binding = { name:string uri:string } / {default : string}

@opacapi
type xhtml_href =
    {constant:string} /**Constant string, no additional check.*/
/   {untyped:string}  /**Untyped string,  go through whitelist checking*/
/   {typed:Uri.uri}   /**Typed structure, we assume that it has already been checked, so no additional check.*/
/   {none}            /**No URI*/

@opacapi
type xhtml_bool_attribute_value =
    {string:string}
/   {bool:bool}
/   {none}

@opacapi
type xhtml_bool_attribute = { name:string value:xhtml_bool_attribute_value }

type xhtml_specific_attributes =
  {
        class:list(string)/**The classes of this element.*/
        style:Css.properties /**The style properties of this element*/
        bool_attributes:list(xhtml_bool_attribute)
        events:list(handle_assoc(xhtml_event)) /**The event handlers associated with this element, as a list of pairs event name (_not_ attribute name) * event handler */
        events_options:list(handle_assoc(list(Dom.event_option)))
        href: xhtml_href/**Possibly a hyperlink.*/
}

/**
 * A precompiled html extract.
 *
 * Note: We keep html and js separate to avoid any premature evaluation of JS by overzealous browsers.
 */
type xhtml_specific_extensions =
{
  html_code_unsafe: string/**The html code. It won't be checked before being inserted, so be sure that it has been checked before. It should not contain any JS code.*/
  js_code_unsafe:   string/**The JS code.*/
}

@opacapi
type xhtml = xml(xhtml_specific_attributes, xhtml_specific_extensions)

@abstract type empty = void
type xmlns_dialect = empty
type xmlns_specific_attributes = empty
/* FIXME: when universal quantification is available, we should
 * have instead
 * type xmlns = forall('attributes,'extensions) xml('attributes,'extensions) */
type xmlns = xml(xmlns_specific_attributes,xmlns_dialect)
type xml_header =
  { version : option(float)
    encoding : option(string)
    standalone : option(bool)
  }
type xml_document =
  { header : xml_header
    element : xmlns
  }

/**
 * {1 Functions exported to the global namespace}
 */

/**
 * The empty fragment of xhtml
 */
empty_xhtml = {fragment = []} : xhtml

/**
 * Convert a data structure to human-readable X(HT)ML
 */
@opacapi
@specialize(Xml.to_xml:xhtml -> xhtml,
            Xml.to_xml:xmlns -> xmlns,
            Xml.create_fragment:list(xhtml) -> xhtml,
            Xml.create_fragment:list(xmlns) -> xmlns,
            XmlConvert.of_string:string -> xhtml,
            XmlConvert.of_int:int -> xhtml,
            XmlConvert.of_float:float -> xhtml,
            XmlConvert.of_bool:bool -> xhtml,
            XmlConvert.of_void:void -> xhtml)
magicToXml = XmlConvert.of_alpha : 'a -> xml

/**
 * {1 Xmlns interface}
 */

Xmlns =
{{

   /**
    * Convert a xmlns structure to xhtml
    * FIXME: when xmlns is defined as said above, use [to_xhtml(x:xmlns) : xhtml = x]
    */
   to_xhtml(xmlns: xmlns): xhtml = @unsafe_cast(xmlns)

   /**
    * Convert a xmlns structure into a string, assuming utf-8 encoding
    */
   to_string : xmlns -> string = serialize_to_string

   /**
    * Convert a xhtml structure into a xmlns
    * This function returns an option as it may fail
    * when html specific features are used
    */
   of_xhtml(x) : option(xmlns) =
     match x : xhtml with
     | ~{text} -> {some = ~{text}}
     | ~{content_unsafe} -> {some = ~{content_unsafe}}
     | ~{fragment} ->
        match List.map_while_opt(of_xhtml,fragment) with
        | {none} -> {none}
        | {some=fragment} -> {some = ~{fragment}}
        end
     | {xml_dialect = {none}} as v -> {some = v}
     | {xml_dialect = {some=_}} -> {none}
     | ~{namespace tag args content xmlns specific_attributes={none}}
     | ~{namespace tag args content xmlns specific_attributes={some = {style=[] class=[] bool_attributes=[] events=[] events_options=[] href={none}}}} ->
        match List.map_while_opt(of_xhtml,content) with
        | {none} -> {none}
        | {some=content} ->
           {some = ~{namespace tag args content xmlns specific_attributes={none}}}
        end
     | {namespace=_ ...} -> {none}

   get_children(xml) =
   match xml : xml with
   | { xml_dialect=_ }
   | { text=_ }
   | { content_unsafe=_} -> []
   | { ~fragment } -> List.flatten(List.map(get_children,fragment))
   | { ~content ... } -> content


/*
   get_children_no_ws(x) =
     x |> get_children |> List.filter(x -> not(Xml.is_ws_node(x)),_)
*/

   /**
    * All the intermediate rules for the xmlns parser
    */
   /* identifiers */
   name_start = parser [a-zA-Z_] -> {}
   name_rest = parser [a-zA-Z_\-.0-9] -> {}
   name = parser v=(name_start name_rest*) -> Text.to_string(v)

   open_sign = parser "<" Rule.ws -> {}
   close_sign = parser Rule.ws ">" -> {}
   autoclose = parser Rule.ws "/" close_sign -> {}

   char_ref_raw = parser "&#" v=(v=Rule.natural -> v | "x" v=Rule.hexadecimal_number -> v) ";" -> v
   regroup_bytes =
   | [] -> ""
   | [h1|t] ->
     match (Cactutf.lenbytes(h1),t) with
     | ({some=1},t) -> Cactutf.cons(Cactutf.one_byte(h1)) ^ regroup_bytes(t)
     | ({some=2},[h2|t]) -> Cactutf.cons(Cactutf.two_bytes(h1,h2)) ^ regroup_bytes(t)
     | ({some=3},[h2,h3|t]) -> Cactutf.cons(Cactutf.three_bytes(h1,h2,h3)) ^ regroup_bytes(t)
     | ({some=4},[h2,h3,h4|t]) -> Cactutf.cons(Cactutf.four_bytes(h1,h2,h3,h4)) ^ regroup_bytes(t)
     | _ -> /* something is invalid */ "?" ^ regroup_bytes(t)
   /* the rule parses all the consecutive entities to be able to regroup them later */
   char_ref = parser intl=char_ref_raw+ -> regroup_bytes(intl)
   entity_name = parser "quot" -> "\""
                      | "amp" -> "&"
                      | "apos" -> "\'"
                      | "lt" -> "<"
                      | "gt" -> ">"
   xml_entity = parser "&" s=entity_name ";" -> s
   escape_sequence = parser s=char_ref -> s
                          | s=xml_entity -> s

   /* */
   svalue = parser v=svaluechars* -> Text.to_string(Text.ltconcat(v))
   svaluechars = parser s=escape_sequence -> Text.cons(s)
                      | s=(svaluechar+) -> s
   svaluechar = parser !['&] . -> {}

   dvalue = parser v=dvaluechars* -> Text.to_string(Text.ltconcat(v))
   dvaluechars = parser s=escape_sequence -> Text.cons(s)
                      | s=(dvaluechar+) -> s
   dvaluechar = parser ![\"&] . -> {}

   text = parser v=textchars+ -> Text.to_string(Text.ltconcat(v))
   textchars = parser s=escape_sequence -> Text.cons(s)
                    | s=(textchar+) -> s
                    | s=cdata -> s
   textchar = parser ![<&] . -> {}
   cdata = parser "<![CDATA[" s=((!"]]>" .)*) "]]>" -> s

   /* */
   open_tag =
      parser open_sign namespace=namespace tag=name Rule.ws ->
         ~{namespace tag}

   open_tag_attributes =
      parser nstag=open_tag args=attribute* ->
         ~{nstag args}
   close_tag =
      parser open_sign "/" Rule.ws namespace=namespace tag=name close_sign ->
         ~{namespace tag}

   /* */
   comment = parser "<!--" (!"-->" .)* "-->" -> {}

   /* attributes */
   equal = parser Rule.ws "=" Rule.ws -> {}
   attribute = parser
   | "xmlns:" ~name equal uri=arg_value Rule.ws -> ~{name uri}
   | "xmlns" equal uri=arg_value Rule.ws -> {default = uri}
   | n=namespace e=name equal v=arg_value Rule.ws -> {namespace=n name=e value=v}

   arg_value = parser "'" s=svalue "'" -> s
                    | "\"" s=dvalue "\"" -> s
   quoted_value(parser_) = parser "'"  v=parser_ "'"  -> v
                                | "\"" v=parser_ "\"" -> v

   /* tag */
   tag = parser
     | comment Rule.ws t=tag -> t
     | v1=open_tag_attributes v2=tail_open_tag {Rule.succeed_if(Xml.matching_tags(v1.nstag,v2.nstag))} ->
       {nstag=~{namespace tag} ~args} = v1
       ~{args xmlns} = List.fold_left(~{xmlns args}, arg ->
                                       match arg
                                       | {default=_} as x | {name=_ uri=_} as x -> {xmlns = [x | xmlns] ~args}
                                       | {namespace=_ name=_ value=_} as a -> {~xmlns args = [a | args]}
                                      , {xmlns=[] args=[]}, args)
       {~content nstag=_} = v2
       ~{namespace tag args content xmlns specific_attributes={none}}
       : xmlns

   tail_open_tag = parser autoclose -> {content=[] nstag={none}}
                        | close_sign content=node* nstag=close_tag -> ~{nstag={some=nstag} content}

   /* node */
   node = parser tag=tag -> tag
               | text=text -> ~{text}

   /* namespace */
   namespace = parser o=real_namespace? -> o ? ""
   real_namespace = parser t=name Rule.ws ":" -> t

   /* headers */
   document = parser prolog=prolog tag=tag misc* -> {header=prolog element=tag}

   prolog = parser decl=xmldecl? misc* (doctypedecl misc*)? -> decl ? {version = {none} encoding={none} standalone = {none}}
   xmldecl = parser "<?xml" f=versioninfo e=encodingdecl? s=sddecl? Rule.ws "?>" ->
               {version = {some = f}; encoding=e; standalone = s}
   versioninfo = parser Rule.strict_ws "version" equal v={quoted_value(versionnum)} -> v
   versionnum = parser t=("1." [0-9]+) -> Float.of_string(Text.to_string(t))
   encodingdecl = parser Rule.strict_ws "encoding" equal v={quoted_value(encname)} -> v
   encname = parser t=("UTF"~ "-8") -> Text.to_string(t)
                  | t=([A-Za-z] [A-Za-z0-9._\-]*) ->
                     enc = Text.to_string(t)
                     do Log.warning("xmlparser", "xml was declared with encoding {enc}, treating it as utf-8")
                     enc
   sddecl = parser Rule.strict_ws "standalone" equal b={quoted_value(yes_or_no)} -> b
   yes_or_no = parser "yes" -> {true}
                    | "no" -> {false}

   misc = parser comment -> {}
               | Rule.strict_ws -> {}
               | pi -> {}
   pi = parser "<?" s1=pitarget s2=(Rule.strict_ws t=(!"?>" .)* -> t) "?>" -> (s1,Text.ltconcat(s2))
   pitarget = parser !(xml (Rule.strict_ws | "?>")) s=name -> s
   xml = parser "XML"~ -> {}

   /* FIXME */
   doctypedecl = parser "<!DOCTYPE" doctypedecl_inside -> {}
   doctypedecl_inside = parser (![><] .)* ( "<!" doctypedecl_inside -> {}
                                          | ">" -> {}) -> {}

   /**
    * The main functions for parsing
    */
   parser_ = parser Rule.ws tag=tag Rule.ws comment? -> tag
   try_parse(s:string) : option(xmlns) = Parser.try_parse(parser_,s)
   parse_with_outcome(s:string) : outcome(xmlns,string) =
     match try_parse(s) with
     | {none} -> {failure = s}
     | ~{some} -> {success = some}
   try_parse_document(s:string) : option(xml_document) = Parser.try_parse(document,s)

  /**
   * A few utility functions for pattern matching
   */
  match_star_aux(pattern:XmlParser.t,xmls) =
    rec aux(acc,xmls) =
      match pattern.parse(xmls, pattern.env) with
      | {none} -> (List.rev(acc),xmls)
      | {some=(res,xmls)} -> aux([res|acc],xmls)
    aux([],xmls)
  match_star(pattern:XmlParser.t,xmls) =
    {some = match_star_aux(pattern,xmls)}
  match_question(pattern:XmlParser.t,xmls) =
    match pattern.parse(xmls, pattern.env) with
    | {none} -> {some = ({none}, xmls)}
    | {some=(res,xmls)} -> {some = ({some=res},xmls)}
  match_plus(pattern:XmlParser.t,xmls) =
    match pattern.parse(xmls, pattern.env) with
    | {none} -> none
    | {some=(hd_res,xmls)} ->
        (tl_res,xmls) = match_star_aux(pattern,xmls)
        {some = ([hd_res|tl_res],xmls)}
  match_range(pattern:XmlParser.t,min,max,xmls) =
    if max < 0 then {none} else
    over(min,acc,xmls) =
      if min <= 0 then
        {some = (List.rev(acc),xmls)}
      else
        {none}
    rec aux(min,max,acc,xmls) =
      if max == 0 then
        over(min,acc,xmls)
      else
        match pattern.parse(xmls, pattern.env) with
        | {none} -> over(min,acc,xmls)
        | {some=(res,xmls)} -> aux(min-1,max-1,[res|acc],xmls)
    aux(min,max,[],xmls)
  match_exact(pattern:XmlParser.t,number,xmls) =
    match_range(pattern,number,number,xmls)

  match_namespace(env:XmlParser.env, pns, xns) =
    get_uri(ns, ~{default map}) =
      match ns with
      | "" -> default
      | _ -> StringMap.get(ns, map) ? default
    String.equals(get_uri(pns, env.pbind), get_uri(xns, env.xbind))

  /**
   * The default namespace
   */
  default_ns_uri = ""

  serialize_to_string(xmlns: xmlns): string =
    xhtml = to_xhtml(xmlns)
    ~{js_code html_code} = Xhtml.prepare_for_export(xhtml,false)
    do @assert(js_code == "")
    html_code

}}

verbatim_expr(_)=""

/**
 * {1 Xml interface}
 */

/**
 * The functions that should go in that module are functions that are available
 * independently of the specificity of your xml
 * Thus, functions like to_string, or parse cannot appear in here
 */
Xml =
  {{
   /**
    * Returns a boolean saying if two tags match
    * The second namespace and tag are optional: they are none when saying <div/>
    */
  matching_tags(nstag1,nstag2o) =
    match nstag2o with
    | {none} -> {true}
    | {some=nstag2} -> nstag1 == nstag2

  create_fragment(fragment : list(xml)) : xml = ~{fragment}
  to_xml : xml -> xml = x -> x

   /**
    * A few functions used by the xml_parser generation pass
    */
  find_attr(args,namespace_,name_) =
    match List.find({~namespace ~name value=_} ->
                      name == name_ && namespace == namespace_, args)
    with
      | {none} -> {none}
      | {some = {~value ... }} -> {some = value}
    end

  /**
   * {2 Rule module}
   */

  Rule = {{
    integer = xml_parser parser v={@toplevel.Rule.integer} -> v
    float = xml_parser parser v={@toplevel.Rule.float} -> v
    string = xml_parser parser v={@toplevel.Rule.consume} -> v
    of_rule(r) = xml_parser parser v=r -> v
  }}

  // conversion from a list to xml + registering auto-magical conversion from list to xml
  @xmlizer(list('a)) list_to_xml(l) =
    create_fragment(List.map(XmlConvert.of_alpha, l))

  // conversion from an option to xml + registering auto-magical conversion from list to xml
  @xmlizer(option('a)) option_to_xml(o) =
    Option.switch(XmlConvert.of_alpha, <></>, o)

  // conversion from an iterator to xml + registering auto-magical conversion from iterator to xml
  @xmlizer(iter('a)) iterator_to_xml(i) =
    create_fragment(Iter.map(XmlConvert.of_alpha, i) |> Iter.to_list)

  /**
   *  Fold on every node of the xml
   *  @param the fold function
   *  @param the first element of the fold
   *  @param the xml to fold
   */
  fold(fun:(xml('a, 'b), 'c -> 'c), seed:'c, xml:xml): 'c =
    match xml with
    | { text=_ }
    | { content_unsafe=_ }
    | { xml_dialect=_ } -> seed
    | { ~fragment } -> List.foldl((el, acc -> fold(fun, acc, el) ), fragment, seed)
    | { ~content ... } as node ->
      res = fun(node, seed)
      List.foldl((el, acc -> fold(fun, acc, el) ), content, res)
    end

  /**
   *  Apply a transformation function to every element of the given xml
   *  @param the mapping function
   *  @param the xml to transform
   */
  map(fun:(xml('a,'b) -> xml('c,'d)), element:xml('a,'b)) : xml('c,'d) =
    rec aux(elt:xml('a,'b)) =
      match elt with
      | { text=_ }
      | { content_unsafe=_ }
      | { xml_dialect=_ } -> fun(elt)
      | { ~fragment } -> {fragment = List.map(aux, fragment) }
      | { ~content ... } as r ->
        content = List.map(aux, content) ;
        fun({r with content=content} <: xml )
    aux(element)

}}

/**
 * {1 Xml_parser interface}
 */
@abstract
type XmlParser.env = {
    /* Namespaces bindings of parser */
    pbind : XmlNsEnv.t;

    /* Namespaces bindings of xml tree */
    xbind : XmlNsEnv.t;
}

@opacapi
@abstract
type XmlParser.t('result, 'attributes, 'extensions) = {
    /* Parse function take a list of xml, and a map which contains namespaces
       bindings */
    parse : list(xml('attributes, 'extensions)), XmlParser.env
        -> option(('result, list(xml('attributes, 'extensions))))

    env : XmlParser.env
}

@opacapi
XmlParser_Env_add_pbinds = XmlParser.Env.add_pbinds
@opacapi
XmlParser_Env_add_xbinds = XmlParser.Env.add_xbinds
@opacapi
XmlParser_Env_p_get_uri = XmlParser.Env.p_get_uri
@opacapi
XmlParser_Env_x_get_uri = XmlParser.Env.x_get_uri
@opacapi
XmlParser_make = XmlParser.make
@opacapi
XmlParser_set_env = XmlParser.set_env
@opacapi
XmlParser_raw_parse = XmlParser.raw_parse

Xml_parser = XmlParser

XmlParser = {{

  Env = {{

    empty:XmlParser.env = {pbind = XmlNsEnv.empty xbind = XmlNsEnv.empty}

    add_pbinds(env:XmlParser.env, binds:list(Xml.binding)):XmlParser.env =
      {env with pbind = XmlNsEnv.add(env.pbind, binds)}

    add_xbinds(env:XmlParser.env, binds:list(Xml.binding)):XmlParser.env =
      {env with xbind = XmlNsEnv.add(env.xbind, binds)}

    p_get_uri(env:XmlParser.env, ns:string) = XmlNsEnv.get_uri(ns, env.pbind)

    x_get_uri(env:XmlParser.env, ns:string) = XmlNsEnv.get_uri(ns, env.xbind)
  }}

  flatten_and_discard_whitespace_aux(xml,acc) =
    match xml : xml with
    | ~{text} ->
       match Parser.try_parse(@toplevel.Rule.ws,text) with
      | {none} -> [xml|acc]
      | {some} -> acc
      end
    | ~{fragment} ->
      flatten_and_discard_whitespace_aux_list(fragment,acc)
    | _ -> [xml|acc]
  flatten_and_discard_whitespace_aux_list(xmls,acc) =
    List.foldl(flatten_and_discard_whitespace_aux,xmls,acc)

  flatten_and_discard_whitespace(xml) =
    List.rev(flatten_and_discard_whitespace_aux(xml,[]))

  flatten_and_discard_whitespace_list(xmls) =
    List.rev(flatten_and_discard_whitespace_aux_list(xmls,[]))

  make(parse:list(xml('attributes, 'extensions)), XmlParser.env -> option(('result, list(xml('attributes, 'extensions))))) =
   ~{parse env = Env.empty} : XmlParser.t

  set_env(p:XmlParser.t, env:XmlParser.env):XmlParser.t = {p with ~env}

  raw_parse(
    p:XmlParser.t('a, 'attributes, 'extensions),
    xml:list(xml('attributes, 'extensions))
  ) = p.parse(xml, p.env)

  try_parse(
    p:XmlParser.t('a, 'attributes, 'extensions),
    xml:xml('attributes, 'extensions)
  ) =
    match raw_parse(p, flatten_and_discard_whitespace(xml)) with
    | {none} -> none
    | {some=(result,_nodes)} -> {some=result}

}}

@abstract
type XmlNsEnv.t =
  { default : string map : stringmap(string) }


XmlNsEnv = {{

  empty:XmlNsEnv.t = {default = "" map = StringMap.empty}

  add(x:XmlNsEnv.t, binds:list(Xml.binding)):XmlNsEnv.t =
    List.fold_left(~{map default}, bind ->
      match bind with
      | ~{name uri} -> ~{default map=StringMap.add(name, uri, map)}
      | ~{default} -> ~{default map}
    , x, binds)

  get_uri(name:string, x:XmlNsEnv.t):string =
    if name == "" then x.default
    else StringMap.get(name, x.map) ? x.default

  try_get_uri(name, x:XmlNsEnv.t) =
    if name == "" then some(x.default)
    else StringMap.get(name, x.map)

}}

/**
 * {1 XmlConvert interface}
 */

/**
 * Create xml representation of some basic type
 */
XmlConvert = {{

  /**
   * Return the xml representation of any value
   */
  of_alpha_with_ty(original_ty, value) =
    rec aux(value, ty : OpaType.ty) =
      match ty with
      | {TyName_ident = "xml"; ...} | {TyName_ident = "xhtml"; ...} ->
          Magic.id(value)
      | {TyName_ident = "text"; ...} ->
          XmlConvert.of_string(Text.to_string(Magic.id(value)))
      | {TyConst = {TyInt}} -> XmlConvert.of_int(Magic.id(value))
      | {TyConst = {TyFloat}} -> XmlConvert.of_float(Magic.id(value))
      | {TyConst = {TyString}} -> XmlConvert.of_string(Magic.id(value))
      | {TyName_ident = "list";
         TyName_args =
           [{TyName_ident = "xhtml"; TyName_args = (_ : list(OpaType.ty)) }]} ->
          Xml.create_fragment(Magic.id(value))
      | {TyName_ident = "list";
         TyName_args =
           [{TyName_ident = "xml"; TyName_args = (_ : list(OpaType.ty)) }]} ->
          Xml.create_fragment(Magic.id(value))
      | {TyName_args = args; TyName_ident = ident} ->
        OpaValue.todo_magic_container(
          %%BslValue.MagicContainer.xmlizer_get%%,
          ident, args,
          aux(_, OpaType.type_of_name(ident, args)),
          value, [])
      | ty ->
        if OpaTypeUnification.is_unifiable(ty, @typeval(xhtml)) then
          Magic.id(value)
        else if OpaTypeUnification.is_unifiable(ty, @typeval(list(xhtml))) then
          Xml.create_fragment(Magic.id(value))
        else if OpaTypeUnification.is_unifiable(ty, @typeval(list(xml))) then
          Xml.create_fragment(Magic.id(value))
        else {text = "Can't make an xml with {ty}"}
    aux(value, original_ty)
  : xml

  of_alpha(value) = of_alpha_with_ty(@typeof(value), value)

  /**
   * Return the xml representation of a string
   */
  of_string(text) : xml = ~{text}

  /**
   * Return the xml representation of an integer
   */
  of_int(i) = of_string(Int.to_string(i))

  /**
   * Return the xml representation of a float
   */
  of_float(f) = of_string(Float.to_string(f))

  /**
   * Convert a boolean to a xhtml representation.
   *
   * @return [<>true</>] or [<>false</>]
   */
  of_bool(b: bool)  = of_string(Bool.to_string(b))

  /**
   * Convert [void] to a XHTML representation
   *
   * @return [<>\{\}</>]
   */
  of_void(u) = of_string(Void.to_string(u))

  /**
   * Convert a list of XHTML fragments to a single XHTML fragment
   *
   * @return [<>{beg_symbol}{x_1}{sep_symbol}...{sep_symbol}{x_n}{end_symbol}</>]
   */
  of_list_using(beg_symbol, end_symbol, sep_symbol, l) =
    List.compose((x, y -> <>{x}{y}</>), beg_symbol, end_symbol, sep_symbol, l)

}}

/**
 * {1 Xhtml interface}
 */

/**
 * This module regroups only xhtml specific functions
 * If you want a function that could be defined in Xml instead
 * then define it in Xml and make an alias in this module
 */
Xhtml =
{{

  /**
   * Escapes every html special characters of the given string with &#xxx;
   *
   * Note: You shouldn't use it by yourself except if you want to insert an
   * unsafe html node, and if you be aware of XSS risk.
   */
  escape_special_chars =
    String.replace_char(_,
      (| '&' | '\"' | '\'' | '<' | '>' -> true | _ -> false),
      (c -> "&#{c};")
    )

  default_attributes = {style=[] class=[] bool_attributes=[] events=[] events_options=[] href={none}} : xhtml_specific_attributes

  createFragment : list(xhtml) -> xhtml = Xml.create_fragment

  to_xhtml(xhtml_: xhtml) = xhtml_

  /**
   * Convert an XHTML tree to is client-side Dom representation.
   *
   * Some browsers handle CSS in weird and unexpected ways. Consequently, we cannot apply the styles already.
   * Rather, we collect the styles, then store them in a OPA-specific hidden attribute of the Dom representation.
   * We only apply the CSS when putting the Dom inside the browser document.
   */
  to_dom(xhtml: xhtml) = Dom.from_xhtml(xhtml)

  to_text(xhtml: xhtml) =
    rec fold(src, acc) = List.fold((i, a -> a^aux(i, "")), src, acc)
    and aux(x, a) = match x: xhtml with
      | { ~fragment } -> fold(fragment, a)
      | { tag=_; ~content; ... } -> fold(content, a)
      | { text = t} -> t
      | _ -> error("Xhtml.to_text: Not Fully Implemented")
    aux(xhtml, "")

  of_string : string -> xhtml = XmlConvert.of_string
  of_string_unsafe(text:string): xhtml = { content_unsafe = text }

  //Private functions, they should move
  @private
  default_href = sassoc_full("", "href", "javascript:void(0)")
  @private
  default_alt  = sassoc_full("", "alt", ".")
  @private
  sanitized_uri= "javascript:void(0)/*Sanitized URI*/"

  @private
  exists_attr(attr, list: list(Xml.attribute)): bool =
    oracle(i:Xml.attribute) = i.name == attr
    List.exists(oracle, list)

  @private
  find_attr(attr, list: list(string_assoc(string))): option(string) =
    oracle(i:{name:string; namespace: string; value:string}) =
      if i.name == attr then some(i.value) else none
    List.find_map(oracle, list)

  @private
  remove_attr(attr, list: list(string_assoc(string))): list(string_assoc(string)) =
    oracle(i:Xml.attribute) = i.name == attr
    List.remove_p(oracle, list)

  @private
  iter_tell_me_if_i_am_last(f: 'a,bool -> void, l: list('a)):void =
    rec aux =
      | [hd ] -> f(hd, true)
      | [hd | tl] -> do f(hd, false); aux(tl)
      | [] -> void ;
    aux(l)

   _script_start = "\n<script type=\"text/javascript\">//<![CDATA[\n"
   _script_end   = "\n//]]>\n</script>\n"
//   _script_start = "\n<script type=\"text/javascript\">//<![CDATA[\n(function()\{var js_onready = function() \{var element = document.createElement(\"script\");var content = document.createTextNode(\"";
//   _script_end   = "\"); document.body.appendChild(element);}; if (window.addEventListener) window.addEventListener(\"load\", js_onready, false); else if (window.attachEvent) window.attachEvent(\"onload\", js_onready); else window.setTimeout(js_onready, 500);\})()\n//]]>\n</script>\n"



  /**
   * The URI for the XHTML namespace
   */
  ns_uri = "http://www.w3.org/1999/xhtml"
  @private sassoc_full(namespace, name, value) : Xml.attribute = ~{ namespace name value }

  /**
   * Convert a xhtml structure into a string, assuming utf-8 encoding
   */
  to_string = serialize_to_string

  @private
  JsEvent = {{

    filter_unsafe_inline(f)(v) =
      if is_safe_inline_event(v.name)
      then
        str = inline_content(v.value)
        if is_safe_inline_content(str) then
             do f(Dom.Event.get_name(v.name),str):void
             false
        else
             true
      else
        true

    inline_handler(eventname,content) = " on{eventname}='{content}'"

    inline_content =
    | ~{value} -> value
    | ~{expr}  -> FunAction.serialize(expr)

    /* stay sync with jquery.(mlstate)bind */
    is_safe_inline_event =
    | {click} -> true
    | {keydown} -> false // jquery normalisation
    | _ -> false

    /*
      false = {}
      true  = {v}
      none = {}
      some(a)  = {v:a}
    */
    is_safe_inline_content(s) =
     match Parser.try_parse(check,s)
     {some} ->
       // do println("is_safe_inline_content ACCEPTED")
       true
     {none} ->
       // do println("is_safe_inline_content REJECTED {s} at {Parser.partial_parse(debug_check,s)}\n")
       false

    // CAUTION: the check accept only a very restricted set of chars, take care when extending to not introduce security problem
    // the checked string is delimited by ', hence ' is not in the accepted chars set
    // e.g. the string f("\"'onready=\"alert(\"toto\")\"") could cause a js injection on some browser
    // < and > should not be in the set
    // typical event handler is a function call with args that are only datatype (no code)
    // * / are here in case of comments
    check = parser
    | [-_A-Za-z()\"0-9:.,\n\t{}*/]* -> void
    debug_check = parser s=(check) -> s

  }}

  @both_implem new_id = String.fresh(200)

  @private
  serialize_xmlns(buffer, xmlns) =
    List.iter(
      | ~{name uri} ->
        do Buffer.append(buffer, " xmlns:")
        do Buffer.append(buffer, name)
        do Buffer.append(buffer, "=\"")
        do Buffer.append(buffer, uri)
        do Buffer.append(buffer, "\"")
        void
      | ~{default} ->
        do Buffer.append(buffer, " xmlns=\"")
        do Buffer.append(buffer, default)
        do Buffer.append(buffer, "\"")
        void
      , xmlns
    )

 /**
   * Convert a [xhtml] subtree to a pair of strings containing the html proper and the corresponding JS code.
   *
   * Note that event handlers and inline styles are extracted from the html and inserted as JS code, as this
   * lets us delegate the handling of browser incompatibilities to the JS library. For instance, our JS
   * library can determine dynamically of the browser calls the CSS [float] property as [cssFloat] or [styleFloat].
   * Also, setting event handlers from JS code is both the modern way of doing things, and the orthogonal
   * way of managing extensions to Dom events, e.g. "onmousewheel", "onnewline", "onready", etc.
   *
   * @param namespace_map A map from uris to the its identifier in the serialized xhtml
   *                      used to have a predictable name of a given uri, as is needed for facebook
   *                      (if you don't put <fb:sometag xmlns:fb="..."> but <plop:sometag xmlns:plop="...">
   *                       it doesn't work)
   * @param xhtml A xhtml {e subtree}, anything that can be inserted inside the [head] or the [body] --
   * {e without the tag}. Do not pass anything larger to this function, or the result will be meaningless
   * for some browsers.
   * @return [~{js_code html_code}], where [html_code] contains the complete structure of the subtree
   * (i.e. the tags) and [js_code] contains the event handlers and the style information as a JS
   * string.
   */
  prepare_for_export(xhtml: xhtml, style_inline : bool): {js_code: string; html_code:string} =
  (
    html_buffer = Buffer.create(1024)//A buffer for storing the HTML source code
    js_buffer   = Buffer.create(1024)//A buffer for storing the JS source code -- at the last step, it is inserted in [html_buffer]
    jsappend_event_handler(x: xhtml_event) =
      code = match x with
        | { ~value } -> value
        | { ~expr  } -> FunAction.serialize(expr)
      Buffer.append(js_buffer,code)
    /**
     * @param depth The current depth in the tree. Used both for pretty-printing and to insert scripts at the correct place
     */
    rec handle_xhtml(xhtml: xhtml, depth:int) =
      next = depth + 1 //next depth
      match xhtml with
      | ~{ text }            -> Buffer.append(html_buffer,escape_special_chars(text))
      | ~{ content_unsafe }  -> Buffer.append(html_buffer,content_unsafe)
      | ~{ fragment }        -> List.iter(x -> handle_xhtml(x, depth), fragment)
      | ~{ xml_dialect }     ->
        match xml_dialect with
            | {none} -> void
            | {some = ~{js_code_unsafe html_code_unsafe}} ->
                  do Buffer.append(html_buffer,html_code_unsafe)
                  Buffer.append(js_buffer,js_code_unsafe)
        end
      | ~{ namespace tag args content specific_attributes xmlns } ->

          tag =
            if String.is_empty(namespace) then tag else
            namespace ^ ":" ^ tag

          //Start handling the tag itself
          do Buffer.append(html_buffer,"<")
          do Buffer.append(html_buffer,tag)

          do serialize_xmlns(html_buffer, xmlns)

          //Handle regular attributes
          print_arg(~{name namespace=tagns value}) =
            do Buffer.append(html_buffer," ")
            do if String.is_empty(tagns) then Buffer.append(html_buffer,name)
               else
                 do Buffer.append(html_buffer,tagns)
                 do Buffer.append(html_buffer,":")
                 Buffer.append(html_buffer,name)
            do Buffer.append(html_buffer,"=\"")
            do Buffer.append(html_buffer,escape_special_chars(value))
            Buffer.append(html_buffer,"\"")

          do List.iter(print_arg,args)

          do match specific_attributes with
             | {none} -> void
             | {some=~{class style bool_attributes events events_options href}} ->
          //Normalize tags
               do (
                 match tag with
                   | "img" ->    //Add a default [alt] attribute to <img> tags that don't have one
                      if not(exists_attr("alt", args))  then print_arg(default_alt)
                   | "a" | "area"  ->    //Transform xhtml-specific attribute [href] into a string
                      // Should match tag_specific_a in opalang/syntax/xml.trx
                     replacement = match href
                      | {none}     ->
                         // Hack around incorrect [Xml.to_xhtml]
                         // TODO: We should rather implement a new, safe Xml.to_xhtml
                         find_attr("href",args)
                      | ~{constant}-> {some = constant}
                      | ~{untyped} -> //Here, insert dynamic filter through uri parser
                         if Uri.is_secure(untyped) then {some = untyped} //URI was accepted, return original URI
                         else {some = sanitized_uri} //URI was rejected, replace by default URI
                      | ~{typed}   -> {some = Uri.to_string(typed)}//Here, insert URI serialization
                     end
                     match replacement with
                      | {none} -> print_arg(default_href) //Add a default [href] attribute to <a> tags that don't have one
                      | ~{some}-> print_arg(sassoc("href", some))
                     end
                   | _ -> void
               )

               do List.iter(~{name value} ->
                  match value with
                  | {string=value} -> print_arg(sassoc(name,value))
                  | {bool=b} -> if b then print_arg(sassoc(name,name)) else void
                  | {none} -> print_arg(sassoc(name,name))
                  end,
                  bool_attributes)

               (load_events, other_events) = List.partition((a -> match a.name:Dom.event.kind {ready} -> true | _ -> false), events)
               (_,   other_events_options) = List.partition((a -> match a.name:Dom.event.kind {ready} -> true | _ -> false), events_options)

               other_events = // take care of event handler that can be inlined in html attribute
                 if XhtmlOptions.options.enable_inlined_event then
                   safe_inline(eventname,content) =
                     Buffer.append(html_buffer,JsEvent.inline_handler(eventname,content))
                   List.filter(JsEvent.filter_unsafe_inline(safe_inline), other_events)
                 else
                   other_events

               //Handle events and style: start
               do (if other_events == [] && other_events_options == [] && style == [] then void
                      else  //We need an ID for this node, to be able to attach event handlers
                         id = match find_attr("id", args) with
                            | ~{some} -> some
                            | {none}  ->
                               id = new_id()
                               do print_arg(sassoc("id", id))
                               id
                         end
                         //Now, generate jQuery-specific code in the jsbuffer, as a chain of JS dot calls on the item
                         do Buffer.append(js_buffer,"\n$('#")
                         do Buffer.append(js_buffer,Dom.escape_selector(id))
                         do Buffer.append(js_buffer,"')\n")

                         //Handle style -- generate a call to jQuery function [css]
                         do if style == [] then void
                            else
                              css_as_list = Css_printer.to_xhtml_style(style)
                              if css_as_list != [] then
                                /* if we printed when css_as_list is empty the css({ would not be closed })*/
                                if style_inline // style_inline is used e.g. for emails
                                then
                                  do Buffer.append(html_buffer," style=\"")
                                  iter_tell_me_if_i_am_last((~{name value}, last ->
                                    do Buffer.append(html_buffer,name)
                                    do Buffer.append(html_buffer,":")
                                    do Buffer.append(html_buffer,value)
                                    if last then Buffer.append(html_buffer,"\"")
                                    else Buffer.append(html_buffer,"; ")),
                                    css_as_list
                                  )

                                else
                                  do Buffer.append(js_buffer,".css(\{  ")
                                  iter_tell_me_if_i_am_last((~{name value}, last ->
                                    do Buffer.append(js_buffer,"'")
                                    do Buffer.append(js_buffer,name)
                                    do Buffer.append(js_buffer,"': '")
                                    do Buffer.append(js_buffer,value)
                                    if last then Buffer.append(js_buffer,"'})\n")
                                    else Buffer.append(js_buffer,"', ")),
                                    css_as_list
                                  )

                         //Handle non-inlined, non-ready events
                         do (List.iter(_,other_events)){
                            ~{name value} -> //Generate    [.name(function(event({<<serialize_event_handler(value)>>})))]
                            name = Dom.Event.get_name(name)
                            content = JsEvent.inline_content(value)
                            add = ".bind('{name}',(function(event)\{{content}\}))\n"
                            Buffer.append(js_buffer,add)
                         }
                         //Handle non-inlined non-ready events options
                         do (List.iter(_,other_events_options)){
                            {name=handle value=options} -> //Generate    [.name(function(event({<<serialize_event_handler(value)>>})))]
                            stop_propagation = List.exists(_ == {stop_propagation}, options)
                            prevent_default  = List.exists(_ == {prevent_default},  options)
                            if(stop_propagation || prevent_default) then
                               name = Dom.Event.get_name(handle)
                               stop_propagation = if stop_propagation then "event.stopPropagation();" else ""
                               prevent_default  = if prevent_default  then "event.preventDefault();"  else ""
                               add = ".bind('{name}',(function(event)\{{stop_propagation}{prevent_default}\}))\n"
                               Buffer.append(js_buffer,add)
                         }

                         //Finally, return args with id
                         void
                 )

                 do List.iter(~{name value} ->
                    match name with
                      | {ready} ->
                              do Buffer.append(js_buffer,"\n$(function()\{var event = {JsInterface.default_opa_event};")//In jQuery, the first argument of the callback is [$] itself -- replace by default event
                              do jsappend_event_handler(value)
                              do Buffer.append(js_buffer,"\});")
                              void
                      | _ -> error("[Xhtml.prepare_for_export] Internal error in xhtml serialization -- at this stage, all events other than [ready] should have been prepared")
                    end,
                    load_events)

               //Handle events and style: end

               //Handle classes
               do match class with
                  | [] -> void
                  | [name|t] ->
                    do Buffer.append(html_buffer," class=\"")
                    do Buffer.append(html_buffer,name)
                    do List.iter((name -> do Buffer.append(html_buffer," ") Buffer.append(html_buffer,name)),t)
                    Buffer.append(html_buffer,"\"")

             void

          //Handle children
          do if content == [] && //Auto-close auto-closing tags
                (match tag with
                | "abbr" | "br" | "col" | "img" | "input" | "link" | "meta" | "param" | "hr" | "area" | "embed" -> true
                | _ -> false)
             then
               Buffer.append(html_buffer,"/>")
             else
               do if depth == 0 then
                 // saving the current content of the buffer
                 start = Buffer.contents(html_buffer)
                 do Buffer.clear(html_buffer)
                 // need to first look at the children,
                 // or else we won't have all their namespaces
                 do List.iter(x -> handle_xhtml(x, next), content)
                 content = Buffer.contents(html_buffer)
                 do Buffer.clear(html_buffer)
                 // putting back everything into the buffer
                 do Buffer.append(html_buffer,start)
                 do Buffer.append(html_buffer,">")
                 Buffer.append(html_buffer,content)
               else
                 do Buffer.append(html_buffer,">")
                 List.iter(x -> handle_xhtml(x, next), content)
               do Buffer.append(html_buffer,"</")
               do Buffer.append(html_buffer,tag)
               do Buffer.append(html_buffer,">")
               void
          void
   end

   do handle_xhtml(xhtml, 0)
   //Now, insert the script
   //We surround everything by a CDATA -- which has an effect in xhtml but not in html
   //We replace each '>', which we assume cannot be a javascript token at this place,
   //  (so it happens only in a string) by its utf escaped counterpart
   //  to prevent both accidental termination via '</script>' tag (when CDATA is not
   //  operative as in html) or accidental termination of CDATA, ']]>'.

   js_code =
     str = Buffer.contents(js_buffer)
     str = String.replace(">", "\\076", str)
     str
   {js_code = js_code;
    html_code = Buffer.contents(html_buffer)}
 )

 /**
  * Convert xhtml to a readable text
  */
  to_readable_string(xhtml: xhtml): string =
  (
    html_buffer = Buffer.create(1024)//A buffer for storing the HTML source code
    // indent(n) = Buffer.append(html_buffer,String.make(n," "))
    rec handle_xhtml(xhtml: xhtml, depth:int) =
      next = depth + 1 //next depth
      match xhtml with
      | ~{ text }            ->
        Buffer.append(html_buffer,text)
      | { content_unsafe=_ }  -> void
      | ~{ fragment }        ->
        List.iter(x -> handle_xhtml(x, depth), fragment)
      | { xml_dialect=_ }     -> void
      | { namespace=_ ~tag ~args ~content ~specific_attributes xmlns=_ } ->
        match tag with
        | "img" ->
          match find_attr("alt",args) with
            | {none} -> void
            |~{some} -> do Buffer.append(html_buffer,"[") do Buffer.append(html_buffer,some) Buffer.append(html_buffer,"]")
          end
        | "a"   ->    //Transform xhtml-specific attribute [href] into a string
          match specific_attributes with
            | {none} -> void
            |~{some} ->
              href = match some.href with
                | {none} -> find_attr("href",args)
                | ~{constant}-> {some = constant}
                | ~{untyped} -> //Here, insert dynamic filter through uri parser
                   if Uri.is_secure(untyped) then {some = untyped} //URI was accepted, return original URI
                   else {none}
                | ~{typed}   -> {some = Uri.to_string(typed)}//Here, insert URI serialization
              end
              match href with
                | {~some} -> do Buffer.append(html_buffer,"[") do Buffer.append(html_buffer,some) do Buffer.append(html_buffer," | ") do List.iter(handle_xhtml(_,depth),content) Buffer.append(html_buffer,"]")
                | {none} -> List.iter(handle_xhtml(_,depth),content)
              end
          end
        | "h1" | "h2" | "h3" | "h4" | "h5" | "h6" ->
          do Buffer.append(html_buffer,"\n") do List.iter(handle_xhtml(_,depth),content) Buffer.append(html_buffer,"\n")
        | "div"| "p"| "pre"| "blocknote"| "adress" ->
          do Buffer.append(html_buffer,"\n") do List.iter(handle_xhtml(_,depth),content) Buffer.append(html_buffer,"\n")
        | "ul"|"ol"|"dl"|"dir"|"menu" ->
          do Buffer.append(html_buffer,"\n") do List.iter(handle_xhtml(_,next),content) Buffer.append(html_buffer,"\n")
        | "li"|"dt" ->
          do Buffer.append(html_buffer,"- ") do List.iter(handle_xhtml(_,depth),content) Buffer.append(html_buffer,"\n")
        | "br" ->
          Buffer.append(html_buffer,"\n\n")
        | "hr" -> Buffer.append(html_buffer,"\n---------------------------\n")
        | "b" | "i" | "span" | "acronym" | "cite" | "q" | "sup" | "sub" | "strong" | "em"
        | "del" | "ins" | "dfn" | "kbd"->
          List.iter(handle_xhtml(_,depth),content)
        | "html" | "body" ->
          List.iter(handle_xhtml(_,depth),content)
        | _ -> void
        end
    end
    do handle_xhtml(xhtml, 0)
    Buffer.contents(html_buffer)
  )

  /**
    * Same with xhtml fields instead of string
    */
  prepare_for_export_as_xml_blocks(xhtml: xhtml) =
    ~{html_code js_code} =  prepare_for_export(xhtml,false)
    html = of_string_unsafe(html_code)
    js   = of_string_unsafe(js_code)
    ~{html js}

  prepare_for_export_as_xml_blocks_non_utf8(xhtml: xhtml) =
    ~{html_code js_code} =  prepare_for_export(xhtml,false)
    html = of_string_unsafe(html_code)
    js   = of_string_unsafe(js_code)
    ~{html js}

  /** Same as to_string */
  serialize_to_string(xhtml: xhtml): string =
  (
    ~{js_code html_code} = prepare_for_export(xhtml,false)
    if String.is_empty(js_code) then html_code
    else
      String.flatten([html_code,_script_start,js_code,_script_end])
  )

  /** Same as to_string but without js_code */
  serialize_as_standalone_html(xhtml: xhtml): string =
    {js_code=_ ~html_code} = prepare_for_export(xhtml,true)
    html_code

  /**
   * Precompile a html fragment into a form that will be faster to transmit and insert.
   *
   * @return a dialect of html designed for this purpose
   */
  precompile(xhtml: xhtml): xhtml =
   {html_code=html_code_unsafe js_code=js_code_unsafe} = prepare_for_export(xhtml,false)
   {xml_dialect = some(~{html_code_unsafe js_code_unsafe})}


  /**
   * Perform the finalization of the js by encapsulation in a secured script construction
   * to be used with [prepare_for_xhtml_export]
   */
  finalize_js_inline(js:xhtml):xhtml =
    match compile(js)
    {text=""} {content_unsafe=""} {fragment=[]} -> empty_xhtml
    _ -> {fragment = [of_string_unsafe(_script_start), js, of_string_unsafe(_script_end)]}

  /**
   * Perform the final compilation of a html fragment.
   *
   * You should never need this function, except if you're tweaking the generation of the original web page.
   * @return a string fit to be sent to the browser
   */
  compile(xhtml: xhtml): xhtml =
     { content_unsafe = serialize_to_string(xhtml) }

  // Should put binds on the first encountred element
  add_binds(list : list(handle_assoc(xhtml_event)), o : xhtml) = match o with
    | { ~specific_attributes ... } as r ->
      attr = Option.default(default_attributes,specific_attributes)
      attr = {attr with events= list ++ attr.events}
      @opensums({r with specific_attributes={some=attr}}) : xhtml
    | _ -> error("add_binds: not fully implemented")

  @private id_attr = "id"

  /**
   * Get the main id of the xhtml value
   * Will fail if no id or if several id are possible
   */
  get_id(x):option(string)=
    match x : xhtml
    {fragment=[x]} -> get_id(x)
    {~args ...} -> find_attr(id_attr,args)
    _ -> none
    end

  /**
   * Add an id to the xhtml when it is not already defined,
   * When the future position of the id is not clear (several possible node), it encapsulated everything in a div
   */
  add_id(id,x:xhtml):xhtml =
    id = id ? new_id()
    // aux(id, x) with
    rec aux(id,x)=
    match x : xhtml
    {fragment=[x]} -> aux(id,x)
    {text=_}{content_unsafe=_} -> <div id={id}>{x}</div>
    {~args ...} as x->
      args = if exists_attr(id_attr,args) then args
             else [{name=id_attr namespace="" value=id}|args]
      @opensums({x with ~args})
    _ -> <div id={id}>{x}</div>
    end
    aux(id,x)

  @private add_class(value: string, x:xhtml):xhtml =
    rec aux(value,x)=
    match x : xhtml
    {fragment=[x]} -> aux(value,x)
    {text=_}{content_unsafe=_} -> <div class="{value}">{x}</div>
    {~specific_attributes ...} as x ->
      specific_attributes = specific_attributes ? default_attributes
      specific_attributes = some({ specific_attributes with class = specific_attributes.class ++ [value] })
      @opensums({x with ~specific_attributes})
    _ -> <div class="{value}">{x}</div>
    end
    aux(value,x)

  @private add_href(value: string, x:xhtml):xhtml =
    rec aux(value,x)=
    match x : xhtml
    {fragment=[x]} -> aux(value,x)
    {~specific_attributes ...} as x ->
      specific_attributes = specific_attributes ? default_attributes
      specific_attributes = some({ specific_attributes with href = {untyped=value} })
      @opensums({x with ~specific_attributes})
    _ -> x
    end
    aux(value,x)

  @private add_style_from_string(value: string, x:xhtml):xhtml =
    rec aux(value,x)=
    match x : xhtml
    {fragment=[x]} -> aux(value,x)
    {~specific_attributes ...} as x ->
      aux2(acc, s) =
        match String.explode(":", s)
        [k,v] ->
          key = String.strip(k)
          value = String.strip(v)
          [{not_typed=(key, value)}|acc]
        _ -> acc
        end
      styles = List.fold_left(aux2, [], String.explode(";", value))
      specific_attributes = specific_attributes ? default_attributes
      specific_attributes = some({ specific_attributes with style = (specific_attributes.style ++ styles) })
      @opensums({x with ~specific_attributes})
    _ -> x
    end
    aux(value,x)

  @private gen_add_attribute(name: string, value: string, x:xhtml, append:bool):xhtml =
    match name
    | "class" -> add_class(value, x)
    | "href" -> add_href(value, x)
    | "style" -> add_style_from_string(value, x)
    | _ ->
      rec aux(x)=
      match x : xhtml
      {fragment=[x]} -> aux(x)
      {~args ...} as x->
        args = match find_attr(name,args) with
               {some=val} ->
                 if not(append) then args
                 else
                   value = "{val} {value}"
                   args = remove_attr(name,args)
                   [{~name namespace="" ~value}|args]
               {none} -> [{~name namespace="" ~value}|args]
        @opensums({x with ~args})
      _ -> x
      end
      aux(x)

  /**
   * Add an attribute to an xhtml node if not already defined
   */
  add_attribute_unsafe(name: string, value: string, x:xhtml):xhtml =
    gen_add_attribute(name, value, x, false)

  /**
   * Update (by appending) an attribute to an xhtml node, add it if not already present
   */
  update_attribute_unsafe(name: string, value: string, x:xhtml):xhtml =
    gen_add_attribute(name, value, x, true)

  /**
   * Set an attribute to an xhtml node. Replace if already_exists
   */
  set_attribute_unsafe(name: string, value: string, x:xhtml):xhtml =
    // aux(id, x) with
    rec aux(x)=
    match x : xhtml
    {fragment=[x]} -> aux(x)
    {~args ...} as x->
      args =
        l = remove_attr(name,args)
        [{~name namespace="" ~value}|l]
      @opensums({x with ~args})
    _ -> x
    end
    aux(x)

   /**
   * Remove an attribute from an xhtml node.
   */
  remove_attribute(name: string, x:xhtml):xhtml =
    // aux(id, x) with
    rec aux(x)=
    match x : xhtml
    {fragment=[x]} -> aux(x)
    {~args ...} as x->
      args = remove_attr(name,args)
      @opensums({x with ~args})
    _ -> x
    end
    aux(x)

  /**
   * Add a title attribute to an xhtml node.
   * No verification on wether the xhtml supports title attribute is made
   */
  add_title(t:string, x:xhtml) : xhtml = Xhtml.add_attribute_unsafe("title", t, x)

  /**
   * Add/Update ths class attribute of an xhtml node, by appending a certain class.
   * No verification on wether the xhtml supports class attribute is made
   */
  update_class(c:string, x:xhtml) : xhtml = Xhtml.update_attribute_unsafe("class", c, x)

  /**
   * Add style to the xhtml (added to pre-exiting style)
   * When the future position of the style is not clear (several possible node), it encapsulated everything in a div
   */
  add_style(style,x):xhtml =
   match x : xhtml
    {fragment=l} -> {fragment=List.map(add_style(style,_),l)}
    {text=_}{content_unsafe=_} -> <div style={style}>{x}</div>
    {specific_attributes=sa ...} as x->
      sa = sa ? default_attributes
      style = style ++ sa.style
      specific_attributes = some({sa with ~style})
      @opensums({x with ~specific_attributes})
    _ -> <div style={style}>{x}</div>

  /**
   * Add a onready event the xhtml
   * NEED TO DETAIL BEHAVIOR IF onready ALREADY EXISTING
   * DOES NOT WORK ON SERVER SIDE UNTIL CLOSURE SERIALIZATION IS WORKING AND USED ON XHTML
   */
  add_onready(f,x):xhtml =
   match x : xhtml
    {content_unsafe=_}
    {text=_} -> <div onready={f}>{x}</div>
    {fragment=[]} -> <div onready={f}></div>
    {fragment=[x|l]} -> x = add_onready(f,x)
                        {fragment=[x|l]}
    {specific_attributes=sa ...} as x->
      sa = sa ? default_attributes
      events = [{name={ready} value={expr=f}}|sa.events]
      specific_attributes = some({sa with ~events})
      @opensums({x with ~specific_attributes})
    _ -> <div onready={f}>{x}</div>

  /**
   * Serializer for xhtml data structures.
   * Provides a standard serialization but on server side,
   * unserialization checks and replaces unsafe fields by default
   * values.
   */
  @both_implem @serializer(xhtml) serializer =
    ximpl = OpaType.implementation(@typeval(xhtml))
    {
      f1 = OpaSerialize.partial_serialize_options(_, ximpl, _)
      f2 = json -> @sliced_expr({
        client = OpaSerialize.finish_unserialize(json, ximpl)

        server =
          check_args =
            List.map({namespace=_ ~name ~value} as a ->
              match String.has_prefix("on", name)
              | {true} ->
                do Log.warning("Xhtml",
"Attribute {name} can be an event handler and contains an unsafe string :
{value}
Replaced by a default value.")
                {a with value="/*unsafe attribute from a client*/"}
              | _ -> a
              , _)
          check_sargs({class=_ style=_ bool_attributes=_ ~events events_options=_ href=_} as a) =
            { a with events = List.map(
              | ~{name value=~{value}} ->
                do Log.warning("Xhtml",
"Receiving from a client an unsafe specific attribute {name} :
{value}
Replaced by a default value.")
                ~{name value={value="/*unsafe specific attribute from a client*/"}}
              | _ as a -> a
              , events)
            }
          Option.map(
            | ~{content_unsafe} ->
              do Log.warning("Xhtml",
"Receiving from client unsafe content of xhtml :
{content_unsafe}.
Replaced by a default value.")
              {text = "unsafe content from a client"} : xhtml
            | {namespace=_ tag=_ ~args content=_ ~specific_attributes xmlns=_} as e->
              @opensums({e with args=check_args(args) specific_attributes=Option.map(check_sargs, specific_attributes)}) : xhtml
            | _ as safe -> safe
            ,  OpaSerialize.finish_unserialize(json, ximpl))
        })
    }

}}

/* Functions used by xml pattern matching */
@opacapi Xml_find_attr = Xml.find_attr
@opacapi Xml_match_star = Xmlns.match_star
@opacapi Xml_match_plus = Xmlns.match_plus
@opacapi Xml_match_question = Xmlns.match_question
@opacapi Xml_match_number = Xmlns.match_exact
@opacapi Xml_match_range = Xmlns.match_range
@opacapi Xml_match_namespace = Xmlns.match_namespace


// Cannot be in Uri.uri module due to dependencies on this package
@xmlizer(Uri.uri) uri_to_xml(u : Uri.uri) =
  <>{"{u}"}</>