Source file engine.ml

(*********************************************************************************)
(*                Stog                                                           *)
(*                                                                               *)
(*    Copyright (C) 2012-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU General Public License as                    *)
(*    published by the Free Software Foundation, version 3 of the License.       *)
(*                                                                               *)
(*    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 General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU 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                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** *)

open Types;;
module Smap = Types.Str_map;;

module XR = Xtmpl.Rewrite
module Xml = Xtmpl.Xml

exception Cant_open_cache_file of string

type 'a level_fun =
  | Fun_stog of (stog XR.env -> stog -> Types.Doc_set.t -> stog)
  | Fun_data of ('a XR.env -> stog * 'a -> Types.Doc_set.t -> stog * 'a)
  | Fun_stog_data of ((stog * 'a) XR.env -> stog * 'a -> Types.Doc_set.t -> stog * 'a)

type 'a modul = {
      mod_data : 'a ;
      mod_levels : 'a level_fun Types.Int_map.t ;
      mod_name : string ;
    }

module type Module = sig
    type data
    val modul : data modul

    type cache_data
    val cache_load : stog -> data -> doc -> cache_data -> data
    val cache_store : stog -> data -> doc -> cache_data
  end

type stog_state =
  { st_stog : stog ;
    st_modules : (module Module) list ;
    st_docs : Types.Doc_set.t ;
  };;

let apply_module level env state modul =
  let module E = (val modul : Module) in
  match
    try Some (Int_map.find level E.modul.mod_levels)
    with Not_found -> None
  with
    None -> { state with st_modules = modul :: state.st_modules }
  | Some f ->
      let old_stog = state.st_stog in
      let stog = state.st_stog in
      let (stog, data) =
        try
          match f with
            Fun_stog f ->
              let stog = f env stog state.st_docs in
              (stog, E.modul.mod_data)
          | Fun_data f ->
              f (Obj.magic env) (stog, E.modul.mod_data) state.st_docs
          | Fun_stog_data f ->
              f (Obj.magic env) (stog, E.modul.mod_data) state.st_docs
        with
          XR.Error e ->
            let msg = Printf.sprintf
              "Error when applying module %s on level %d:\n%s"
              E.modul.mod_name level (XR.string_of_error e)
            in
            failwith msg
      in
      let modul =
        let module E2 = struct
          type data = E.data
          let modul = { E.modul with mod_data = data }
          type cache_data = E.cache_data
          let cache_load = E.cache_load
          let cache_store = E.cache_store
          end
        in
        (module E2 : Module)
      in
      let docs =
        let f id d set =
          match d.doc_out with
            None ->
              (* new element of existing element recreated *)
              Types.Doc_set.add id set
          | _ ->
              try ignore(Tmap.get old_stog.stog_docs id); set
              with _ ->
                  (* new element *)
                  Types.Doc_set.add id set
        in
        Tmap.fold f stog.stog_docs state.st_docs
      in
      { st_stog = stog ;
        st_modules = modul :: state.st_modules ;
        st_docs = docs ;
      }
;;

let (compute_level : 'a XR.env -> int -> stog_state -> stog_state) =
  fun env level state ->
    Log.info (fun m -> m "Computing level %d" level);
    let state = List.fold_left (apply_module level env)
      { state with st_modules = [] } state.st_modules
    in
    state
;;

let levels =
  let add level _ set = Types.Int_set.add level set in
  let f set m =
    let module M = (val m : Module) in
    Types.Int_map.fold add M.modul.mod_levels set
  in
  fun state ->
    List.fold_left f Types.Int_set.empty state.st_modules
;;

(***** Caching *****)


let cache_info_file stog = Filename.concat stog.stog_cache_dir "info";;
let stog_cache_name = "_stog";;

let cache_file name stog doc =
  let cache_dir = Filename.concat stog.stog_cache_dir name in
  Filename.concat cache_dir
    ((String.concat "/" doc.doc_path.Path.path)^"._doc")
;;

let get_cached_docs stog =
  let doc_dir = Filename.concat stog.stog_cache_dir stog_cache_name in
  let files = Find.find_list Find.Ignore [doc_dir]
    [Find.Type Unix.S_REG]
  in
  let load acc file =
    try
      let ic = open_in_bin file in
      let (doc : Types.doc) = input_value ic in
      close_in ic;
      doc :: acc
    with
      Failure s | Sys_error s ->
        Log.warn (fun m -> m "%s" s);
        acc
  in
  let docs = List.fold_left load [] files in
  Log.debug (fun m -> m "%d documents found in cache"
     (List.length docs));
  docs
;;

let set_doc_env doc stog doc_envs =
  let digest = Types.stog_md5 stog in
  Path.Map.add doc.doc_path digest doc_envs
;;

let apply_loaders state doc =
  let f_modul e =
    let module E = (val e : Module) in
    let cache_file = cache_file E.modul.mod_name state.st_stog doc in
    let ic =
      try open_in_bin cache_file
      with _ -> raise (Cant_open_cache_file cache_file)
    in
    let t = input_value ic in
    close_in ic;
    let data = E.cache_load state.st_stog E.modul.mod_data doc t in
    let module E2 = struct
      type data = E.data
      let modul = { E.modul with mod_data = data }
      type cache_data = E.cache_data
      let cache_load = E.cache_load
      let cache_store = E.cache_store
     end
    in
    (module E2 : Module)
  in
  let modules = List.map f_modul state.st_modules in
  let state = { state with st_modules = modules } in
  state
;;

let apply_storers state doc =
  let f_modul e =
    let module E = (val e : Module) in
    let cache_file = cache_file E.modul.mod_name state.st_stog doc in
    let cache_dir = Filename.dirname cache_file in
   Stog_base.Misc.safe_mkdir cache_dir ;
    let oc = open_out_bin cache_file in
    let t = E.cache_store state.st_stog E.modul.mod_data doc in
    Marshal.to_channel oc t [Marshal.Closures];
    close_out oc
  in
  List.iter f_modul state.st_modules
;;

let get_cached_documents state env =
 Stog_base.Misc.safe_mkdir state.st_stog.stog_cache_dir;
  let info_file = cache_info_file state.st_stog in
  let (doc_envs, stog) =
    if Sys.file_exists info_file then
      begin
        let ic = open_in_bin info_file in
        let ((doc_envs, deps, id_map) :
           (string Path.Map.t * Types.Depset.t Smap.t *
            (Path.path * string option) Smap.t Path.Map.t)) =
          input_value ic
        in
        close_in ic;
        let stog = { state.st_stog with
            stog_deps = deps ;
            stog_id_map = id_map ;
          }
        in
        (doc_envs, stog)
      end
    else
      (Path.Map.empty, state.st_stog)
  in
  let state = { state with st_stog = stog } in
  let digest = Types.stog_md5 state.st_stog in
  Log.debug (fun m -> m "digest(stog)=%s" digest);

  let docs = get_cached_docs state.st_stog in
  let doc_by_path =
    let map = List.fold_left
      (fun map doc -> Types.Str_map.add
         (Path.to_string doc.doc_path) doc map)
        Types.Str_map.empty docs
    in
    fun path -> Types.Str_map.find path map
  in
  let f (state, cached, kept_deps, kept_id_map) doc =
    let path = doc.doc_path in
    let same_doc_env =
      try
        let d = Path.Map.find path doc_envs in
        Log.debug (fun m -> m "digest(path=%s,stog)=%s"
            (Path.to_string path) d);
        d = digest
      with Not_found ->
          Log.debug
            (fun m -> m "cached doc %s not found in stog"
               (Path.to_string path));
          false
    in
    let use_cache =
      if same_doc_env then
        begin
          let src_cache_file = cache_file stog_cache_name state.st_stog doc in
          let src_cache_time =Stog_base.Misc.file_mtime src_cache_file in
          let deps_time = Deps.max_deps_date state.st_stog doc_by_path
            (Path.to_string doc.doc_path)
          in
          Log.debug
           (fun m -> m "deps_time for %S = %s, last generated on %s" src_cache_file
             (Stog_base.Misc.string_of_time deps_time)
             (match src_cache_time with None -> "" | Some d ->Stog_base.Misc.string_of_time d)
            );
          match src_cache_time with
            None -> false
          | Some t_doc -> deps_time < t_doc
        end
      else
        (
         Log.debug (fun m ->
           m "path=%s not same env" (Path.to_string path));
         false
        )
    in
    if use_cache then
      begin
        let state = apply_loaders state doc in
        (* keep deps of this document, as it did not change *)
        let kept_deps =
          let spath = Path.to_string path in
          try Smap.add spath (Smap.find spath state.st_stog.stog_deps) kept_deps
          with Not_found -> kept_deps
        in
        let kept_id_map =
          try Path.Map.add path
            (Path.Map.find path state.st_stog.stog_id_map) kept_id_map
          with
            Not_found -> kept_id_map
        in
        (state, doc :: cached, kept_deps, kept_id_map)
      end
    else
      begin
        (* do not keep deps of this document, as it will be recomputed *)
        (state, cached, kept_deps, kept_id_map)
      end
  in
  let (state, cached, kept_deps, kept_id_map) =
    List.fold_left f
      (state, [], Smap.empty, Path.Map.empty) docs
  in
  let stog = {
      state.st_stog with
      stog_deps = kept_deps ;
      stog_id_map = kept_id_map ;
    }
  in
  let state = { state with st_stog = stog } in
  (state, cached)
;;

let cache_doc state doc =
  let cache_file = cache_file stog_cache_name state.st_stog doc in
 Stog_base.Misc.safe_mkdir (Filename.dirname cache_file);
  let oc = open_out_bin cache_file in
  output_value oc doc ;
  close_out oc ;
  apply_storers state doc
;;

let output_cache_info stog doc_envs =
  let info_file = cache_info_file stog in
  (*Tmap.iter
    (fun doc_id doc ->
       ignore(Deps.max_deps_date stog
        (fun path -> snd (Types.doc_by_path stog (Path.of_string path)))
          (Path.to_string doc.Types.doc_path))
    )
       stog.Types.stog_docs;
  *)
  let v = (doc_envs, stog.stog_deps, stog.stog_id_map) in
  let oc = open_out_bin info_file in
  output_value oc v;
  close_out oc
;;

let state_merge_cdata ?docs state =
 let docs =
    match docs with
      None -> Types.doc_list state.st_stog
    | Some l -> List.map (fun id -> (id, Types.doc state.st_stog id)) l
  in
  let f stog (doc_id, doc) =
    let doc =
      match doc.doc_out with
        None ->
          doc
      | Some xmls ->
          { doc with doc_out = Some (XR.merge_cdata_list xmls) }
    in
    Types.set_doc stog doc_id doc
  in
  { state with st_stog = List.fold_left f state.st_stog docs }
;;

let set_docs_to_compute ?(use_cache=true) env state =
  match use_cache with
  | _ when not (Types.Doc_set.is_empty state.st_docs) ->
      state
  | false ->
      let st_docs = Tmap.fold
        (fun doc_id doc acc -> Types.Doc_set.add doc_id acc)
        state.st_stog.stog_docs Types.Doc_set.empty
      in
      { state with st_docs }
  | true ->
      let (state, cached) = get_cached_documents state env in
      Log.info (fun m -> m "%d documents kept from cache" (List.length cached));
      let f_doc (stog, cached) cached_doc =
        try
          let (doc_id, _) = Types.doc_by_path stog cached_doc.doc_path in
          (* replace document by cached one *)
          let stog = Types.set_doc stog doc_id cached_doc in
          (stog, Types.Doc_set.add doc_id cached)
        with _ ->
            (* document not loaded but cached; keep it as it may be a
               document from a cut-doc rule *)
            let stog = Types.add_doc stog cached_doc in
            let (doc_id, _) = Types.doc_by_path stog cached_doc.doc_path in
            (stog, Types.Doc_set.add doc_id cached)
      in
      let (stog, cached) = List.fold_left f_doc
        (state.st_stog, Types.Doc_set.empty) cached
      in
      let st_docs =
        Tmap.fold
          (fun doc_id doc acc ->
             if Types.Doc_set.mem doc_id cached then
               acc
             else
               Types.Doc_set.add doc_id acc
          )
          state.st_stog.stog_docs
          Types.Doc_set.empty
      in
      { state with st_stog = stog ; st_docs }
;;


let compute_levels ?use_cache env state =
  let levels = levels state in
  let state = set_docs_to_compute ?use_cache env state in
  let state = Types.Int_set.fold (compute_level env) levels state in
  state_merge_cdata state
;;


let rec make_fun (name, params, body) acc =
  let f data env ?loc atts subs =
    let vars = Xml.Name_map.fold
      (fun param default acc ->
         match XR.get_att atts param with
           None -> (param, XR.atts_empty, default) :: acc
         | Some v -> (param, XR.atts_empty, v) :: acc
      )
      params []
    in
    let env = env_of_defs ~env vars in
    let body = [ XR.node ("",XR.tag_env) ~atts body ] in
    let f data _ ?loc atts xmls =
      match Xml.Name_map.is_empty atts, xmls with
        true, [] -> (data, subs)
      | _ -> raise XR.No_change
    in
    let env = XR.env_add_cb "contents" f env in
    XR.apply_to_xmls data env body
  in
  (name, f) :: acc


and env_of_defs ?env defs =
  let f x acc =
    match x with
    | (key, atts, body) when Xml.Name_map.is_empty atts ->
        (key, fun data _ ?loc _ _ -> (data, body)) :: acc
    | _ ->  make_fun x acc
  in
  (* fold_right instead of fold_left to reverse list and keep associations
     in the same order as in declarations *)
  let l = List.fold_right f defs [] in
  XR.env_of_list ?env l
;;

(** FIXME: handle module requirements and already added modules *)
(* FIXME: add dependency ? *)
let env_of_used_mod stog ?(env=XR.env_empty()) modname =
  try
    let m = Types.Str_map.find modname stog.stog_modules in
    (*prerr_endline (Printf.sprintf "adding %d definitions from module %S"
      (List.length m.mod_defs) modname);*)
    env_of_defs ~env m.mod_defs
  with Not_found ->
    Log.warn (fun m -> m "No module %S" modname);
    env

let env_of_used_mods stog ?(env=XR.env_empty()) mods =
  Types.Str_set.fold (fun name env -> env_of_used_mod stog ~env name) mods env
;;

let fun_site_url stog data _env ?loc _ _ =
  (data, [ XR.cdata (Url.to_string stog.stog_base_url) ])
;;

let run ?(use_cache=true) ?default_style state =
  let stog = state.st_stog in
  let dir =
    if Filename.is_relative stog.stog_dir then
      Filename.concat (Sys.getcwd ()) stog.stog_dir
    else
      stog.stog_dir
  in
  let env = XR.env_of_list
    [
     (("", Tags.site_desc), (fun data _ ?loc _ _ -> (data, stog.stog_desc))) ;
     (("", Tags.site_email), (fun data _ ?loc _ _ -> (data, [ XR.cdata stog.stog_email ]))) ;
     (("", Tags.site_title), (fun data _ ?loc _ _ -> (data, [ XR.cdata stog.stog_title ]))) ;
     (("", Tags.stog_dir), (fun data _ ?loc _ _ -> (data, [ XR.cdata dir ]))) ;
     (("", Tags.site_url), fun_site_url stog) ;
    ]
  in
  let env = env_of_used_mods ~env stog stog.stog_used_mods in
  let env = env_of_defs ~env stog.stog_defs in
  compute_levels ~use_cache env state
;;

let encode_for_url s =
  let len = String.length s in
  let b = Buffer.create len in
  for i = 0 to len - 1 do
    match s.[i] with
    | 'A'..'Z' | 'a'..'z' | '0'..'9'
    | '_' | '-' | '.' | '!' | '*' | '+' | '/' ->
        Buffer.add_char b s.[i]
    | c -> Printf.bprintf b "%%%02x" (Char.code c)
  done;
  Buffer.contents b
;;

let doc_dst_path stog doc =
  let path =
    match doc.doc_path.Path.path with
      [] -> failwith "Invalid path: []"
    | p -> p
  in
  if doc.doc_lang_dep then
    match stog.stog_lang with
      None -> path
    | Some lang ->
        match List.rev path with
          h :: q -> List.rev ((h^"."^lang) :: q)
        | _ -> assert false
  else
    path

let doc_dst (*?(encode=true)*) stog doc =
  let path = doc_dst_path stog doc in
  (*let dst = if encode then List.map encode_for_url path else path in*)
  Url.append stog.stog_base_url path
;;

let doc_dst_file stog doc =
  let path = doc_dst_path stog doc in
  List.fold_left Filename.concat stog.stog_outdir path

let doc_url stog doc =
  let url_path = doc_dst_path stog doc in
  let url = Url.append stog.stog_base_url url_path in
  match String.lowercase_ascii (Url.scheme url) with
    "file" -> url
  | _ ->
      let p = Url.path url in
      match List.rev p with
      | "index.html" :: q -> Url.with_path url (List.rev ("" :: q))
      | _ -> url
;;

let output_doc ~gen_cache state doc =
  let file = doc_dst_file state.st_stog doc in
 Stog_base.Misc.safe_mkdir (Filename.dirname file);
  match doc.doc_out with
    None ->
      failwith
        (Printf.sprintf "Element %S not computed!"
         (Path.to_string doc.doc_path)
        )
  | Some xmls ->
      let oc = open_out file in
      let xmldoc =
        let prolog = match doc.doc_prolog with
            None -> Xml.prolog []
          | Some p -> p
        in
        XR.doc prolog xmls
      in
      let xmldoc =
        match Xml.doctype_name xmldoc with
        | Some (_,s) when String.lowercase_ascii s = "html" ->
            let elements = List.map Html5.hack_self_closed xmldoc.Xml.elements in
            { xmldoc with Xml.elements }
        | _ -> xmldoc
      in
      output_string oc (XR.doc_to_string ~xml_atts: false xmldoc);
      close_out oc;
      if gen_cache then cache_doc state doc
;;

let output_docs ~gen_cache ?docs state =
  let stog = state.st_stog in
  let docs =
    match docs with
      None ->
        Tmap.fold
          (fun _ doc acc -> output_doc ~gen_cache state doc ; doc :: acc)
          stog.stog_docs []
    | Some l -> List.iter (output_doc ~gen_cache state) l; l
  in
  let doc_envs = List.fold_left
    (fun doc_envs doc -> set_doc_env doc stog doc_envs)
      Path.Map.empty docs
  in
  if gen_cache then output_cache_info stog doc_envs
;;

let copy_other_files stog =
  let report_error msg = Log.err 
    (fun m -> m "Html.copy_other_files: %s" msg)
  in
  let copy_file src dst =
    let com = Printf.sprintf "cp -f %s %s" (Filename.quote src) (Filename.quote dst) in
    match Sys.command com with
      0 -> ()
    | n ->
        let msg = Printf.sprintf "Command failed [%d]: %s" n com in
        report_error msg
  in
  let f_file dst path name =
    let dst = Filename.concat dst name in
    let src = Filename.concat path name in
    copy_file src dst
  in
  let rec f_dir dst path name t =
    let dst = Filename.concat dst name in
    let path = Filename.concat path name in
   Stog_base.Misc.safe_mkdir dst;
    iter dst path t
  and iter dst path t =
    Types.Str_set.iter (f_file dst path) t.files ;
    Types.Str_map.iter (f_dir dst path) t.dirs
  in
  iter stog.stog_outdir stog.stog_dir stog.stog_files
;;

let generate ?(use_cache=true) ?(gen_cache=true) ?default_style ?only_docs stog modules =
  begin
    match stog.stog_lang with
      None -> ()
    | Some lang -> Log.info (fun m -> m "Generating pages for language %s" lang);
  end;
 Stog_base.Misc.safe_mkdir stog.stog_outdir;
  let only_docs =
    match only_docs with
      None -> None
    | Some l ->
        let f s =
          let path = Path.of_string s in
          let (doc_id, _) = Types.doc_by_path stog path in
          doc_id
        in
        Some (List.map f l)
  in
  let st_docs =
    match only_docs with
      None -> Types.Doc_set.empty
    | Some ids ->
        let set =
          List.fold_right Types.Doc_set.add
            ids Types.Doc_set.empty
        in
        set
  in
  let state = { st_stog = stog ; st_modules = modules ; st_docs } in
  let state = run ~use_cache ?default_style state in
  match only_docs with
    None ->
      output_docs ~gen_cache state ;
      copy_other_files state.st_stog
  | Some ids ->
      let docs = List.map (Types.doc state.st_stog) ids in
      output_docs ~gen_cache ~docs state
;;


(*** Convenient functions to create level_fun's ***)


let get_in_env data env (prefix, s) =
  let node = [ XR.node (prefix,s) [] ] in
  let (data, node2) = XR.apply_to_xmls data env node in
  if node2 = node then (data, []) else (data, node2)
;;

let opt_in_env data env (prefix, s) =
  let node = [ XR.node (prefix,s) [] ] in
  let (data, node2) = XR.apply_to_xmls data env node in
  if node2 = node then (data, None) else (data, Some node2)
;;

let get_in_args_or_env data env args s =
  match XR.get_att args s with
    None -> get_in_env data env s
  | Some xmls -> (data, xmls)
;;

let get_path data env =
  let (data, xmls) = get_in_env data env ("", Tags.doc_path) in
  match XR.merge_cdata_list xmls with
    [XR.D s] -> (data, Path.of_string s.Xml.text)
  | xmls -> Path.invalid (XR.to_string xmls)
;;

let get_path_in_args_or_env data env args =
  let (data,x) = get_in_args_or_env data env args ("", Tags.doc_path) in
  match XR.merge_cdata_list x with
    [XR.D s] -> (data, Path.of_string s.Xml.text)
  | xmls -> Path.invalid (XR.to_string xmls)
;;

let get_doc_out stog doc =
  match doc.doc_out with
    None ->
      let (stog, xmldoc) =
        let default =
          match doc.doc_type with
            "by-topic" -> Tmpl.by_topic
          | "by-keyword" -> Tmpl.by_keyword
          | "by-month" -> Tmpl.by_month
          | "rss" -> Tmpl.rss
          | _ -> Tmpl.page
        in
        Tmpl.get_template_doc stog ~doc default (doc.doc_type^".tmpl")
      in
      let xmls = xmldoc.Xml.elements in
      let doc = { doc with
          doc_prolog = Some xmldoc.Xml.prolog ;
          doc_out = Some xmls ;
        }
      in
      (stog, doc, xmls)
  | Some xmls ->
      (stog, doc, xmls)
;;

let get_languages data env =
  match opt_in_env data env ("", "languages") with
  | (data, Some [XR.D s]) ->
      (data, Stog_base.Misc.split_string s.Xml.text [','; ';' ; ' '])
  | (data, Some xmls) ->
      failwith ("Invalid languages specification: "^(XR.to_string xmls))
  | (data, None) -> (data, ["fr" ; "en"])
;;

let env_add_lang_rules data env stog doc =
  match stog.stog_lang with
    None ->
      (data,
       XR.env_add_cb Tags.langswitch
         (fun data _ ?loc _ _ -> (data, [])) env)
  | Some lang ->
      let (data, languages) = get_languages data env in
      let map_lang lang =
        let url = doc_url { stog with stog_lang = Some lang } doc in
        let img_url = Url.concat stog.stog_base_url (lang^".png") in
        XR.node ("", "a")
         ~atts: (XR.atts_of_list [("", "href"), [ XR.cdata (Url.to_string url) ]])
         [
           XR.node ("", "img")
              ~atts: (XR.atts_of_list
               [ ("", "src"), [ XR.cdata (Url.to_string img_url) ] ;
                 ("", "title"), [ XR.cdata lang ] ;
                 ("", "alt"), [ XR.cdata lang]
               ])
               []
          ]
      in
      let f data _env ?loc args _subs =
        let languages = List.filter ((<>) lang) languages in
        (data, List.map map_lang languages)
      in
      let env = XR.env_add_cb Tags.langswitch f env in
      let to_remove = List.filter ((<>) lang) languages in
      let f_keep acc _env ?loc _args subs = (acc, subs) in
      let f_remove acc _env ?loc _args _subs = (acc, []) in
      let rules =
        (("", lang), f_keep) ::
          (List.map (fun lang -> (("", lang), f_remove)) to_remove)
      in
      (data, XR.env_of_list ~env rules)
;;

let doc_env data env stog doc =
  let env = env_of_used_mods stog ~env doc.doc_used_mods in
  let env = env_of_defs ~env doc.doc_defs in
(*  prerr_endline
    (Printf.sprintf "doc=%s\ndefs=%s"
      (Path.to_string doc.doc_path)
      (String.concat "\n"
        (List.map (fun ((p,name),_,subs) -> Printf.sprintf "%s:%s=>%s" p name (XR.string_of_xmls subs))
          doc.doc_defs)
      )
    );
  prerr_endline ("env_of_defs => "^(XR.string_of_env env));
*)
  let rules = [
      ("", Tags.doc_path),
      (fun  acc _ ?loc _ _ ->
         (acc, [XR.cdata (Path.to_string doc.doc_path)]))
    ]
  in
  let env = XR.env_of_list ~env rules in
  let (data, env) = env_add_lang_rules data env stog doc in
  (data, env)

type 'a stog_doc_rules =
  Types.stog -> Types.doc_id -> (XR.name * 'a XR.callback) list

let apply_stog_env_doc stog env doc_id =
  let doc = Types.doc stog doc_id in
  let (stog, env) = doc_env stog env stog doc in
  let (stog, doc, xmls) = get_doc_out stog doc in
  if !Config.debug then
    prerr_endline (Printf.sprintf "apply_stog_env_doc: %s = %s"
     (Path.to_string doc.doc_path)
     (XR.to_string xmls));
  let (stog, xmls) = XR.apply_to_xmls stog env xmls in
  let doc = { doc with doc_out = Some xmls } in
  Types.set_doc stog doc_id doc
;;

let apply_stog_data_env_doc (stog,data) env doc_id =
  let doc = Types.doc stog doc_id in
  let ((stog, data), env) = doc_env (stog, data) env stog doc in
  let (stog, doc, xmls) = get_doc_out stog doc in
  if !Config.debug then
    prerr_endline (Printf.sprintf "apply_stog_data_env_doc: %s = %s"
     (Path.to_string doc.doc_path)
     (XR.to_string xmls));
  (*prerr_endline (Printf.sprintf "env=%s" (XR.string_of_env env));*)
  let ((stog, data), xmls) = XR.apply_to_xmls (stog, data) env xmls in
  let doc = { doc with doc_out = Some xmls } in
  (Types.set_doc stog doc_id doc, data)

let apply_data_env_doc (stog,data) env doc_id =
  let doc = Types.doc stog doc_id in
  let (data, env) = doc_env data env stog doc in
  let (stog, doc, xmls) = get_doc_out stog doc in
  if !Config.debug then
    prerr_endline (Printf.sprintf "apply_data_env_doc: %s = %s"
     (Path.to_string doc.doc_path)
     (XR.to_string xmls));
  let (data, xmls) = XR.apply_to_xmls data env xmls in
  let doc = { doc with doc_out = Some xmls } in
  (Types.set_doc stog doc_id doc, data)
;;

let fun_apply_stog_doc_rules f_rules =
  let f_doc env doc_id stog =
    let rules = f_rules stog doc_id in
    let env = XR.env_of_list ~env rules in
    apply_stog_env_doc stog env doc_id
  in
  let f env stog docs = Types.Doc_set.fold (f_doc env) docs stog in
  Fun_stog f
;;

let fun_apply_stog_data_doc_rules f_rules =
  let f_doc env doc_id (stog, data) =
    let rules = f_rules stog doc_id in
    let env = XR.env_of_list ~env rules in
    apply_stog_data_env_doc (stog,data) env doc_id
  in
  let f env (stog, data) docs =
    Types.Doc_set.fold (f_doc env) docs (stog, data)
  in
  Fun_stog_data f
;;

let fun_apply_data_doc_rules f_rules =
  let f_doc env doc_id (stog, data) =
    let rules = f_rules stog doc_id in
    let env = XR.env_of_list ~env rules in
    apply_data_env_doc (stog,data) env doc_id
  in
  let f env (stog, data) docs =
    Types.Doc_set.fold (f_doc env) docs (stog, data)
  in
  Fun_data f
;;

(*** Engines ***)

type module_fun = Types.stog -> (module Module)

let modules = ref (Types.Str_map.empty : (Types.stog -> (module Module)) Types.Str_map.t);;

let register_module name f_mod =
  modules := Types.Str_map.add name f_mod !modules
;;

let module_by_name name =
  try Some (Types.Str_map.find name !modules)
  with Not_found -> None
;;

let modules () = Types.Str_map.fold
  (fun name f acc -> (name, f) :: acc) !modules []
;;