Source file xml.ml

(*********************************************************************************)
(*                Xtmpl                                                          *)
(*                                                                               *)
(*    Copyright (C) 2012-2021 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    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 Library 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., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*                                                                               *)
(*********************************************************************************)

(** *)

module U = Sedlexing.Utf8

module SMap = Map.Make(String)

type Types.error += Parse_error of Types.loc * string
let parse_error loc msg = Types.error (Parse_error (loc, msg))

let string_of_parse_error loc str =
  Printf.sprintf "%s: %s" (Types.string_of_loc loc) str

let () = Types.register_string_of_error
  (function Parse_error (loc,msg) -> Some (string_of_parse_error loc msg) | _ -> None)

module Name =
  struct
    type t = string * string
    let compare (p1,s1) (p2,s2) =
      match String.compare s1 s2 with
        0 -> String.compare p1 p2
      | n -> n
  end

let string_of_name = function
| ("",s) -> s
| (p, s) -> p ^ ":" ^ s

module Name_map = Map.Make(Name)

module P = struct
    module Attributes = Name_map
    type attr_value = string Types.with_loc_option
    type data = unit
    let compare_name = Name.compare
    let compare_attr_value (s1,_) (s2,_) = String.compare s1 s2
    let compare_data _ _ = 0
    let default_data () = ()
    let version_name () = ("", "version")
    let default_version () = ("1.0", None)
    let default_attr_value () = "", None
    let pp_name ppf name = Format.pp_print_string ppf (string_of_name name)
    let pp_attr_value ppf (value,_) =
      Format.pp_print_string ppf (Misc.escape ~quotes:true value)
    let pp_attributes = None
  end
include (Types.Make(P))

module Name_set = Set.Make (Name)
module SSet = Set.Make(String)

let name_of_string str =
  try
    let p = String.index str ':' in
    let len = String.length str in
    let prefix = String.sub str 0 p in
    let suffix =
      if p + 1 < len then String.sub str (p+1) (len - (p + 1)) else ""
    in
    (prefix, suffix)
  with
    Not_found -> ("", str)


let nl_char = Uchar.of_char '\n'

let loc_of_pos = Types.loc_of_pos

let update_pos pos str =
  let f pos i = function
  | `Malformed msg -> parse_error (loc_of_pos pos 1) msg
  | `Uchar c when Uchar.equal c nl_char ->
      let pos_bol = pos.Lexing.pos_cnum in
      { pos with
        Lexing.pos_lnum = pos.Lexing.pos_lnum + 1;
        pos_bol ;
        pos_cnum = pos.pos_cnum + 1 ;
      }
  | _ -> { pos with pos_cnum = pos.pos_cnum + 1}
  in
  Uutf.String.fold_utf_8 f pos str

let update_pos_from_lb pos lb = update_pos pos (U.lexeme lb)

type stack = (Types.pos * name * attributes) Stack.t

let cp_to_string cp =
  let b = Buffer.create 10 in
  Uutf.Buffer.add_utf_8 b cp ;
  Buffer.contents b

let mk_entities l =
  List.fold_left
    (fun map (e, cp) -> SMap.add e (Uchar.of_int cp) map) SMap.empty l

let xml_entities =
  mk_entities [ "quot", 34 ; "amp", 38 ; "apos", 39;  "lt", 60 ; "gt", 62 ; "nbsp", 160]

let html_entities = mk_entities Html_ents.entities

let e_nameStartChar = [%sedlex.regexp? ":" | 'A'..'Z' | "_" | 'a'..'z' | 0xC0 .. 0xD6 | 0xD8 .. 0xF6 | 0xF8 .. 0x02FF | 0x0370 .. 0x037D | 0x037F .. 0x1FFF | 0x200C .. 0x200D | 0x2070 .. 0x218F | 0x2C00 .. 0x2FEF | 0x3001 .. 0xD7FF | 0xF900 .. 0xFDCF | 0xFDF0 .. 0xFFFD | 0x010000 .. 0x0EFFFF]
let e_nameChar =
  [%sedlex.regexp? e_nameStartChar | "-" | "." | '0' .. '9' | 0xB7
  | 0x0300 .. 0x036F | 0x203F .. 0x2040 ]
