Source file rewrite.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                                          *)
(*                                                                               *)
(*                                                                               *)
(*********************************************************************************)


(** Templating XML trees.

    XML {!type:tree}s which are rewritten using {!type:callback} rules
    provided by the {!type:env} environment.

    A complete description of the templating rules is available in the
    {!section:engine} section below.
*)

module SMap = Xml.SMap
module Name_set = Xml.Name_set

module Str = Re.Str

(** {2 XML documents} *)

module Attributes = Xml.Name_map

module rec P : Types.P with
  module Attributes = Xml.Name_map and
  type attr_value = X.tree list =
  struct
    module Attributes = Xml.Name_map
    type attr_value = X.tree list
    type data = unit
    let compare_name = Xml.Name.compare
    let compare_attr_value = List.compare X.compare_tree
    let compare_data _ _ = 0
    let default_data () = ()
    let version_name () = ("", "version")
    let default_version () = [X.cdata "1.0"]
    let default_attr_value () = [X.cdata ""]
    let pp_name ppf name = Format.pp_print_string ppf (Xml.string_of_name name)
    let pp_attr_value = X.pp_trees
    let pp_attributes : (Format.formatter -> attr_value Attributes.t -> unit) option =
        Some (fun ppf atts -> !PP.pp_attributes_r ppf atts)
  end
and X : Types.S with
  type name = Attributes.key and
  type attr_value = P.attr_value and
  type attributes = P.attr_value Attributes.t and
  type data = unit = Types.Make(P)

and PP : sig
  (**/**)

  val pp_attributes_r : (Format.formatter -> X.attributes -> unit) ref

  (**/**)
end =
struct
  let pp_attributes_r : (Format.formatter -> X.attributes -> unit) ref =
    ref (fun _ _ -> assert false)
end

include(X)

(** Empty map of attributes *)
let atts_empty : attributes = Attributes.empty

(** {2 Errors} *)

(** To catch eventual infinite loops in rewriting, we keep a
  stack of the rules called. *)
type rewrite_stack = (name * attributes * tree list * Types.loc option) list

(** String representation of the given rewrite stack. *)
let string_of_rewrite_stack l =
  let b = Buffer.create 256 in
  let f ((prefix,t), atts, subs, loc) =
    Buffer.add_string b "==================\n";
    Buffer.add_string b ("Apply <"^prefix^":"^t^">\nAttributes:");
    Attributes.iter
      (fun (p,s) v ->
         Buffer.add_string b "\n  ";
         if p <> "" then Buffer.add_string b (p^":");
         Printf.bprintf b "%s=%S " s (to_string v))
      atts;
    Buffer.add_string b "\nSubs=\n";
    List.iter (fun xml -> Buffer.add_string b (to_string [xml])) subs;
    Buffer.add_string b "\n"
  in
  List.iter f (List.rev l);
  Buffer.contents b

type Types.error +=
| Loop of rewrite_stack   (** The [Loop] error is raised when the rewrite stack
       is higher than a default value of [100]. This value can be changed
       by setting the [XTMPL_REWRITE_DEPTH_LIMIT] environment variable.
       *)
| Parse_attribute_error of Types.loc option * Xml.name * string
| Invalid_attribute_value of string * tree list
| Fixpoint_limit of int

let loop_error stack = Types.error (Loop stack)
let parse_attribute_error loc name msg = Types.error (Parse_attribute_error (loc, name, msg))
let invalid_attribute_value att v = Types.error (Invalid_attribute_value (att,v))
let fixpoint_limit n = Types.error (Fixpoint_limit n)

let string_of_error = function
  Loop stack ->
    let msg = "Max rewrite depth reached -- possible loop ?\nRewrite stack:\n"^
      (string_of_rewrite_stack stack)
    in
    Some msg
| Parse_attribute_error (loc, name, msg) ->
    Some (Printf.sprintf "%sParse error in attribute %S: %s"
     (match loc with None -> "" | Some loc -> (Types.string_of_loc loc)^": ")
       (Xml.string_of_name name) msg)
| Invalid_attribute_value (att, v) ->
    Some (Printf.sprintf "invalid value of attribute %s: %s" att (to_string v))
| Fixpoint_limit n ->
    Some (Printf.sprintf "Xtmpl fixpoint iteration limit reached (%d)" n)
| _ -> None

let () = Types.register_string_of_error string_of_error

