helm/DEVEL/pxp/pxp/compatibility/markup_document.ml

   1 (* $Id$
   2  * ----------------------------------------------------------------------
   3  *)
   4
   5 type node_type =
   6     T_element of string
   7   | T_data
   8
   9 class type [ 'node ] extension = [ 'node ] Pxp_document.extension
  10
  11 class type [ 'ext, 'node ] pxp_extension_type =
  12 object ('self)
  13     method clone : 'self
  14     method node : 'self Pxp_document.node
  15     method set_node : 'self Pxp_document.node -> unit
  16
  17     method markup_node : 'node
  18     method set_markup_node : 'node -> unit
  19
  20     method set_index : 'self Pxp_yacc.index -> unit
  21     method index : 'self Pxp_yacc.index
  22   end
  23 ;;
  24
  25
  26 class type [ 'ext ] node =
  27   object ('self)
  28     constraint 'ext = 'ext node #extension
  29     method pxp_node : (('ext, 'ext node) pxp_extension_type) Pxp_document.node
  30
  31     method extension : 'ext
  32     method delete : unit
  33     method parent : 'ext node
  34     method root : 'ext node
  35     method orphaned_clone : 'ext node
  36     method orphaned_flat_clone : 'ext node
  37     method add_node : 'ext node -> unit
  38     method add_pinstr : Markup_dtd.proc_instruction -> unit
  39     method pinstr : string -> Markup_dtd.proc_instruction list
  40     method pinstr_names : string list
  41     method sub_nodes : 'ext node list
  42     method iter_nodes : ('ext node -> unit) -> unit
  43     method iter_nodes_sibl :
  44       ('ext node option -> 'ext node -> 'ext node option -> unit) -> unit
  45     method set_nodes : 'ext node list -> unit
  46     method data : string
  47     method node_type : node_type
  48     method attribute : string -> Markup_types.att_value
  49     method attribute_names : string list
  50     method attribute_type : string -> Markup_types.att_type
  51     method attributes : (string * Markup_types.att_value) list
  52     method required_string_attribute : string -> string
  53     method required_list_attribute : string -> string list
  54     method optional_string_attribute : string -> string option
  55     method optional_list_attribute : string -> string list
  56     method quick_set_attributes : (string * Markup_types.att_value) list -> unit
  57     method find : string -> 'ext node
  58     method reset_finder : unit
  59     method dtd : Markup_dtd.dtd
  60     method create_element :
  61       Markup_dtd.dtd -> node_type -> (string * string) list -> 'ext node
  62     method create_data : Markup_dtd.dtd -> string -> 'ext node
  63     method local_validate : unit
  64     method keep_always_whitespace_mode : unit
  65     method write_compact_as_latin1 : Markup_types.output_stream -> unit
  66     method internal_adopt : 'ext node option -> unit
  67     method internal_delete : 'ext node -> unit
  68     method internal_init : Markup_dtd.dtd -> string -> (string * string) list -> unit
  69   end
  70 ;;
  71
  72
  73 class [ 'ext ] pxp_extension init_markup_node =
  74   (object (self : 'self)
  75     (* constraint 'ext = 'ext node #extension *)
  76     val mutable pxp_node = (None :
  77                               'self Pxp_document.node option)
  78     (* 'ext pxp_extension Pxp_document.node option *)
  79     val mutable markup_node = (init_markup_node : 'ext node)
  80
  81     val mutable index = (None : 'self Pxp_yacc.index option)
  82
  83     method clone =
  84       {< >}
  85
  86     method node =
  87       match pxp_node with
  88           None ->
  89             assert false
  90         | Some n -> n
  91
  92     method set_node n =
  93       pxp_node <- Some n
  94
  95     method markup_node = markup_node
  96
  97     method set_markup_node n = markup_node <- n
  98
  99     method set_index ix =
 100       index <- Some ix
 101
 102     method index =
 103       match index with
 104           None -> assert false
 105         | Some x -> x
 106
 107    end
 108      : ['ext, 'ext node] pxp_extension_type )
 109 ;;
 110
 111
 112 class [ 'ext ] emulate_markup_node init_ext init_pxp_node =
 113   object (self)
 114     constraint 'ext = 'ext node #extension
 115     val mutable pxp_node = (init_pxp_node :
 116                               ('ext, 'ext #node)
 117                               pxp_extension_type Pxp_document.node option)
 118     val mutable extension = (init_ext : 'ext)
 119
 120     method pxp_node =
 121       match pxp_node with
 122           None   -> assert false
 123         | Some n -> n
 124
 125     method extension = extension
 126     method delete = self # pxp_node # delete
 127     method parent = self # pxp_node # parent # extension # markup_node
 128     method root   = self # pxp_node # root # extension # markup_node
 129
 130     method orphaned_clone =
 131       let ext' = extension # clone in
 132       let pxp' = self # pxp_node # orphaned_clone in
 133       let n = new emulate_markup_node ext' (Some pxp') in
 134       ext' # set_node (n : 'ext #node  :> 'ext node);
 135       pxp' # extension # set_markup_node n;
 136       n
 137
 138      method orphaned_flat_clone =
 139       let ext' = extension # clone in
 140       let pxp' = self # pxp_node # orphaned_flat_clone in
 141       let n = new emulate_markup_node ext' (Some pxp') in
 142       ext' # set_node (n : 'ext #node  :> 'ext node);
 143       pxp' # extension # set_markup_node n;
 144       n
 145
 146      method dtd = self # pxp_node # dtd
 147
 148      method add_node (n : 'ext node) =
 149        let n_pxp = n # pxp_node in
 150        self # pxp_node # add_node n_pxp
 151
 152      method add_pinstr pi =
 153        self # pxp_node # add_pinstr pi
 154
 155      method sub_nodes =
 156        let l = self # pxp_node # sub_nodes in
 157        List.map (fun n_pxp -> n_pxp # extension # markup_node) l
 158
 159      method pinstr name =
 160        self # pxp_node # pinstr name
 161
 162      method pinstr_names =
 163        self # pxp_node # pinstr_names
 164
 165      method iter_nodes f =
 166        self # pxp_node # iter_nodes
 167          (fun n_pxp -> f (n_pxp # extension # markup_node))
 168
 169      method iter_nodes_sibl f =
 170        self # pxp_node # iter_nodes_sibl
 171          (fun left_pxp node_pxp right_pxp ->
 172             let left =
 173               match left_pxp with
 174                   None       -> None
 175                 | Some n_pxp -> Some (n_pxp # extension # markup_node) in
 176             let right =
 177               match right_pxp with
 178                   None       -> None
 179                 | Some n_pxp -> Some (n_pxp # extension # markup_node) in
 180             let node =
 181               node_pxp # extension # markup_node in
 182             f left node right
 183          )
 184
 185      method set_nodes (l : 'ext node list) =
 186        let l_pxp = List.map (fun n -> n # pxp_node) l in
 187        self # pxp_node # set_nodes l_pxp
 188
 189      method data = self # pxp_node # data
 190
 191      method node_type =
 192        match self # pxp_node # node_type with
 193            Pxp_document.T_data         -> T_data
 194          | Pxp_document.T_element name -> T_element name
 195          | Pxp_document.T_super_root   -> T_element "-vr"
 196          | Pxp_document.T_pinstr _     -> T_element "-pi"
 197          | _ -> assert false
 198
 199      method attribute name =
 200        self # pxp_node # attribute name
 201
 202      method attribute_names =
 203        self # pxp_node # attribute_names
 204
 205      method attribute_type name =
 206        self # pxp_node # attribute_type name
 207
 208      method attributes =
 209        self # pxp_node # attributes
 210
 211      method required_string_attribute name =
 212        self # pxp_node # required_string_attribute name
 213
 214      method required_list_attribute name =
 215        self # pxp_node # required_list_attribute name
 216
 217      method optional_string_attribute name =
 218        self # pxp_node # optional_string_attribute name
 219
 220      method optional_list_attribute name =
 221        self # pxp_node # optional_list_attribute name
 222
 223      method quick_set_attributes l =
 224        self # pxp_node # quick_set_attributes l
 225
 226      method find (name : string) =
 227        let index = self # root # pxp_node # extension # index in
 228        let n = index # find name in (* may raise Not_found *)
 229        n # extension # markup_node
 230
 231      method reset_finder = ()
 232
 233      method create_element dtd nt atts =
 234        let nt_pxp =
 235          match nt with
 236              T_data -> Pxp_document.T_data
 237            | T_element name -> Pxp_document.T_element name in
 238        let node_pxp =
 239          self # pxp_node # create_element dtd nt_pxp atts in
 240        let ext' = extension # clone in
 241        let n = new emulate_markup_node ext' (Some node_pxp) in
 242        ext' # set_node (n : 'ext #node  :> 'ext node);
 243        node_pxp # extension # set_markup_node n;
 244        n
 245
 246      method create_data dtd s =
 247        let node_pxp =
 248          self # pxp_node # create_data dtd s in
 249        let ext' = extension # clone in
 250        let n = new emulate_markup_node ext' (Some node_pxp) in
 251        ext' # set_node (n : 'ext #node  :> 'ext node);
 252        node_pxp # extension # set_markup_node n;
 253        n
 254
 255      method keep_always_whitespace_mode =
 256        self # pxp_node # keep_always_whitespace_mode
 257
 258      method write_compact_as_latin1 out =
 259        self # pxp_node # write_compact_as_latin1 out
 260
 261      method local_validate =
 262        self # pxp_node # local_validate()
 263
 264      method internal_adopt (p:'ext node option) =
 265        assert false;
 266        ()
 267
 268      method internal_delete (n:'ext node) =
 269        assert false;
 270        ()
 271
 272      method internal_init (d:Markup_dtd.dtd) (s:string) (atts:(string*string)list) =
 273        assert false;
 274        ()
 275   end
 276 ;;
 277
 278 class [ 'ext ] data_impl ext data =
 279   object (self)
 280     inherit [ 'ext ] emulate_markup_node ext None
 281     constraint 'ext = 'ext node #extension
 282     initializer
 283       if data <> "" then
 284         failwith "Emulation of Markup_document: Cannot instantiate data node with non-empty string";
 285       let self' = (self : 'ext #node :> 'ext node ) in
 286       pxp_node <- Some (new Pxp_document.data_impl (new pxp_extension self'))
 287
 288   end
 289 ;;
 290
 291 class [ 'ext ] element_impl ext =
 292   object (self)
 293     inherit [ 'ext ] emulate_markup_node ext None
 294     initializer
 295       let self' = (self : 'ext #node :> 'ext node ) in
 296       pxp_node <- Some (new Pxp_document.element_impl (new pxp_extension self'))
 297   end
 298 ;;
 299
 300
 301 class [ 'ext ] document w =
 302   object (self)
 303     val pxp_doc = new Pxp_document.document
 304                     (w : Markup_types.collect_warnings :> Pxp_types.collect_warnings)
 305
 306     val mutable standalone_flag = false
 307
 308     method init_xml_version v =
 309       pxp_doc # init_xml_version v
 310
 311     method xml_version =
 312       pxp_doc # xml_version
 313
 314     method init_xml_standalone b =
 315       standalone_flag <- b
 316
 317     method xml_standalone = standalone_flag
 318
 319     method init_root (r : 'ext node) =
 320       pxp_doc # init_root (r # pxp_node);
 321       self # dtd # set_standalone_declaration standalone_flag
 322         (* questionable *)
 323
 324     method root =
 325       let pxp_root = pxp_doc # root in
 326       pxp_root # extension # markup_node
 327
 328     method dtd =
 329       pxp_doc # dtd
 330
 331     method add_pinstr pi =
 332       pxp_doc # add_pinstr pi
 333
 334     method pinstr name =
 335       pxp_doc # pinstr name
 336
 337     method pinstr_names =
 338       pxp_doc # pinstr_names
 339
 340     method write_compact_as_latin1 out =
 341       pxp_doc # write_compact_as_latin1 out
 342
 343   end
 344 ;;
 345
 346 (* ======================================================================
 347  * History:
 348  *
 349  * $Log$
 350  * Revision 1.1  2000/11/17 09:57:30  lpadovan
 351  * Initial revision
 352  *
 353  * Revision 1.6  2000/08/18 20:19:00  gerd
 354  *      Changed the emulation: there are now wrapper objects for nodes.
 355  * This was necessary because node_type changed in PXP such that it became
 356  * incompatible with Markup's node_type.
 357  *
 358  * Revision 1.5  2000/07/14 21:35:35  gerd
 359  *      Updated because of the simplification of Pxp_types.collect_warnings.
 360  *
 361  * Revision 1.4  2000/07/08 17:40:50  gerd
 362  *      Updated the simulation.
 363  *
 364  * Revision 1.3  2000/06/14 22:19:27  gerd
 365  *      Update because of additional 'encoding' methods.
 366  *
 367  * Revision 1.2  2000/05/30 00:08:40  gerd
 368  *      Bugfix.
 369  *
 370  * Revision 1.1  2000/05/29 23:43:51  gerd
 371  *      Initial compatibility revision.
 372  *
 373  *)
 374