let e_name = [%sedlex.regexp? e_nameStartChar , Star(e_nameChar)]
let e_space = [%sedlex.regexp? 	Plus(0x20 | 0x9 | 0xD | 0xA)]

let e_char_no_minus = [%sedlex.regexp?  0x9 | 0xA | 0xD | 0x20 .. 0x2C | 0x2E .. 0xD7FF | 0xE000 .. 0xFFFD | 0x10000 .. 0x10FFFF]
let e_char = [%sedlex.regexp? e_char_no_minus | '-']

let e_charRef = [%sedlex.regexp?
    ("&#", Plus('0'..'9'), ';') | ("&#x", Plus('0'..'9'|'a'..'f'|'A'..'F'), ';')]

let e_name_hack = (* same as e_name but ... *)
  [%sedlex.regexp? e_nameStartChar , Star(e_nameChar |
        (* these characters are here just to be able to parse entities with errors,
         for example a newline in it (yes I saw it...); they will be removed before
         unescaping the entity: *)
   "\n" | "\r" )]
let e_entityRef = [%sedlex.regexp? '&',e_name_hack,(';'|' ')] (* support space-ending entity *)
let e_reference = [%sedlex.regexp? e_entityRef | e_charRef]
let e_attValueChar =
  [%sedlex.regexp? 0x00 .. 0x25| 0x27 .. 0x3B | 0x3D .. 0x0EFFFF]
let e_attValueChar_noquot =
  [%sedlex.regexp? 0x00 .. 0x21 | 0x23 .. 0x25| 0x27 .. 0x3B | 0x3D .. 0x0EFFFF]
let e_attValueChar_noapos =
  [%sedlex.regexp? 0x00 .. 0x25| 0x28 .. 0x3B | 0x3D .. 0x0EFFFF]

let e_attValue = [%sedlex.regexp?
    '"', Star(e_attValueChar_noquot | e_reference), '"'
  | "'", Star(e_attValueChar_noapos | e_reference), "'"
  ]

let e_xml = [%sedlex.regexp? ('x'|'X'),('m'|'M'),('l'|'L')]

type parse_param =
  { ignore_unclosed: bool ;
    self_closing : SSet.t ;
    entities : Uchar.t SMap.t ;
  }
let default_parse_param = {
    ignore_unclosed = false ;
    self_closing = SSet.empty ;
    entities = xml_entities ;
  }

let normalize_parse_param p =
  let self_closing = SSet.map String.lowercase_ascii p.self_closing in
  { p with self_closing }


(*c==v=[String.no_blanks]=1.0====*)
let no_blanks s =
  let len = String.length s in
  let buf = Buffer.create len in
  for i = 0 to len - 1 do
    match s.[i] with
      ' ' | '\n' | '\t' | '\r' -> ()
    | c -> Buffer.add_char buf c
  done;
  Buffer.contents buf
(*/c==v=[String.no_blanks]=1.0====*)

let map_string = Misc.map_string
let escape = Misc.escape

