← Back to branch summary

~ubuntu-branches/ubuntu/oneiric/ocsigen/oneiric

« back to all changes in this revision

Viewing changes to xmlp4/oldocaml/simplexmlparser.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stephane Glondu
  • Date: 2009-07-02 10:02:08 UTC
  • mfrom: (1.1.9 upstream) (4.1.3 squeeze)
  • Revision ID: james.westby@ubuntu.com-20090702100208-n158b1sqwzn0asil
Tags: 1.2.0-2
Fix build on non-native architectures

Show diffs side-by-side

added added

removed removed

Lines of Context:
xmlp4/oldocaml/simplexmlparser.ml
1
 
(* Ocsigen
2
 
 * Copyright (C) 2005 Vincent Balat
3
 
 *
4
 
 * This program is free software; you can redistribute it and/or modify
5
 
 * it under the terms of the GNU Lesser General Public License as published by
6
 
 * the Free Software Foundation, with linking exception;
7
 
 * either version 2.1 of the License, or (at your option) any later version.
8
 
 *
9
 
 * This program is distributed in the hope that it will be useful,
10
 
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11
 
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12
 
 * GNU Lesser General Public License for more details.
13
 
 *
14
 
 * You should have received a copy of the GNU Lesser General Public License
15
 
 * along with this program; if not, write to the Free Software
16
 
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
17
 
 *)
18
 
 
19
 
(*
20
 
   Parseur camlp4 pour XML sans antiquotations
21
 
 
22
 
   Attention c'est juste un essai
23
 
   Je ne colle peut-�tre pas � la syntaxe XML
24
 
   par ex il faut revoir si un attribut peut �tre vide en xml
25
 
   Si oui, il faut remplacer le "string" par "string option"
26
 
 
27
 
   Le typage des attributs n'est pas evident donc pour l'instant ils sont tous string
28
 
   exemple << <plop number="5" /> >> ----> `Number 5  (en fait `Number (int_of_string "5"))
29
 
           << <plop number=$n$ /> >> ----> `Number n o`u n est de type int ???
30
 
 
31
 
On pourrait decider d'ecrire << <plop number=$string_of_int n$ /> >>
32
 
Mais du coup cela fait int_of_string (string_of_int n)
33
 
et ensuite encore string_of_int au moment de l'affichage
34
 
 
35
 
   Revoir aussi la gestion des commentaires ?
36
 
 
37
 
� revoir
38
 
 
39
 
*)
40
 
 
41
 
open Pcaml
42
 
 
43
 
exception Xml_parser_error of string
44
 
 
45
 
 
46
 
(* Instead of using Pcaml.gram, we use a new grammar, using xmllexer *)
47
 
let g = Grammar.gcreate (Xmllexer.gmake ())
48
 
 
49
 
 
50
 
module ExprOrPatt = struct
51
 
 
52
 
  let loc = (Lexing.dummy_pos, Lexing.dummy_pos)
53
 
 
54
 
  type tvarval =
55
 
      EPVstr of string
56
 
    | EPVvar of string
57
 
 
58
 
  type 'a tlist =
59
 
      PLEmpty
60
 
    | PLCons of 'a * 'a tlist
61
 
 
62
 
  type texprpatt =
63
 
      EPanyattr of tvarval * tvarval
64
 
    | EPanytag of string * texprpatt tlist * texprpatt tlist
65
 
    | EPpcdata of string
66
 
    | EPwhitespace of string
67
 
    | EPcomment of string
68
 
 
69
 
  let list_of_mlast_expr el =
70
 
    List.fold_right
71
 
      (fun x l -> <:expr< [$x$ :: $l$] >>) el <:expr< [] >>
72
 
 
73
 
  let list_of_mlast_patt pl =
74
 
    List.fold_right
75
 
      (fun x l -> <:patt< [$x$ :: $l$] >>) pl <:patt< [] >>
76
 
 
77
 
  let expr_valorval = function
78
 
      EPVstr v -> <:expr< $str:v$ >>
79
 
    | EPVvar v -> <:expr< $lid:v$ >>
80
 
 
81
 
  let patt_valorval = function
82
 
      EPVstr v -> <:patt< $str:v$ >>
83
 
    | EPVvar v -> <:patt< $lid:v$ >>
84
 
 
85
 
  let rec to_expr = function
