helm/DEVEL/pxp/pxp/compatibility/markup_yacc.ml

   1 (* $Id$
   2  * ----------------------------------------------------------------------
   3  *)
   4
   5 open Markup_types
   6 open Markup_dtd
   7 open Markup_document
   8
   9 type config =
  10     { warner : collect_warnings;
  11       errors_with_line_numbers : bool;
  12       processing_instructions_inline : bool;
  13       virtual_root : bool;
  14       debugging_mode : bool;
  15     }
  16
  17
  18 type source =
  19     Entity of ((dtd -> Pxp_entity.entity) * Markup_reader.resolver)
  20   | Channel of in_channel
  21   | File of string
  22   | Latin1 of string
  23   | ExtID of (ext_id * Markup_reader.resolver)
  24
  25 type 'ext domspec =
  26     { map : (node_type, 'ext node) Hashtbl.t;
  27       default_element : 'ext node;
  28     }
  29
  30
  31 class default_ext =
  32   object(self)
  33     val mutable node = (None : ('a extension node as 'a) option)
  34     method clone = {< >}
  35     method node =
  36       match node with
  37           None ->
  38             assert false
  39         | Some n -> n
  40     method set_node n =
  41       node <- Some n
  42   end
  43 ;;
  44
  45
  46 let default_extension = new default_ext;;
  47
  48 let default_config =
  49   { warner = new collect_warnings;
  50     errors_with_line_numbers = true;
  51     processing_instructions_inline = false;
  52     virtual_root = false;
  53     debugging_mode = false;
  54   }
  55
  56
  57 let default_dom =
  58   let d = Hashtbl.create 2 in
  59   Hashtbl.add d T_data (new data_impl default_extension "");
  60   { map = d;
  61     default_element = new element_impl default_extension
  62   }
  63 ;;
  64
  65
  66 let pxp_config cfg =
  67   { Pxp_yacc.default_config with
  68         Pxp_yacc.warner = (cfg.warner :> Pxp_types.collect_warnings);
  69         Pxp_yacc.errors_with_line_numbers = cfg.errors_with_line_numbers;
  70         Pxp_yacc.enable_pinstr_nodes = cfg.processing_instructions_inline;
  71         Pxp_yacc.enable_super_root_node = cfg.virtual_root;
  72         Pxp_yacc.encoding = `Enc_iso88591;
  73         Pxp_yacc.recognize_standalone_declaration = false;
  74         Pxp_yacc.debugging_mode = cfg.debugging_mode;
  75   }
  76 ;;
  77
  78
  79 class pxp_resolver r =
  80   object (self)
  81     val markup_resolver = r
  82
  83     method init_rep_encoding enc =
  84       assert (enc = `Enc_iso88591 )
  85
  86     method init_warner w =
  87       ()
  88
  89     method rep_encoding = `Enc_iso88591
  90
  91     method open_in xid =
  92       markup_resolver # open_in xid
  93
  94     method close_in =
  95       markup_resolver # close_in
  96
  97     method close_all =
  98       markup_resolver # close_in
  99
 100     method change_encoding enc =
 101       markup_resolver # change_encoding enc
 102
 103     method clone =
 104       ( {< markup_resolver = markup_resolver # clone >}
 105         : #Pxp_reader.resolver :> Pxp_reader.resolver )
 106   end
 107 ;;
 108
 109
 110 let pxp_source src =
 111   match src with
 112       Entity (mkent, res) -> Pxp_yacc.Entity(mkent, new pxp_resolver res)
 113     | ExtID (id, res)     -> Pxp_yacc.ExtID(id, new pxp_resolver res)
 114     | Channel ch          -> Pxp_yacc.from_channel
 115                                ~system_encoding:`Enc_iso88591 ch
 116     | File f              -> Pxp_yacc.from_file
 117                                ~system_encoding:`Enc_iso88591 f
 118     | Latin1 s            -> Pxp_yacc.from_string ~fixenc:`Enc_iso88591 s
 119 ;;
 120
 121
 122 let pxp_dom dom =
 123   let dex =
 124     try Hashtbl.find dom.map T_data
 125     with Not_found -> assert false
 126   in
 127   let eex = dom.default_element in
 128   let m = Hashtbl.create 100 in
 129   Hashtbl.iter
 130     (fun nt ex ->
 131        match nt with
 132            T_element name when name <> "-vr" && name <> "-pi" ->
 133              let pxp_ex = ex # pxp_node in
 134              Hashtbl.add m name pxp_ex
 135          | _              -> ()
 136     )
 137     dom.map;
 138   let srex =
 139     try
 140       Some ((Hashtbl.find dom.map (T_element "-vr")) # pxp_node)
 141     with
 142         Not_found -> None
 143   in
 144   let piex =
 145     try
 146       Some ((Hashtbl.find dom.map (T_element "-pi")) # pxp_node)
 147     with
 148         Not_found -> None
 149   in
 150   Pxp_document.make_spec_from_mapping
 151     ?super_root_exemplar:srex
 152     ?default_pinstr_exemplar:piex
 153     ~data_exemplar:(dex # pxp_node)
 154     ~default_element_exemplar:(eex # pxp_node)
 155     ~element_mapping:m
 156     ()
 157 ;;
 158
 159
 160 let markup_document w index doc =
 161   let mdoc = new document w in
 162   mdoc # init_xml_version (doc # xml_version);
 163   mdoc # init_xml_standalone (doc # xml_standalone);
 164   let r = doc # root # extension in
 165   r # set_index index;
 166   mdoc # init_root (r # markup_node);
 167   List.iter
 168     (fun piname ->
 169        let l = doc # pinstr piname in
 170        List.iter
 171          (fun pi -> mdoc # add_pinstr pi)
 172          l)
 173     (doc # pinstr_names);
 174   mdoc
 175 ;;
 176
 177
 178
 179 let parse_dtd_entity cfg src =
 180   Pxp_yacc.parse_dtd_entity
 181     (pxp_config cfg)
 182     (pxp_source src)
 183 ;;
 184
 185
 186 let parse_document_entity cfg src dom =
 187   let index = (new Pxp_yacc.hash_index :> 'ext Pxp_yacc.index) in
 188   markup_document
 189     cfg.warner
 190     index
 191     (Pxp_yacc.parse_document_entity
 192         ~id_index:index
 193         (pxp_config cfg)
 194         (pxp_source src)
 195         (pxp_dom dom))
 196 ;;
 197
 198
 199 let parse_content_entity cfg src dtd dom =
 200   let index = (new Pxp_yacc.hash_index :> 'ext Pxp_yacc.index) in
 201   let n =
 202     (Pxp_yacc.parse_content_entity
 203      ~id_index:index
 204        (pxp_config cfg)
 205        (pxp_source src)
 206        dtd
 207        (pxp_dom dom)) # extension in
 208   n # set_index index;
 209   n # markup_node
 210 ;;
 211
 212
 213 let parse_wf_entity cfg src dom =
 214   let index = (new Pxp_yacc.hash_index :> 'ext Pxp_yacc.index) in
 215   (* Restriction: index is not filled! *)
 216   markup_document
 217     cfg.warner
 218     index
 219     (Pxp_yacc.parse_wfdocument_entity
 220        (pxp_config cfg)
 221        (pxp_source src)
 222        (pxp_dom dom))
 223 ;;
 224
 225
 226 (* ======================================================================
 227  * History:
 228  *
 229  * $Log$
 230  * Revision 1.1  2000/11/17 09:57:30  lpadovan
 231  * Initial revision
 232  *
 233  * Revision 1.4  2000/08/18 20:19:16  gerd
 234  *      Updates in the emulation because of PXP changes.
 235  *
 236  * Revision 1.3  2000/07/14 21:35:35  gerd
 237  *      Updated because of the simplification of Pxp_types.collect_warnings.
 238  *
 239  * Revision 1.2  2000/07/08 17:40:50  gerd
 240  *      Updated the simulation.
 241  *
 242  * Revision 1.1  2000/05/29 23:43:51  gerd
 243  *      Initial compatibility revision.
 244  *
 245  *)