let unescape =
  let add = Buffer.add_string in
  let rec iter param entities buf lb =
    match%sedlex lb with
    | e_entityRef ->
        let lexeme = U.lexeme lb in
        let s =
          if entities then
            (
             let ent = String.sub lexeme 1 (String.length lexeme - 2) in
             let ent = no_blanks ent in
             match SMap.find_opt ent param.entities with
             | None -> lexeme
             | Some x -> cp_to_string x
            )
          else
            lexeme
        in
        add buf s ;
        iter param entities buf lb

    | "&#", Plus('0'..'9'), ';' ->
        let lexeme = U.lexeme lb in
        let s =
          try
            let c =
              let len = String.length lexeme in
              let s = String.sub lexeme 2 (len - 3) in
              Uchar.of_int (int_of_string s)
            in
            cp_to_string c
          with _ -> lexeme
        in
        add buf s ;
        iter param entities buf lb
    | "&#x", Plus('0'..'9'|'a'..'f'|'A'..'F'), ';' ->
        let lexeme = U.lexeme lb in
        let s =
          try
            let c =
              let len = String.length lexeme in
              let s = "0"^(String.sub lexeme 2 (len - 3)) in
              Uchar.of_int (int_of_string s)
            in
            cp_to_string c
          with
            _ -> lexeme
        in
        add buf s;
        iter param entities buf lb
    | any -> add buf (U.lexeme lb); iter param entities buf lb
    | _ -> ()
  in
  fun param ?(entities=true) -> map_string (iter param entities)

let rec parse_comment parse_param pos buf lb =
  match%sedlex lb with
    "-->" -> unescape parse_param (Buffer.contents buf)
  | "<!--"
  | e_char ->
(*  | e_char_no_minus | ('-', e_char_no_minus) ->*)
      Buffer.add_string buf (U.lexeme lb);
      parse_comment parse_param pos buf lb
  | any ->
      parse_error (loc_of_pos pos 1) ("Illegal comment character: "^(U.lexeme lb))
  | _ ->
      let pos = update_pos pos (Buffer.contents buf) in
      parse_error (loc_of_pos pos 1) "Unexpected end of stream while parsing comment"

let rec parse_cdata parse_param pos buf lb =
  match%sedlex lb with
    "]]>" -> unescape parse_param ~entities: false (Buffer.contents buf)
  | e_char ->
      Buffer.add_string buf (U.lexeme lb);
      parse_cdata parse_param pos buf lb
  | any ->
      parse_error (loc_of_pos pos 1) ("Illegal cdata character: "^(U.lexeme lb))
  | _ ->
      let pos = update_pos pos (Buffer.contents buf) in
      parse_error (loc_of_pos pos 1) "Unexpected end of stream while parsing cdata"

let rec parse_proc_inst parse_param pos buf lb =
  match%sedlex lb with
    "?>" ->
      let args = unescape parse_param (Buffer.contents buf) in
      let pos = update_pos pos (U.lexeme lb) in
      let args = Misc.strip_string args in
      (args, pos)
  | e_char ->
      Buffer.add_string buf (U.lexeme lb);
      parse_proc_inst parse_param pos buf lb
  | any ->
      parse_error (loc_of_pos pos 1) ("Illegal character in processing instruction: "^(U.lexeme lb))
  | _ ->
      let pos = update_pos pos (Buffer.contents buf) in
      parse_error (loc_of_pos pos 1)
        "Unexpected end of stream while parsing processing instruction"

let rec parse_doctype parse_param pos buf lb =
  match%sedlex lb with
    ">" ->
      let args = unescape parse_param (Buffer.contents buf) in
      let pos = update_pos pos (U.lexeme lb) in
      let args = Misc.strip_string args in
      (args, pos)
  | e_char ->
      Buffer.add_string buf (U.lexeme lb);
      parse_doctype parse_param pos buf lb
  | any ->
      parse_error (loc_of_pos pos 1) ("Illegal character in doctype decl: "^(U.lexeme lb))
  | _ ->
      let pos = update_pos pos (Buffer.contents buf) in
      parse_error (loc_of_pos pos 1)
        "Unexpected end of stream while parsing doctype decl"

let add_elt stack elt =
  match stack with
  | [] -> assert false
  | (x,l) :: q -> (x, elt :: l) :: q

let push stack pos_start name attributes =
  ((name, pos_start, attributes), []) :: stack

