--- /dev/null
+(* $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.
+ *
+ *)
+
projects / helm.git / blobdiff