(** {2 Special tag and attributes} *)

(** The environment tag, currently ["env_"].

    See the template rules in the {!section:engine} section below for more
    information about this tag.
*)
let tag_env = "env_"

(** The defer attribute, currently ["defer_"]. See the engine section
  for details. *)
let att_defer = "defer_"

(** The escamp attribute, currently ["escamp_"]. This attribute
  is used when converting XML to string or reading XML from a string.
  The CDATA associated to this attribute indicates the other attributes
  in which the ampersands must be escaped (when parsing XML from an
  attribute string) or unescaped (when printing XML to an attribute string).
  This is useful for urls with &, for example in [<a href="...">] nodes.

  Example: In [<a escamp_="href", href="http://foo.fr?v1=3amp;v2=4">...</a>].
  As attributes are parsed as XML, setting the [escamp_] attribute to ["href"]
  will make the ampersand escaped. The attribute is kept during rewriting.
  When the XML tree will be converted to a string, the [escamp_] attribute
  will be removed. Several attribute names can be indicated, using [',']
  or [';'] as separator, as in
  [ <a escamp_="href, foo, gee:buz" href="..." ...>...</a> ].
*)
let att_escamp = "escamp_"

(** The protect attribute, currently "protect_". See the engine section
  for details. This attribute is removed when a XML tree is converted
  to a string, as for {!att_escamp}.
*)
let att_protect = "protect_"

(** {2 Mapping to {!Xml} documents} *)

(**/**)

let re_escape = Str.regexp "&\\(\\([a-z]+\\)\\|\\(#[0-9]+\\)\\);"
let escape_ampersand s =
  let len = String.length s in
  let b = Buffer.create len in
  for i = 0 to len - 1 do
    match s.[i] with
      '&' when Str.string_match re_escape s i ->
        Buffer.add_char b '&'
    | '&' -> Buffer.add_string b "&amp;"
    | c -> Buffer.add_char b c
  done;
  Buffer.contents b

let re_amp = Str.regexp_string "&amp;"
let unescape_ampersand s = Str.global_replace re_amp "&" s

let gen_atts_to_escape =
  let key = ("", att_escamp) in
  fun get_att to_s atts ->
    let spec = get_att atts key in
    match spec with
      None -> Xml.Name_set.empty
    | Some x ->
        let s = to_s x in
        let l = Misc.split_string s [',' ; ';'] in
        List.fold_right
          (fun s set ->
             let s = Misc.strip_string s in
             let name =
               match Misc.split_string s [':'] with
                 [] | [_] -> ("",s)
               | p :: q -> (p, String.concat ":" q)
             in
             Xml.Name_set.add name set
          )
          l
          Xml.Name_set.empty

let atts_to_escape = gen_atts_to_escape Xml.get_att (fun (x,_loc) -> x)
let xml_atts_to_escape = gen_atts_to_escape get_att
  (function [D s] -> s.Types.text
   | _ -> failwith ("Invalid value for attribute "^att_escamp))

module To_xml =
  struct
    module Mapper_to_xml = Types.Make_map(X)(Xml)

    let map_name name = name
    let map_data d = d

    let mapper_to_xml ~xml_atts () =
      let map_xmls = ref (fun _ -> assert false) in
      let rec map_attr_value xmls = (to_string xmls, None)

      and to_string trees = Xml.to_string (!map_xmls trees)

      and map_attributes atts =
        let atts_to_escape = xml_atts_to_escape atts in
        let escamp name = Name_set.mem name atts_to_escape in
        Attributes.fold (map_attribute ~escamp) atts Xml.Name_map.empty

      and map_attribute ~escamp name xmls (map:Xml.attributes) =
        match name with
        | ("", s) when s = att_escamp -> map
        | ("", s) when s = att_protect -> map
        | _ ->
            let s = to_string xmls in
            let s = if escamp name then unescape_ampersand s else s in
            let s = if xml_atts then s else Xml.unescape Xml.default_parse_param s in
            Xml.atts_one ~atts: map name (s, None)

      and mapper () =
            let param = Types.{ map_name ; map_data ;
                map_attributes = Some map_attributes ;
                map_attr_value = map_attr_value ;
              }
            in
            Mapper_to_xml.mapper param
      in
      let mapper = mapper () in
      map_xmls := mapper.Types.map_xmls;
      mapper

    let to_xml_atts_true = mapper_to_xml ~xml_atts:true ()
    let to_xml_atts_false = mapper_to_xml ~xml_atts:false ()
    let on_to_xml_mapper f =
      fun ?(xml_atts=true) x ->
        f (if xml_atts then to_xml_atts_true else to_xml_atts_false) x

    let to_xml_attributes = on_to_xml_mapper
      (fun to_xml atts -> to_xml.map_atts atts)

    let to_string ?(xml_atts=true) xmls =
      if xml_atts then
        Xml.to_string (to_xml_atts_true.map_xmls xmls)
      else
        Misc.string_of_pp X.pp_trees xmls

    let doc_to_string ?(xml_atts=true) doc =
      if xml_atts then
        Xml.doc_to_string (to_xml_atts_true.map_doc doc)
      else
        Misc.string_of_pp X.pp_doc doc

    let to_xml = on_to_xml_mapper (fun to_xml d -> to_xml.map_xml d)
    let to_xmls = on_to_xml_mapper (fun to_xml d -> to_xml.map_xmls d)
    let to_doc = on_to_xml_mapper (fun to_xml d -> to_xml.map_doc d)
    let to_prolog = on_to_xml_mapper (fun to_xml p -> to_xml.map_prolog p)
  end

let () =
  let f : Format.formatter -> attributes -> unit =
    let pp_attr ?first ppf ~escamp name xmls =
      match name with
      | ("", s) when s = att_escamp -> ()
      | ("", s) when s = att_protect -> ()
      | _ ->
          let s = X.to_string xmls in
          let s = if escamp name then unescape_ampersand s else s in
          let s = Xml.unescape Xml.default_parse_param s in
          (* Xml.pp_attr will escape the string *)
          Xml.pp_attr ?first ppf name (s, None)
    in
    fun ppf atts ->
      match Attributes.bindings atts with
      | [] -> ()
      | (name,value)::q ->
          let atts_to_escape = xml_atts_to_escape atts in
          let escamp name = Name_set.mem name atts_to_escape in
          pp_attr ~first:true ppf ~escamp name value;
          List.iter (fun (n,v) -> pp_attr ppf ~escamp n v) q
  in
  PP.pp_attributes_r := f

(**/**)