let rec find_in_stack acc name stack =
  match stack with
  | [] | ((("",""),_,_),_) :: [] -> None
  | ((n, _, _),_) :: q when n = name ->
      Some (List.rev acc, stack)
  | h :: q -> find_in_stack (h :: acc) name q

let rec pop param stack pos_end name =
  match stack with
  | []
  | ((("",""),_,_),_) :: [] ->
      if param.ignore_unclosed then
        stack
      else
        parse_error (loc_of_pos pos_end 1)
          (Printf.sprintf "Closing already closed </%s>"
           (string_of_name name))
  | ((n,pos_start,atts), subs) :: q ->
      if n = name then
        let loc = Types.loc pos_start pos_end in
        let elt = node ~loc ~atts name (List.rev subs) in
        add_elt q elt
      else
        if param.ignore_unclosed then
          match find_in_stack [] name stack with
          | Some (before, stack) ->
              let f acc ((n,pos_start,atts),subs) =
                let loc = Types.loc pos_start pos_end in
                let elt = node ~loc ~atts n (List.rev subs) in
                elt :: acc
              in
              let closed_elts = List.fold_left f [] before in
              let stack = List.fold_left add_elt stack closed_elts in
              pop param stack pos_end name
          | None ->
              stack
        else
          parse_error (loc_of_pos pos_end 1)
            (Printf.sprintf "Found </%s> instead of </%s>"
             (string_of_name name) (string_of_name n))

let new_stack pos_start = [(("",""), pos_start, Name_map.empty), []]
let stack_is_empty l = List.length l <= 1

let autoclosed name set =
  match name with
  | ("",s) -> SSet.mem (String.lowercase_ascii s) set
  | _ -> false