86
 
 
87
 
      EPanyattr (EPVstr aa, v) ->
88
 
        let vv = expr_valorval v in
89
 
        <:expr< (`$uid:String.capitalize aa$, $vv$) >>
90
 
 
91
 
    | EPanyattr (EPVvar aa, v) ->
92
 
        let vv = expr_valorval v in
93
 
        <:expr< ($lid:aa$, $vv$) >>
94
 
 
95
 
    | EPanytag (tag, attribute_list, child_list) ->
96
 
        <:expr< `$uid:String.capitalize tag$
97
 
          $to_expr_attlist attribute_list$
98
 
          $to_expr_taglist child_list$
99
 
        >>
100
 
 
101
 
    | EPpcdata dt -> <:expr< `PCData $str:dt$ >>
102
 
 
103
 
    | EPwhitespace dt -> <:expr< `Whitespace $str:dt$ >>
104
 
 
105
 
    | EPcomment c -> <:expr< `Comment $str:c$ >>
106
 
 
107
 
  and to_expr_taglist = function
108
 
      PLEmpty -> <:expr< [] >>
109
 
    | PLCons (a,l) -> <:expr< [ $to_expr a$ :: $to_expr_taglist l$ ] >>
110
 
 
111
 
  and to_expr_attlist = function
112
 
      PLEmpty -> <:expr< [] >>
113
 
    | PLCons (a,l) -> <:expr< [ $to_expr a$ :: $to_expr_attlist l$ ] >>
114
 
 
115
 
 
116
 
  let rec to_patt = function
117
 
 
118
 
      EPanyattr (EPVstr a, v) ->
119
 
        let vv = patt_valorval v in
120
 
        <:patt< ((`$uid:String.capitalize a$), $vv$) >>
121
 
 
122
 
    | EPanyattr (EPVvar a, v) ->
123
 
        let vv = patt_valorval v in
124
 
        <:patt< ($lid:a$, $vv$) >>
125
 
 
126
 
    | EPanytag (tag, attribute_list, child_list) ->
127
 
        <:patt< `$uid:String.capitalize tag$
128
 
          $to_patt_attlist attribute_list$
129
 
          $to_patt_taglist child_list$
130
 
        >>
131
 
 
132
 
    | EPpcdata dt -> <:patt< `PCData $str:dt$ >>
133
 
 
134
 
    | EPwhitespace dt -> <:patt< `Whitespace $str:dt$ >>
135
 
 
136
 
    | EPcomment c -> <:patt< `Comment $str:c$ >>
137
 
 
138
 
  and to_patt_taglist = function
139
 
      PLEmpty -> <:patt< [] >>
140
 
    | PLCons (a,l) -> <:patt< [ $to_patt a$ :: $to_patt_taglist l$ ] >>
141
 
 
142
 
  and to_patt_attlist = function
143
 
      PLEmpty -> <:patt< [] >>
144
 
    | PLCons (a,l) -> <:patt< [ $to_patt a$ :: $to_patt_attlist l$ ] >>
145
 
 
146
 
end
147
 
 
148
 
open ExprOrPatt
149
 
 
150
 
let exprpatt_xml = Grammar.Entry.create g "xml"
151
 
let exprpatt_any_tag = Grammar.Entry.create g "xml tag"
152
 
let exprpatt_any_tag_list = Grammar.Entry.create g "xml tag list"
153
 
let exprpatt_any_attribute_list = Grammar.Entry.create g "xml attribute list"
154
 
let exprpatt_attr_or_var = Grammar.Entry.create g "xml attribute or $var$"
155
 
let exprpatt_value_or_var = Grammar.Entry.create g "xml value or $var$"
156
 
 
157
 
 
158
 
EXTEND
159
 
 
160
 
  exprpatt_xml:
161
 
  [ [
162
 
    declaration_list = LIST0 [ DECL | XMLDECL ];
163
 
    OPT WHITESPACE;
164
 
    root_tag = exprpatt_any_tag;
165
 
    OPT WHITESPACE;
166
 
    EOI -> root_tag
167
 
  ] ];
168
 
 
169
 
  exprpatt_any_tag:
170
 
  [ [
171
 
    tag = TAG;
172
 
    attribute_list = OPT exprpatt_any_attribute_list;
173
 
    child_list = OPT exprpatt_any_tag_list;
174
 
    GAT ->
175
 
      let attlist = match attribute_list with
176
 
          None -> PLEmpty
177
 
        | Some l -> l
178
 
      in
179
 
      let taglist = match child_list with
180
 
          None -> PLEmpty
181
 
        | Some l -> l
182
 
      in EPanytag
183
 
        (tag,
184
 
         attlist,
185
 
         taglist)
186
 
  | dt = WHITESPACE -> EPwhitespace dt
187
 
  | dt = DATA -> EPpcdata dt
188
 
  | c = COMMENT -> EPcomment c
189
 
  ] ];
190
 
 
191
 
  exprpatt_any_attribute_list:
192
 
  [ [
193
 
     a = exprpatt_attr_or_var;
194
 
      "=";
195
 
      value = exprpatt_value_or_var;
196
 
      suite  = OPT exprpatt_any_attribute_list ->
197
 
      let suite = match suite with
198
 
          None -> PLEmpty
199
 
        | Some l -> l
200
 
      in PLCons (EPanyattr (a,value), suite)
201
 
  ] ];
202
 
 
203
 
  exprpatt_any_tag_list:
204
 
  [ [
205
 
     anytag = exprpatt_any_tag;
206
 
      suite  = OPT exprpatt_any_tag_list ->
207
 
      let suite = match suite with
208
 
          None -> PLEmpty
209
 
        | Some l -> l
210
 
      in PLCons (anytag, suite)
211
 
  ] ];
212
 
 
213
 
  exprpatt_value_or_var:
214
 
  [ [
215
 
    v = VALUE -> EPVstr v
216
 
  ] ];
217
 
 
218
 
  exprpatt_attr_or_var:
219
 
  [ [
220
 
    v = ATTR -> EPVstr v
221
 
  ] ];
222
 
 
223
 
END;;
224
 
 
225
 
let xml_exp s = to_expr (Grammar.Entry.parse exprpatt_xml (Stream.of_string s))
226
 
let xml_pat s = to_patt (Grammar.Entry.parse exprpatt_xml (Stream.of_string s))
227
 
 
228
 
type xml =
229
 
  | Element of (string * (string * string) list * xml list)
230
 
  | PCData of string
231
 
 
232
 
let nocaml_msg =
233
 
        "Caml code not allowed in configuration file. Use $$ to escape $."
234
 
 
235
 
let rec to_xml =
236
 
  let rec to_xml_tag l = function
237
 
    | EPwhitespace _
238
 
    | EPcomment _ -> to_xml l
239
 
    | EPpcdata s -> (PCData s)::(to_xml l)
240
 
    | EPanytag (s, atts, tags) ->
241
 
        (Element (s, (to_xml_atts atts), (to_xml tags)))::(to_xml l)
242
 
    | _ -> raise (Xml_parser_error nocaml_msg)
243
 
  and to_xml_att l = function
244
 
    | EPwhitespace _
245
 
    | EPcomment _ -> to_xml_atts l
246
 
    | EPanyattr ((EPVstr n), (EPVstr v)) -> (n, v)::(to_xml_atts l)
247
 
    | _ -> raise (Xml_parser_error nocaml_msg)
248
 
  and to_xml_atts = function
249
 
    | PLEmpty -> []
250
 
    | PLCons (a, l) -> to_xml_att l a
251
 
  in function
252
 
  | PLEmpty -> []
253
 
  | PLCons (a, l) -> to_xml_tag l a
254
 
 
255
 
 
256
 
let print_location loc =
257
 
  Printf.sprintf "%d-%d" (fst loc).Lexing.pos_cnum (snd loc).Lexing.pos_cnum
258
 
 
259
 
let rawxmlparser s =
260
 
  try
261
 
    let chan = open_in s in
262
 
    let tree = Grammar.Entry.parse exprpatt_any_tag_list (Stream.of_channel chan) in
263
 
    close_in chan;
264
 
    tree
265
 
  with
266
 
  | Stdpp.Exc_located (fl, exn) ->
267
 
      raise
268
 
        (Xml_parser_error
269
 
           ("XML error at position: "^
270
 
            (print_location fl)^". "^(Printexc.to_string exn)))
271
 
 
272
 
let xmlparser s = to_xml (rawxmlparser s)
273