(** Convert to a {!Xml.tree}.
    Optional argument [xml_atts] indicates whether the code in attributes remains valid XML
    or not. Default is [true] but it should be set to [false] when outputting
    final documents like XHTML pages. *)
let to_xml = To_xml.to_xml

(** Same as {!to_xml} but for a list of trees. *)
let to_xmls = To_xml.to_xmls

(** Same as {!to_xml} but for a map of attributes. *)
let to_xml_attributes = To_xml.to_xml_attributes

(** Same as {!to_xml} but for a doc. *)
let to_doc = To_xml.to_doc

(** Same as {!to_xml} but for a document prolog. *)
let to_prolog = To_xml.to_prolog

(** {2 Mapping from a {!Xml} documents} *)

(**/**)

module From_xml =
  struct
    module Mapper_to_xml = Types.Make_map(Xml)(X)

    let map_name name = name
    let map_data d = d

    let mapper_from_xml () =
      let map_xmls = ref (fun _ -> assert false) in
      let rec map_attributes : Xml.attributes -> attributes = fun atts ->
          let to_escape = atts_to_escape atts in
          Xml.Name_map.fold
            (fun name (s,loc) acc ->
               let pos_start = Option.map fst loc in
               let escamp = Name_set.mem name to_escape in
               let s = if escamp then escape_ampersand s else s in
               try
                 let xmls = !map_xmls (Xml.from_string ?pos_start s) in
                 atts_one ~atts:acc name xmls
               with
               | Types.Error (Xml.Parse_error (loc, msg)) -> Xml.parse_error loc msg
               | e ->
                   let msg = Printf.sprintf "%s\n%s"
                     (Printexc.to_string e) s
                   in
                   parse_attribute_error loc name msg
            )
            atts Attributes.empty
      and map_attr_value : Xml.attr_value -> attr_value =
        fun (str,_) -> !map_xmls (Xml.from_string str)

      and mapper () =
            let param = Types.{ map_name ; map_data ;
                map_attributes = Some map_attributes ;
                map_attr_value = map_attr_value ;
              }
            in
            Mapper_to_xml.mapper param
      in
      let mapper = mapper () in
      map_xmls := mapper.Types.map_xmls;
      mapper

    let mapper = mapper_from_xml ()
    let doc_from_string ?pos_start str = mapper.map_doc (Xml.doc_from_string ?pos_start str)
    let from_string ?pos_start str = mapper.map_xmls (Xml.from_string ?pos_start str)
    let from_xml = mapper.map_xml
    let from_xmls = mapper.map_xmls
    let from_xml_attributes = mapper.map_atts
    let from_doc = mapper.map_doc
    let from_prolog = mapper.map_prolog
  end

(**/**)