let rec parse_text parse_param stack ~first pos lb =
  match%sedlex lb with
    "<!--" ->
      let pos = update_pos_from_lb pos lb in
      let text = parse_comment parse_param pos (Buffer.create 256) lb in
      let pos2 = update_pos pos text in
      (* update pos2 with the "-->" lexeme just read *)
      let pos2 = update_pos_from_lb pos2 lb in
      let loc = Types.loc pos pos2 in
      let stack = add_elt stack (comment ~loc text) in
      parse_text parse_param stack ~first pos2 lb

  | "<![CDATA[" ->
      let pos = update_pos_from_lb pos lb in
      let text = parse_cdata parse_param pos (Buffer.create 256) lb in
      let pos2 = update_pos pos text in
      (* update pos2 with the "]]>" lexeme just read *)
      let pos2 = update_pos_from_lb pos2 lb in
      let loc = Types.loc pos pos2 in
      let stack = add_elt stack (cdata ~loc ~quoted: true text) in
      parse_text parse_param stack ~first: false pos2 lb

  | "<?",e_name ->
      let pos2 = update_pos_from_lb pos lb in
      let app =
        let s = U.lexeme lb in
        let len = String.length s in
        name_of_string (String.sub s 2 (len - 2))
      in
      begin
        match app with
          ("", s) when String.lowercase_ascii s = "xml" ->
            let loc = Types.loc pos pos2 in
            parse_error loc "Illegal XML declaration here"
        | _ ->
            let (args, pos2) = parse_proc_inst parse_param pos2 (Buffer.create 256) lb in
            let loc = Types.loc pos pos2 in
            let stack = add_elt stack (pi ~loc app args) in
            parse_text parse_param stack ~first: false pos2 lb
      end
  | '<',e_name ->
      let name =
        let s = U.lexeme lb in
        let len = String.length s in
        name_of_string (String.sub s 1 (len - 1))
      in
      let pos2 = update_pos_from_lb pos lb in
      let (atts, pos2, closed) = parse_attributes parse_param Name_map.empty pos2 lb in
      let stack =
        if closed || autoclosed name parse_param.self_closing then
          (
           let loc = Types.loc pos pos2 in
           let elt = node ~loc ~atts name [] in
           add_elt stack elt
          )
        else
          push stack pos name atts
      in
      parse_text parse_param stack ~first: false pos2 lb
  | "</",e_name,Star(e_space),'>' ->
      let lexeme = U.lexeme lb in
      let len = String.length lexeme in
      let name = String.sub lexeme 2 (len - 3) in
      let name = name_of_string (Misc.strip_string name) in
      let pos2 = update_pos_from_lb pos lb in
      let stack =
        if autoclosed name parse_param.self_closing
        then stack
        else pop parse_param stack pos2 name
      in
      parse_text parse_param stack ~first: false pos2 lb
  | "]]>" ->
      parse_error (loc_of_pos pos 3)
        ("Illegal sequence in character data: "^(U.lexeme lb))
  | Plus(e_attValueChar | e_reference) ->
      let str = unescape parse_param (U.lexeme lb) in
      let pos2 = update_pos_from_lb pos lb in
      if first && Misc.strip_string str = "" then
        parse_text parse_param stack ~first pos2 lb
      else
        (
         let loc = Types.loc pos pos2 in
         let stack = add_elt stack (cdata ~loc str) in
         parse_text parse_param stack ~first: false pos2 lb
        )
  | "</", any ->
      let l = U.lexeme lb in
      let pos2 = update_pos_from_lb pos lb in
      let buf = Buffer.create 256 in
      let rec iter () =
        match Sedlexing.next lb with
        | Some c ->
            if Uchar.is_char c then
              (Buffer.add_char buf (Uchar.(to_char c)); iter ())
        | None -> ()
      in
      iter ();
      parse_error (Types.loc pos pos2)
        (Printf.sprintf "Unexpected characters: %s|%s" l (Buffer.contents buf))
  | '<', any ->
      let pos2 = update_pos_from_lb pos lb in
      parse_error (Types.loc pos pos2)
        (Printf.sprintf "Unexpected characters: %s" (U.lexeme lb))
  | any ->
      parse_error (loc_of_pos pos 1) "Unexpected characters from this point"
  | _ ->
      match stack with
        [] -> assert false
      | ((name,_,_),_) :: _ :: _ ->
          parse_error (loc_of_pos pos 1)
            (Printf.sprintf "Element not terminated: %s"
             (string_of_name name))
      | [_,subs] ->
          List.rev subs

and parse_attributes parse_param ?(ignoring=false) ?(xml_decl=false) map pos lb =
  match%sedlex lb with
  | e_space ->
      parse_attributes parse_param
        ~xml_decl map (update_pos_from_lb pos lb) lb
  | e_name ->
      let name = name_of_string (U.lexeme lb) in
      let pos = update_pos_from_lb pos lb in
      let (att_value, pos2) = parse_attribute_eq parse_param pos lb in
      let map =
        if ignoring then
          map
        else Name_map.add name att_value map
      in
       parse_attributes parse_param ~xml_decl map pos2 lb
  | "?>" ->
      if xml_decl then
        (map, update_pos_from_lb pos lb, true)
      else
        parse_error (loc_of_pos pos 2)
          ("Unexpected characters: "^(U.lexeme lb))
  | '>' ->
      if xml_decl then
        parse_error (loc_of_pos pos 1)
          ("Unexpected character: "^(U.lexeme lb))
      else
        (map, update_pos_from_lb pos lb, false)
  | "/>" ->
      if xml_decl then
        parse_error (loc_of_pos pos 2)
          ("Unexpected characters: "^(U.lexeme lb))
      else
        (map, update_pos_from_lb pos lb, true)
  | any ->
      let loc = loc_of_pos pos 1 in
      let pos = update_pos_from_lb pos lb in
      Log.warn (fun m -> m "%a, Unexpected character in attribute list: %s; skipping attribute" 
         Types.pp_loc loc (U.lexeme lb));
      parse_attributes parse_param ~ignoring:true  ~xml_decl map pos lb
  | _ -> parse_error (loc_of_pos pos 1) "Unexpected end of stream while parsing attributes"

