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

type node_type = 
    T_element of string
  | T_data

class type [ 'node ] extension = [ 'node ] Pxp_document.extension

class type [ 'ext, 'node ] pxp_extension_type =
object ('self)
    method clone : 'self
    method node : 'self Pxp_document.node
    method set_node : 'self Pxp_document.node -> unit

    method markup_node : 'node
    method set_markup_node : 'node -> unit

    method set_index : 'self Pxp_yacc.index -> unit
    method index : 'self Pxp_yacc.index
  end
;;


class type [ 'ext ] node = 
  object ('self)
    constraint 'ext = 'ext node #extension
    method pxp_node : (('ext, 'ext node) pxp_extension_type) Pxp_document.node

    method extension : 'ext
    method delete : unit
    method parent : 'ext node
    method root : 'ext node
    method orphaned_clone : 'ext node
    method orphaned_flat_clone : 'ext node
    method add_node : 'ext node -> unit
    method add_pinstr : Markup_dtd.proc_instruction -> unit
    method pinstr : string -> Markup_dtd.proc_instruction list
    method pinstr_names : string list
    method sub_nodes : 'ext node list
    method iter_nodes : ('ext node -> unit) -> unit
    method iter_nodes_sibl :
      ('ext node option -> 'ext node -> 'ext node option -> unit) -> unit
    method set_nodes : 'ext node list -> unit
    method data : string
    method node_type : node_type
    method attribute : string -> Markup_types.att_value
    method attribute_names : string list
    method attribute_type : string -> Markup_types.att_type
    method attributes : (string * Markup_types.att_value) list
    method required_string_attribute : string -> string
    method required_list_attribute : string -> string list
    method optional_string_attribute : string -> string option
    method optional_list_attribute : string -> string list
    method quick_set_attributes : (string * Markup_types.att_value) list -> unit
    method find : string -> 'ext node
    method reset_finder : unit
    method dtd : Markup_dtd.dtd
    method create_element :
      Markup_dtd.dtd -> node_type -> (string * string) list -> 'ext node
    method create_data : Markup_dtd.dtd -> string -> 'ext node
    method local_validate : unit
    method keep_always_whitespace_mode : unit
    method write_compact_as_latin1 : Markup_types.output_stream -> unit
    method internal_adopt : 'ext node option -> unit
    method internal_delete : 'ext node -> unit
    method internal_init : Markup_dtd.dtd -> string -> (string * string) list -> unit
  end
;;


class [ 'ext ] pxp_extension init_markup_node =
  (object (self : 'self)
    (* constraint 'ext = 'ext node #extension *)
    val mutable pxp_node = (None : 
			      'self Pxp_document.node option)
    (* 'ext pxp_extension Pxp_document.node option *)
    val mutable markup_node = (init_markup_node : 'ext node)

    val mutable index = (None : 'self Pxp_yacc.index option)

    method clone =
      {< >}

    method node =
      match pxp_node with
          None ->
            assert false
        | Some n -> n

    method set_node n =
      pxp_node <- Some n

    method markup_node = markup_node

    method set_markup_node n = markup_node <- n

    method set_index ix =
      index <- Some ix

    method index = 
      match index with
	  None -> assert false
	| Some x -> x

   end
     : ['ext, 'ext node] pxp_extension_type )
;;


class [ 'ext ] emulate_markup_node init_ext init_pxp_node = 
  object (self)
    constraint 'ext = 'ext node #extension
    val mutable pxp_node = (init_pxp_node : 
			      ('ext, 'ext #node) 
			      pxp_extension_type Pxp_document.node option)
    val mutable extension = (init_ext : 'ext)

    method pxp_node =
      match pxp_node with
	  None   -> assert false
	| Some n -> n 

    method extension = extension
    method delete = self # pxp_node # delete
    method parent = self # pxp_node # parent # extension # markup_node
    method root   = self # pxp_node # root # extension # markup_node

    method orphaned_clone =
      let ext' = extension # clone in
      let pxp' = self # pxp_node # orphaned_clone in
      let n = new emulate_markup_node ext' (Some pxp') in
      ext' # set_node (n : 'ext #node  :> 'ext node);
      pxp' # extension # set_markup_node n;
      n

     method orphaned_flat_clone =
      let ext' = extension # clone in
      let pxp' = self # pxp_node # orphaned_flat_clone in
      let n = new emulate_markup_node ext' (Some pxp') in
      ext' # set_node (n : 'ext #node  :> 'ext node);
      pxp' # extension # set_markup_node n;
      n

     method dtd = self # pxp_node # dtd

     method add_node (n : 'ext node) =
       let n_pxp = n # pxp_node in
       self # pxp_node # add_node n_pxp

     method add_pinstr pi =
       self # pxp_node # add_pinstr pi

     method sub_nodes =
       let l = self # pxp_node # sub_nodes in
       List.map (fun n_pxp -> n_pxp # extension # markup_node) l

     method pinstr name =
       self # pxp_node # pinstr name

     method pinstr_names =
       self # pxp_node # pinstr_names

     method iter_nodes f =
       self # pxp_node # iter_nodes
	 (fun n_pxp -> f (n_pxp # extension # markup_node))

     method iter_nodes_sibl f =
       self # pxp_node # iter_nodes_sibl
	 (fun left_pxp node_pxp right_pxp ->
	    let left =
	      match left_pxp with 
		  None       -> None
		| Some n_pxp -> Some (n_pxp # extension # markup_node) in
	    let right =
	      match right_pxp with 
		  None       -> None
		| Some n_pxp -> Some (n_pxp # extension # markup_node) in
	    let node =
	      node_pxp # extension # markup_node in
	    f left node right
	 )

     method set_nodes (l : 'ext node list) =
       let l_pxp = List.map (fun n -> n # pxp_node) l in
       self # pxp_node # set_nodes l_pxp

     method data = self # pxp_node # data

     method node_type =
       match self # pxp_node # node_type with
	   Pxp_document.T_data         -> T_data
	 | Pxp_document.T_element name -> T_element name
	 | Pxp_document.T_super_root   -> T_element "-vr"
	 | Pxp_document.T_pinstr _     -> T_element "-pi"
	 | _ -> assert false

     method attribute name =
       self # pxp_node # attribute name

     method attribute_names =
       self # pxp_node # attribute_names

     method attribute_type name =
       self # pxp_node # attribute_type name

     method attributes =
       self # pxp_node # attributes

     method required_string_attribute name =
       self # pxp_node # required_string_attribute name

     method required_list_attribute name =
       self # pxp_node # required_list_attribute name

     method optional_string_attribute name =
       self # pxp_node # optional_string_attribute name

     method optional_list_attribute name =
       self # pxp_node # optional_list_attribute name

     method quick_set_attributes l =
       self # pxp_node # quick_set_attributes l

     method find (name : string) =
       let index = self # root # pxp_node # extension # index in
       let n = index # find name in (* may raise Not_found *)
       n # extension # markup_node

     method reset_finder = ()

     method create_element dtd nt atts =
       let nt_pxp =
	 match nt with
	     T_data -> Pxp_document.T_data
	   | T_element name -> Pxp_document.T_element name in
       let node_pxp =
	 self # pxp_node # create_element dtd nt_pxp atts in
       let ext' = extension # clone in
       let n = new emulate_markup_node ext' (Some node_pxp) in
       ext' # set_node (n : 'ext #node  :> 'ext node);
       node_pxp # extension # set_markup_node n;
       n

     method create_data dtd s =
       let node_pxp =
	 self # pxp_node # create_data dtd s in
       let ext' = extension # clone in
       let n = new emulate_markup_node ext' (Some node_pxp) in
       ext' # set_node (n : 'ext #node  :> 'ext node);
       node_pxp # extension # set_markup_node n;
       n

     method keep_always_whitespace_mode =
       self # pxp_node # keep_always_whitespace_mode

     method write_compact_as_latin1 out =
       self # pxp_node # write_compact_as_latin1 out

     method local_validate =
       self # pxp_node # local_validate()

     method internal_adopt (p:'ext node option) =
       assert false;
       ()

     method internal_delete (n:'ext node) =
       assert false;
       ()
 
     method internal_init (d:Markup_dtd.dtd) (s:string) (atts:(string*string)list) =
       assert false;
       ()
  end
;;

class [ 'ext ] data_impl ext data =
  object (self)
    inherit [ 'ext ] emulate_markup_node ext None
    constraint 'ext = 'ext node #extension
    initializer
      if data <> "" then
	failwith "Emulation of Markup_document: Cannot instantiate data node with non-empty string";
      let self' = (self : 'ext #node :> 'ext node ) in
      pxp_node <- Some (new Pxp_document.data_impl (new pxp_extension self'))

  end
;;

class [ 'ext ] element_impl ext =
  object (self)
    inherit [ 'ext ] emulate_markup_node ext None
    initializer
      let self' = (self : 'ext #node :> 'ext node ) in
      pxp_node <- Some (new Pxp_document.element_impl (new pxp_extension self'))
  end
;;


class [ 'ext ] document w =
  object (self)
    val pxp_doc = new Pxp_document.document 
		    (w : Markup_types.collect_warnings :> Pxp_types.collect_warnings)

    val mutable standalone_flag = false

    method init_xml_version v =
      pxp_doc # init_xml_version v

    method xml_version =
      pxp_doc # xml_version

    method init_xml_standalone b =
      standalone_flag <- b

    method xml_standalone = standalone_flag

    method init_root (r : 'ext node) =
      pxp_doc # init_root (r # pxp_node);
      self # dtd # set_standalone_declaration standalone_flag
        (* questionable *)

    method root =
      let pxp_root = pxp_doc # root in
      pxp_root # extension # markup_node

    method dtd =
      pxp_doc # dtd

    method add_pinstr pi =
      pxp_doc # add_pinstr pi

    method pinstr name =
      pxp_doc # pinstr name

    method pinstr_names =
      pxp_doc # pinstr_names

    method write_compact_as_latin1 out =
      pxp_doc # write_compact_as_latin1 out

  end
;;

(* ======================================================================
 * History:
 *
 * $Log$
 * Revision 1.1  2000/11/17 09:57:30  lpadovan
 * Initial revision
 *
 * Revision 1.6  2000/08/18 20:19:00  gerd
 * 	Changed the emulation: there are now wrapper objects for nodes.
 * This was necessary because node_type changed in PXP such that it became
 * incompatible with Markup's node_type.
 *
 * Revision 1.5  2000/07/14 21:35:35  gerd
 * 	Updated because of the simplification of Pxp_types.collect_warnings.
 *
 * Revision 1.4  2000/07/08 17:40:50  gerd
 * 	Updated the simulation.
 *
 * Revision 1.3  2000/06/14 22:19:27  gerd
 * 	Update because of additional 'encoding' methods.
 *
 * Revision 1.2  2000/05/30 00:08:40  gerd
 * 	Bugfix.
 *
 * Revision 1.1  2000/05/29 23:43:51  gerd
 * 	Initial compatibility revision.
 *
 *)