(** Convert from a {!Xml.tree} list. Attribute values must
     be valid XML.*)
let from_xml = From_xml.from_xml

(** Same as {!from_xml} but for a list of trees. *)
let from_xmls = From_xml.from_xmls

(** Convert {!Xml.type-attributes} to {!attributes}. *)
let from_xml_attributes = From_xml.from_xml_attributes

(** Convert from a {!Xml.type-doc}. Attribute values must be valid XML.*)
let from_doc = From_xml.from_doc

(** Convert from a {!Xml.type-prolog}. *)
let from_prolog = From_xml.from_prolog

(** {2 Input/output} *)

(** Output a tree list to a string.
  See {!to_xml} about [xml_atts] argument.*)
let to_string = To_xml.to_string

(** Output an XML document to a string.
  See {!to_xml} about [xml_atts] argument.*)
let doc_to_string = To_xml.doc_to_string

(** Parses a string as {!tree} list. *)
let from_string = From_xml.from_string

(** Parses a {!type:doc}. *)
let doc_from_string = From_xml.doc_from_string

(** Same as {!from_string} but reads from a file. *)
let from_file file = from_xmls (Xml.from_file file)

(** Same as {!doc_from_string} but reads from a file. *)
let doc_from_file file = from_doc (Xml.doc_from_file file)

(** {2 Utils} *)

(** Same as {!get_att} but return a string [s] only if [name] is bound to
  a single CDATA XML node ([[D s]]).
  In particular, if [name] is bound to a list of XML tree, or to
  a single tree which is not a CDATA, the function returns [None].
*)
let get_att_cdata atts name =
  match get_att atts name with
  | Some [D s] -> Some s.Types.text
  | Some xmls -> Some (to_string xmls)
  | _ -> None


(** Same as {!opt_att} but looking for CDATA bounded values, as in
  {!get_att_cdata}.
*)
let opt_att_cdata atts ?(def="") name =
  match get_att_cdata atts name with None -> def | Some s -> s

(** [upto_first_element trees] returns the list of trees until
  the first [E] element, included.
  @raise Not_found if there is no element in the list.
*)
let upto_first_element =
  let rec iter acc = function
  | [] -> raise Not_found
  | (E _) as xml :: _ -> List.rev (xml :: acc)
  | xml :: q -> iter (xml :: acc) q
  in
  fun l -> iter [] l

(** Same as {!merge_cdata} but taking a {!tree} list. *)
let merge_cdata_list =
  let rec f acc = function
    [] -> List.rev acc
  | (D d1) :: (D d2) :: q ->
      let d = D (Types.merge_cdata d1 d2) in
      f acc (d :: q)
  | ((D _) as x) :: q -> f (x :: acc) q
  | E node :: q ->
      let subs = f [] node.subs in
      f (E {node with subs} :: acc) q
  | xml :: q -> f (xml::acc) q
  in
  fun l -> f [] l

(** Recursively merge sibling [D] nodes into one [D] node. *)
let merge_cdata t =
  match t with
  | E node -> E { node with subs = merge_cdata_list node.subs }
  | xml -> xml

(** {2 Environment}

    An {!type:env} is a {!type:name}-to-{!type:callback} associative map. In addition
    to basic manipulation functions, the functions {!val:env_add_xml} and
    {!val:env_of_list} provide convenient shortcuts for common operations.

    The environments are immutable, all mutating operations return new
    environments.
*)

type 'a env = {
    env_ns : Iri.t SMap.t ;
    env_map : ('a callback) Attributes.t ;
  }
and 'a callback =
  'a -> 'a env -> ?loc: Types.loc -> attributes -> tree list -> 'a * tree list

(** An environment that contains no binding.*)
let env_empty () = { env_ns = SMap.empty ; env_map = Attributes.empty }