and parse_attribute_eq parse_param pos lb =
  match%sedlex lb with
  | e_space -> parse_attribute_eq parse_param (update_pos_from_lb pos lb) lb
  | '=', Star(e_space) -> parse_attribute_value parse_param pos lb
  | any ->
      Log.warn (fun m -> m "%s: attribute with no value, setting empty string"
         (Types.string_of_loc (loc_of_pos pos 1)));
      Sedlexing.rollback lb;
      ("", None), pos
(*      parse_error (loc_of_pos pos 1)
        ("Unexpected character: "^(U.lexeme lb)^"; '=' was expected")*)
  | _ ->
      parse_error (loc_of_pos pos 1)
        "Unexpected end of stream while parsing attribute"

and parse_attribute_value parse_param pos lb =
  match%sedlex lb with
  | e_attValue ->
    let lexeme = U.lexeme lb in
    let pos2 = update_pos_from_lb pos lb in
    let len = String.length lexeme in
    let v = unescape parse_param (String.sub lexeme 1 (len - 2)) in
    let loc = Types.loc pos pos2 in
    ((v, Some loc), pos2)
  | any ->
      parse_error (loc_of_pos pos 1)
        ("Unexpected character: "^(U.lexeme lb))
  | _ ->
      parse_error (loc_of_pos pos 1)
        "Unexpected end of stream while parsing attribute value"

let rec parse_prolog parse_param ?xml_decl misc pos lb =
  match%sedlex lb with
  | "<!",('d'|'D'),('o'|'O'),('c'|'C'),('t'|'T'),('y'|'Y'),('p'|'P'),('e'|'E'),Plus(e_space) ->
      let pos2 = update_pos_from_lb pos lb in
      let name = match%sedlex lb with
        | e_name -> name_of_string (U.lexeme lb)
        | _ ->
            parse_error (loc_of_pos pos 1)
              ("Invalid character in doctype decl: "^(U.lexeme lb))
      in
      let (args, pos2) = parse_doctype parse_param pos2 (Buffer.create 256) lb in
      let loc = Types.loc pos pos2 in
      let doctype = doctype ~loc name args in
      let prolog = prolog ?decl: xml_decl ~doctype (List.rev misc) in
      let elements = parse_text parse_param (new_stack pos2) ~first: true pos2 lb in
      doc prolog elements

  | "<!--" ->
      let pos = update_pos_from_lb pos lb in
      let text = parse_comment parse_param pos (Buffer.create 256) lb in
      let pos2 = update_pos pos text in
      (* update pos2 with the "-->" lexeme just read *)
      let pos2 = update_pos_from_lb pos2 lb in
      let loc = Types.loc pos pos2 in
      let comment = prolog_comment ~loc text in
      parse_prolog parse_param ?xml_decl ((PC comment)::misc) pos2 lb

  | "<?",e_name ->
      let pos2 = update_pos_from_lb pos lb in
      let app =
        let s = U.lexeme lb in
        let len = String.length s in
        name_of_string (String.sub s 2 (len - 2))
      in
      begin
        match app with
          ("", s) when String.lowercase_ascii s = "xml" ->
            let loc = Types.loc pos pos2 in
            parse_error loc "Illegal XML declaration here"
        | _ ->
            let (args, pos2) =
              parse_proc_inst parse_param pos2 (Buffer.create 256) lb
            in
            let loc = Types.loc pos pos2 in
            let pi = prolog_pi ~loc app args in
            parse_prolog parse_param ?xml_decl (PPI pi :: misc) pos2 lb
      end
  | e_space ->
      let pos2 = update_pos_from_lb pos lb in
      parse_prolog parse_param ?xml_decl misc pos2 lb
  | '<',e_name ->
      Sedlexing.rollback lb ;
      let prolog = prolog ?decl: xml_decl (List.rev misc) in
      let elements = parse_text parse_param (new_stack pos) ~first: true pos lb in
      doc prolog elements
  | any ->
      let pos2 = update_pos_from_lb pos lb in
      let loc = Types.loc pos pos2 in
      parse_error loc (Printf.sprintf "Illegal character %S" (U.lexeme lb))
  | _ ->
      let loc = loc_of_pos pos 0 in
      parse_error loc ("Unexpected end of stream while parsing prolog")

