(* $Id$
 * ----------------------------------------------------------------------
 *)

open Markup_types
open Markup_dtd
open Markup_document

type config =
    { warner : collect_warnings;
      errors_with_line_numbers : bool;
      processing_instructions_inline : bool;
      virtual_root : bool;
      debugging_mode : bool;
    }


type source =
    Entity of ((dtd -> Pxp_entity.entity) * Markup_reader.resolver)
  | Channel of in_channel
  | File of string
  | Latin1 of string
  | ExtID of (ext_id * Markup_reader.resolver)

type 'ext domspec =
    { map : (node_type, 'ext node) Hashtbl.t;
      default_element : 'ext node;
    }


class default_ext =
  object(self)
    val mutable node = (None : ('a extension node as 'a) option)
    method clone = {< >}
    method node =
      match node with
          None ->
            assert false
        | Some n -> n
    method set_node n =
      node <- Some n
  end
;;


let default_extension = new default_ext;;

let default_config = 
  { warner = new collect_warnings;
    errors_with_line_numbers = true;
    processing_instructions_inline = false;
    virtual_root = false;
    debugging_mode = false;
  }


let default_dom =
  let d = Hashtbl.create 2 in
  Hashtbl.add d T_data (new data_impl default_extension "");
  { map = d;
    default_element = new element_impl default_extension
  }
;;


let pxp_config cfg =
  { Pxp_yacc.default_config with
	Pxp_yacc.warner = (cfg.warner :> Pxp_types.collect_warnings);
	Pxp_yacc.errors_with_line_numbers = cfg.errors_with_line_numbers;
	Pxp_yacc.enable_pinstr_nodes = cfg.processing_instructions_inline;
	Pxp_yacc.enable_super_root_node = cfg.virtual_root;
	Pxp_yacc.encoding = `Enc_iso88591;
	Pxp_yacc.recognize_standalone_declaration = false;
	Pxp_yacc.debugging_mode = cfg.debugging_mode;
  }
;;


class pxp_resolver r =
  object (self)
    val markup_resolver = r

    method init_rep_encoding enc =
      assert (enc = `Enc_iso88591 )
  
    method init_warner w =
      ()

    method rep_encoding = `Enc_iso88591

    method open_in xid = 
      markup_resolver # open_in xid

    method close_in =
      markup_resolver # close_in

    method close_all =
      markup_resolver # close_in

    method change_encoding enc =
      markup_resolver # change_encoding enc

    method clone =
      ( {< markup_resolver = markup_resolver # clone >} 
	: #Pxp_reader.resolver :> Pxp_reader.resolver )
  end
;;


let pxp_source src =
  match src with
      Entity (mkent, res) -> Pxp_yacc.Entity(mkent, new pxp_resolver res)
    | ExtID (id, res)     -> Pxp_yacc.ExtID(id, new pxp_resolver res)
    | Channel ch          -> Pxp_yacc.from_channel 
	                       ~system_encoding:`Enc_iso88591 ch
    | File f              -> Pxp_yacc.from_file 
	                       ~system_encoding:`Enc_iso88591 f
    | Latin1 s            -> Pxp_yacc.from_string ~fixenc:`Enc_iso88591 s
;;


let pxp_dom dom =
  let dex =
    try Hashtbl.find dom.map T_data 
    with Not_found -> assert false
  in
  let eex = dom.default_element in
  let m = Hashtbl.create 100 in
  Hashtbl.iter
    (fun nt ex ->
       match nt with
	   T_element name when name <> "-vr" && name <> "-pi" -> 
	     let pxp_ex = ex # pxp_node in
	     Hashtbl.add m name pxp_ex
	 | _              -> ()
    )
    dom.map;
  let srex =
    try
      Some ((Hashtbl.find dom.map (T_element "-vr")) # pxp_node)
    with
	Not_found -> None
  in
  let piex =
    try
      Some ((Hashtbl.find dom.map (T_element "-pi")) # pxp_node)
    with
	Not_found -> None
  in
  Pxp_document.make_spec_from_mapping
    ?super_root_exemplar:srex
    ?default_pinstr_exemplar:piex
    ~data_exemplar:(dex # pxp_node)
    ~default_element_exemplar:(eex # pxp_node)
    ~element_mapping:m
    ()
;;


let markup_document w index doc =
  let mdoc = new document w in
  mdoc # init_xml_version (doc # xml_version);
  mdoc # init_xml_standalone (doc # xml_standalone);
  let r = doc # root # extension in
  r # set_index index;
  mdoc # init_root (r # markup_node);
  List.iter
    (fun piname ->
       let l = doc # pinstr piname in
       List.iter 
	 (fun pi -> mdoc # add_pinstr pi)
	 l)
    (doc # pinstr_names);
  mdoc
;;



let parse_dtd_entity cfg src =
  Pxp_yacc.parse_dtd_entity
    (pxp_config cfg)
    (pxp_source src)
;;


let parse_document_entity cfg src dom =
  let index = (new Pxp_yacc.hash_index :> 'ext Pxp_yacc.index) in
  markup_document
    cfg.warner
    index
    (Pxp_yacc.parse_document_entity 
        ~id_index:index
	(pxp_config cfg)
	(pxp_source src)
	(pxp_dom dom))
;;


let parse_content_entity cfg src dtd dom =
  let index = (new Pxp_yacc.hash_index :> 'ext Pxp_yacc.index) in
  let n = 
    (Pxp_yacc.parse_content_entity
     ~id_index:index
       (pxp_config cfg)
       (pxp_source src)
       dtd
       (pxp_dom dom)) # extension in
  n # set_index index;
  n # markup_node
;;


let parse_wf_entity cfg src dom =
  let index = (new Pxp_yacc.hash_index :> 'ext Pxp_yacc.index) in
  (* Restriction: index is not filled! *)
  markup_document
    cfg.warner
    index 
    (Pxp_yacc.parse_wfdocument_entity
       (pxp_config cfg)
       (pxp_source src)
       (pxp_dom dom))
;;


(* ======================================================================
 * History:
 *
 * $Log$
 * Revision 1.1  2000/11/17 09:57:30  lpadovan
 * Initial revision
 *
 * Revision 1.4  2000/08/18 20:19:16  gerd
 * 	Updates in the emulation because of PXP changes.
 *
 * Revision 1.3  2000/07/14 21:35:35  gerd
 * 	Updated because of the simplification of Pxp_types.collect_warnings.
 *
 * Revision 1.2  2000/07/08 17:40:50  gerd
 * 	Updated the simulation.
 *
 * Revision 1.1  2000/05/29 23:43:51  gerd
 * 	Initial compatibility revision.
 *
 *)