(** This exception can be raised by callbacks to indicate that the
  node to be rewritten remains unchanged. *)
exception No_change

(**/**)

let env_resolve env name =
  match name with
    ("", str) -> ("", str)
  | (ns, str) ->
    match SMap.find_opt ns env.env_ns with
    | None -> (ns, str)
    | Some iri ->
          let str = Printf.sprintf "%s%s" (Iri.to_string iri) str in
          ("", str)

let protect_in_env env atts =
  match get_att atts ("", att_protect) with
    None -> env
  | Some [D s] ->
      let f env s =
        match Misc.split_string s [':'] with
          [] -> env
        | [s] | ["" ; s] ->
            { env with env_map = Attributes.remove ("",s) env.env_map }
        | s1 :: q ->
            let s2 = String.concat ":" q in
            let k = env_resolve env (s1, s2) in
            { env with env_map = Attributes.remove k env.env_map }
      in
      List.fold_left f env (Misc.split_string s.Types.text [',' ; ';'])
  | Some l -> invalid_attribute_value att_protect l

(**/**)

(** Add a binding to an environment.

    [env_add_cb "double" (fun acc _ _ xml -> (acc, xml @ xml))] binds the key
    [("", "double")] to a callback that doubles an XML subtree.

    [env_add_cb ~prefix: "foo" "double" (fun acc _ _ xml -> (acc, xml @ xml))] does the same but
    for the key  [("foo", "double")].

    If the same key was already bound, the previous binding is replaced.

    Opional argument [prefix] is [""] by default.
*)
let env_add_cb ?(prefix="") name cb env =
  let k = env_resolve env (prefix, name) in
  { env with env_map = Attributes.add k cb env.env_map }

(** Bind a callback that returns some XML.

    The most frequent operation performed by a callback is to return
    constant XML subtrees. This convenience function lets you provide
    the XML subtrees.

    [env_add_xml "logo" [ E (("","img"), atts_one ("","src") [D "logo.png"], []) ] env]
    binds the key [("","logo")] to a callback that returns an XHTML image tag.

    Optional argument [prefix] can be used to specify a prefix for the rule name. Default is [""].
*)
let env_add_xml ?prefix a v env =
  env_add_cb ?prefix a (fun data _ ?loc _ _ -> data, v) env

(** Get a binding from an environment.
    If the binding is not found, returns [None].
*)
let env_get k env =
  let k = env_resolve env k in
  Attributes.find_opt k env.env_map

(** Add several bindings at once.

    This convenience function saves you the effort of calling
    {!val:env_add_cb} several times yourself.

    [env_of_list ~env:env [ (ns1, k1), f1 ; (ns2, k2), f2 ]] is equivalent to
    [env_add_cb ~prefix: ns1 k1 f1 (env_add_cb ~prefix: ns2 k2 f2 env)]. This means that one key
    is present twice in the list, the first association in the list
    will hide the second one in the resulting environment.

    The [env] optional argument is the environment to which bindings are added. If
    not provided, {!val:env_empty}[ ()] is used.
*)
let env_of_list ?(env=env_empty()) l =
  List.fold_right (fun ((prefix,name), f) env -> env_add_cb ~prefix name f env) l env

(** String representation of all the keys in the environment. *)
let string_of_env env =
  let f (prefix, name) _ acc =
    let s =
      match prefix with
        "" -> name
      | s -> s ^ ":" ^ name
    in
    s :: acc
  in
  String.concat ", " (Attributes.fold f env.env_map [])