let parse_doc parse_param pos lb =
  match%sedlex lb with
  | "<?",e_xml,Plus(e_space) ->
      let pos2 = update_pos_from_lb pos lb in
      let (atts, pos2, _) = parse_attributes parse_param
        ~xml_decl: true Name_map.empty pos2 lb
      in
      let loc = Types.loc pos pos2 in
      let xml_decl = xml_decl ~loc atts in
      parse_prolog parse_param ~xml_decl [] pos2 lb
  | _ ->
      Sedlexing.rollback lb ;
      parse_prolog parse_param [] pos lb

let xmlns_name = ("","xmlns") ;;

let from_lexbuf ?(param=default_parse_param)
  ?(pos_start=Types.pos ~line: 1 ~bol: 0 ~char: 1 ()) lb =
  let param = normalize_parse_param param in
  parse_text param (new_stack pos_start) ~first: true
    pos_start lb

let doc_from_lexbuf ?(param=default_parse_param)
  ?(pos_start=Types.pos ~line:1 ~bol:0 ~char:1 ()) lb =
  let param = normalize_parse_param param in
  parse_doc param pos_start lb

let malformed ?(pos=Types.pos ~line: 1 ~bol: 1 ~char: 1 ()) src =
  parse_error (loc_of_pos pos 1) ("Malformed character in "^src)

let from_string ?param ?pos_start str =
  try
    let lb = U.from_string str in
    from_lexbuf ?param ?pos_start lb
  with
    Sedlexing.MalFormed ->
       malformed ?pos: pos_start str

let doc_from_string ?param ?pos_start str =
  try
    let lb=  U.from_string str in
    doc_from_lexbuf ?param ?pos_start lb
  with
    Sedlexing.MalFormed ->
       malformed ?pos: pos_start str

let from_channel ?param ?pos_start ic =
  try
    let lb=  U.from_channel ic in
    from_lexbuf ?param ?pos_start lb
  with
    Sedlexing.MalFormed ->
       malformed ?pos: pos_start "<channel>"

let doc_from_channel ?param ?pos_start ic =
  try
    let lb=  U.from_channel ic in
    doc_from_lexbuf ?param ?pos_start lb
  with
    Sedlexing.MalFormed ->
      malformed ?pos: pos_start "<channel>"

let from_file ?param file =
  let ic = open_in_bin file in
  let pos_start = Types.pos ~fname:file ~line:1 ~bol:0 ~char:1 () in
  try let xmls = from_channel ?param ~pos_start ic in close_in ic; xmls
  with e ->
    close_in ic;
    raise e

let doc_from_file ?param file =
  let ic = open_in_bin file in
  let pos_start = Types.pos ~fname:file ~line:1 ~bol:0 ~char:1 () in
  try let xmls = doc_from_channel ?param ~pos_start ic in close_in ic; xmls
  with e ->
    close_in ic;
    raise e

(*
let xml = {|<?xml version='1' ?>
  <!DOCTYPE toto sdkfsdl>
  <!--hello comment !-->
   <?myapp tralalalal?>
   bla bl <strong title="coucou&lt;">bla</strong> foo bar|}
let xml = Misc.string_of_file Sys.argv.(1)
let tree =
  try
    let xmls = from_string xml in
    print_endline (to_string xmls)
  with
  Error e ->
      prerr_endline (string_of_error e)
*)