(** {2:engine Templating engine}

    The [apply_*] functions apply a given environment and data to XML tree(s). These
    trees are given as parameter ({!apply_to_xmls}) or can be read from a
    file ({!apply_to_file}), or a string ({!apply_to_string}).

    The functions return the result of the rewrite as XML trees, or
    can write it to a file ({!apply_into_file}). They also return data
    as the result of the callbacks called, as in a classic fold function (callbacks
    take the data in parameter, as the environment, the attributes and subnodes
    of the rewritten node).

    The rewrite rules are applied until a fix-point is reached.
    If the [XTMPL_FIXPOINT_LIMIT] environment variable contains a valid integer [n],
    it is used as a fix-point limit: if no fix-point is reached in [n] iterations,
    then a [Failure] exception is raised.

{ol
{- A single iteration descends recursively into the XML tree. If an
    element has a callback associated in the environment, then the
    callback is applied to the current data and the node's attributes and children.

    {i Example}: consider the following XML:

    {v <album author="Bertrand Betsch" name="Orange Bleue Amère">
  <track>Vivre</track>
  <track>Tant mal que mal</track>
</album> v}

    This would look for a callback bound to [("","album")] in the environment
    and call it using
    [callback data env {("","author")->[ D "Bertrand Betsch"]|("","name")->[D "Orange Bleue Amère"]} xml]
    where [env] is the current environment and [xml] represents the
    two children [ <track>..</track> ] elements.
}
{- The callback returns a pair composed of (maybe new) data
     and a new list of elements that is used instead of the old element.

    {i Example}: assuming that the environnement was build using
    [env_add_cb "x2" (fun data _ _ xml -> (data, xml @ xml)) env],
    then [<x2>A</x2>] is rewritten as [AA].
}
{- The engine then recursively descends into those replaced
    elements (this means that a poorly conceived rule set may well never
    terminate).

    {i Example}: [<x2><x2>A</x2></x2>] is first rewritten as
    [<x2>A</x2><x2>A</x2>], and then as [AAAA].
}
{-  The [env_] element (see {!val:tag_env} is a special case: it is automatically
    replaced with its children (as if its callback was [(fun data _ _ xml -> (data, xml))]).

    [env_] effectively changes the environment
    used when processing its children by adding the bindings defined by
    its attributes (using {!val:env_add_xml}).

    {i Example}: [<env_ a="&lt;b&gt;A&lt;/b&gt;"><a/></env_>] is
    replaced by [<a/>], which in turn is replaced by
    [<b>A</b>].
}
{- If an element has a [defer_] attribute (that is greater
    than zero), then it is not processed and the attribute is decremented
    by one, and the process recursively applies to its children.

    {i Example}: [<x2 defer_="1"><x2>A</x2></x2>] is rewritten as
    [<x2 defer_="0">AA</x2>]. The {b next} iteration will effectively apply the
    rule to the node and return [AAAA].
}
{-  If an element has a [protect_] attribute, then the value
    must be CDATA and contains a list of names to remove from the environment
    when descending in the children. The names are separated by [','] or [';'],
    for example: [<foo protect_="title,id,foo:bar" ..>...</foo>].
}
}
*)

(**/**)

let limit =
  try Some (int_of_string (Sys.getenv "XTMPL_FIXPOINT_LIMIT"))
  with _ -> None

let max_rewrite_depth =
  try int_of_string (Sys.getenv "XTMPL_REWRITE_DEPTH_LIMIT")
  with _ -> 100

let push stack tag ?loc atts subs =
  let stack = (tag, atts, subs, loc) :: stack in
  if List.length stack > max_rewrite_depth then
    loop_error stack
  else
    stack

let set_namespaces =
  let f name v env =
    match name with
      ("xmlns",ns) ->
        begin
          let s = to_string ~xml_atts:false v in
          let iri = Iri.of_string s in
          { env with env_ns = SMap.add ns iri env.env_ns }
        end
    | _ -> env
  in
  fun env atts -> Attributes.fold f atts env

let rec eval_env stack data env ?loc atts subs =
(*  prerr_endline
    (Printf.sprintf "env: subs=%s"
      (String.concat "" (List.map string_of_xml subs)));
*)
  let env = Attributes.fold
    (fun (prefix,s) v acc ->
       (*       prerr_endline (Printf.sprintf "env: %s=%s" s v);*)
       env_add_xml ~prefix s v acc)
      atts env
  in
  eval_xmls stack data env subs

and eval_xmls stack data env xmls =
  let (data, l) =
    List.fold_left
      (fun (data, acc) xml ->
         let (data, subs) = eval_xml stack data env xml in
         (data, subs :: acc)
      )
      (data, [])
      xmls
  in
  (data, List.flatten (List.rev l))

and eval_atts =
  let f stack env name xmls (data, map) =
    let (data, xmls) = eval_xmls stack data env xmls in
    (data, Attributes.add name xmls map)
  in
  fun stack data env atts ->
    Attributes.fold (f stack env) atts (data,Attributes.empty)

and eval_xml stack data env xml =
  match xml with
  | D _ | C _ | PI _ -> (data, [ xml ])
  | E { name ; atts ; subs ; loc } ->
      let (data, atts) = eval_atts stack data env atts in
      let env = set_namespaces env atts in
      let env_protect = protect_in_env env atts in
      match name with
        ("", t) when t = tag_env ->
          let stack = push stack name atts subs in
          eval_env stack data env_protect ?loc atts subs
      | (prefix, tag) ->
          match env_get (prefix, tag) env with
          | Some f ->
              let (defer,atts) =
                match get_att_cdata atts ("",att_defer) with
                  None -> (0, atts)
                | Some s ->
                    try
                      let n = int_of_string s in
                      (n, Attributes.remove ("", att_defer) atts)
                    with
                      _ -> (0, atts)
              in
              if defer > 0 then
                (* defer evaluation, evaluate subs first *)
                (
                 let (data, subs) = eval_xmls stack data env_protect subs in
                 let atts = Attributes.add ("",att_defer)
                   [cdata (string_of_int (defer-1))] atts
                 in
                 (data, [ node ?loc (prefix, tag) ~atts subs ])
                )
              else
                (
                 let xml =
                   try
                     let stack = push stack (prefix,tag) ?loc atts subs in
                     Some (stack, f data env_protect ?loc atts subs)
                   with No_change -> None
                 in
                 match xml with
                   None ->
                     (* no change in node, eval children anyway *)
                     let (data, subs) = eval_xmls stack data env_protect subs in
                     (data, [node ?loc (prefix, tag) ~atts subs])
                 | Some (stack, (data, xmls)) ->
                     (*prerr_endline
                        (Printf.sprintf "=== Evaluated tag %s -> %s\n"
                        tag (String.concat "" (List.map string_of_xml xmls)));*)
                     eval_xmls stack data env_protect xmls
                )
                  (* eval f before subs *)
          | None ->
              let (data, subs) = eval_xmls stack data env_protect subs in
              (data, [ node ?loc (prefix, tag) ~atts subs ])

and (eval_string : rewrite_stack -> 'a -> 'a env -> string -> 'a * string) =
  fun stack data env s ->
    let xmls = from_string s in
    let (data, xmls) = eval_xmls stack data env xmls in
    (data, to_string xmls)


let rec fix_point_snd ?(n=0) f (data, x) =
  match limit with
    Some l when n >= l ->
      fixpoint_limit l
  | _ ->
      let (data, y) = f (data, x) in
      if y = x then (data, x) else fix_point_snd ~n: (n+1) f (data, y)

(**/**)


(** As {!val:apply_to_string}, but applies to a list of XML trees.*)
let apply_to_xmls data env xmls =
  (*prerr_endline (string_of_env env);*)
  let f (data, xmls) = eval_xmls [] data env xmls in
  fix_point_snd f (data, xmls)

(** As {!val:apply_to_string}, but applies to a single XML tree.*)
let apply_to_xml data env xml = apply_to_xmls data env [xml]

(** As {!val:apply_to_string}, but applies to a doc. *)
let apply_to_doc data env d =
  let (data, elements) = apply_to_xmls data env d.elements in
  (data, doc d.prolog elements)

(** Applies as many iterations as necessary to a piece of XML (represented
    as an unparsed string) to reach a fix-point.

    See {!section-engine} for how an iteration is applied.
*)
let (apply_to_string : 'a -> 'a env -> string -> 'a * tree list) = fun data env s ->
  let xmls = from_string s in
  apply_to_xmls data env xmls

(** As {!val:apply_to_string}, but reads the XML from a file. *)
let apply_to_file data env file =
  let xmls = from_file file in
  apply_to_xmls data env xmls

(** As {!val:apply_to_file}, but writes the result back to a file.

    For instance, [apply_to_file data env ~infile:"source.xml" ~outfile: "dest.xml"].

    When provided, optional argument [head] is prepended
    to the XML that is output to the file. By default, nothing is prepended.
*)
let apply_into_file data ?head env ~infile ~outfile =
  let (data, xmls) = apply_to_file data env infile in
  let s = to_string xmls in
  let s = match head with None -> s | Some h -> h^s in
  Misc.file_of_string ~file: outfile s;
  data

(** As {!val:apply_into_file}, but read the XML from a string instead of a file.
*)
let apply_string_into_file data ?head env ~outfile s =
  let (data, xmls) = apply_to_string data env s in
  let s = to_string xmls in
  let s = match head with None -> s | Some h -> h^s in
  Misc.file_of_string ~file: outfile s;
  data