← Back to branch summary

~ubuntu-branches/ubuntu/lucid/camomile/lucid

« back to all changes in this revision

Viewing changes to tools/camlrb-expand.ml

  • Committer: Bazaar Package Importer
  • Author(s): Sylvain Le Gall
  • Date: 2005-12-03 01:18:55 UTC
  • Revision ID: james.westby@ubuntu.com-20051203011855-qzvwlld1xyqnl62t
Tags: upstream-0.6.3
Import upstream version 0.6.3

Show diffs side-by-side

added added

removed removed

Lines of Context:
tools/camlrb-expand.ml
 
1
(* $Id: camlrb.ml,v 1.16 2004/04/06 22:12:40 yori Exp $ *)
 
2
(* Copyright 2002, 2003 Yamagata Yoriyuki *)
 
3
 
 
4
open UCharInfo
 
5
open AbsCe
 
6
 
 
7
let (enc, readfile, dir) =
 
8
  let enc = ref CharEncoding.utf8 in
 
9
  let readfile = ref stdin in
 
10
  let dir = ref Filename.current_dir_name in
 
11
  Arg.parse
 
12
    ["--enc", Arg.String (fun encname -> enc := CharEncoding.of_name encname),
 
13
     "Encoding name";
 
14
     "--file", Arg.String (fun filename -> readfile := open_in_bin filename),
 
15
     "Reading file"]
 
16
    (fun dirname -> dir := dirname) "ocamllocaledef --enc ENCNAME --file INPUTFILE DIRECTORY:\n\
 
17
    Read the localedef INPUTFILE using the encoding ENCNAME \
 
18
and put the compiled data into DIRECTORY. \
 
19
    DATADIR specifies where camomile put the datafiles.\
 
20
    If ENCNAME is ommited, UTF-8 is used.  \
 
21
    If INPUTFILE is ommited, reading from stdin. \
 
22
    If DIRECTORY is ommited, the current directory is used.";
 
23
  !enc, !readfile, !dir
 
24
 
 
25
module Utf8Buffer = UTF8.Buf
 
26
module Utf8NF = UNF.Make (UTF8)
 
27
 
 
28
let ff = 0x000c                         (*form feed*)
 
29
let cr = Char.code '\r'
 
30
let lf = Char.code '\n'
 
31
let nel = 0x0085
 
32
let tab = Char.code '\t'
 
33
 
 
34
let backslash = Char.code '\\'
 
35
let sq = Char.code '\\'
 
36
let dq = Char.code '\"'
 
37
 
 
38
let backslash = Str.regexp "\\\\\\\\"
 
39
let literal_1 =
 
40
  Str.regexp "\\\\[u]\\([0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f]\\)"
 
41
 
 
42
let literal_2 =
 
43
  Str.regexp "\\\\[v]\\([0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f]\\)"
 
44
 
 
45
let unescape s =
 
46
  let s =
 
47
    Str.global_substitute literal_1
 
48
      (fun _ ->
 
49
         let n = int_of_string (Str.replace_matched "0x\\1" s) in
 
50
         UTF8.init 1 (fun _ -> UChar.chr_of_uint n))
 
51
      s
 
52
  in
 
53
  let s =
 
54
    Str.global_substitute literal_2
 
55
      (fun _ ->
 
56
         let n = int_of_string (Str.replace_matched "0x\\1" s) in
 
57
         UTF8.init 1 (fun _ -> UChar.chr_of_uint n))
 
58
      s
 
59
  in
 
60
  Str.global_replace backslash "\\\\" s
 
61
 
 
62
let rec stream_to_list_aux a s =
 
63
  (fun (strm__ : _ Stream.t) ->
 
64
     match Stream.peek strm__ with
 
65
       Some e -> Stream.junk strm__; stream_to_list_aux (e :: a) strm__
 
66
     | _ -> List.rev a)
 
67
    s
 
68
 
 
69
let stream_to_list s = stream_to_list_aux [] s
 
70
 
 
71
type token =
 
72
    Text of string
 
73
  | Brace_r
 
74
  | Brace_l
 
75
  | Colon
 
76
  | Comma
 
77
 
 
78
let rec prep (strm__ : _ Stream.t) =
 
79
  match Stream.peek strm__ with
 
80
    Some u ->
 
81
      Stream.junk strm__;
 
82
      let rest = strm__ in
 
83
      let c =
 
84
        try Some (UChar.char_of u) with
 
85
          _ -> None
 
86
      in
 
87
      begin match general_category u with
 
88
        `Cc | `Cf when c <> Some '\n' -> prep rest
 
89
      | ct ->
 
90
          Stream.lcons (fun _ -> c, ct, u) (Stream.slazy (fun _ -> prep rest))
 
91
      end
 
92
  | _ -> Stream.sempty
 
93
 
 
94
let rec remove_comment (strm__ : _ Stream.t) =
 
95
  match Stream.peek strm__ with
 
96
    Some (Some '/', _, _ as data) ->
 
97
      Stream.junk strm__;
 
98
      let rest = strm__ in
 
99
      (fun (strm__ : _ Stream.t) ->
 
100
         match Stream.peek strm__ with
 
101
           Some (Some '/', _, _) -> Stream.junk strm__; comment strm__
 
102
         | Some (Some '*', _, _) -> Stream.junk strm__; comment2 strm__
 
103
         | _ ->
 
104
             let rest = strm__ in
 
105
             Stream.icons data (Stream.slazy (fun _ -> remove_comment rest)))
 
106
        rest
 
107
  | Some (Some '\"', _, _ as data) ->
 
108
      Stream.junk strm__;
 
109
      let rest = strm__ in
 
110
      Stream.icons data (Stream.slazy (fun _ -> in_quote rest))
 
111
  | Some data ->
 
112
      Stream.junk strm__;
 
113
      let rest = strm__ in
 
114
      Stream.icons data (Stream.slazy (fun _ -> remove_comment rest))
 
115
  | _ -> Stream.sempty
 
116
and comment (strm__ : _ Stream.t) =
 
117
  match Stream.peek strm__ with
 
118
    Some (Some ('\r' | '\n' | '\133'), _, _ | _, (`Zl | `Zp), _) ->
 
119
      Stream.junk strm__; remove_comment strm__
 
120
  | Some data -> Stream.junk strm__; comment strm__
 
121
  | _ -> Stream.sempty
 
122
and comment2 (strm__ : _ Stream.t) =
 
123
  match Stream.peek strm__ with
 
124
    Some (Some '*', _, _ as data) ->
 
125
      Stream.junk strm__;
 
126
      let rest = strm__ in
 
127
      (fun (strm__ : _ Stream.t) ->
 
128
         match Stream.peek strm__ with
 
129
           Some (Some '/', _, _) -> Stream.junk strm__; remove_comment strm__
 
130
         | _ -> comment2 strm__)
 
131
        rest
 
132
  | Some data -> Stream.junk strm__; comment2 strm__
 
133
  | _ -> Stream.sempty
 
134
and in_quote (strm__ : _ Stream.t) =
 
135
  match Stream.peek strm__ with
 
136
    Some (Some '\\', _, _ as data1) ->
 
137
      Stream.junk strm__;
 
138
      begin match Stream.peek strm__ with
 
139
        Some data2 ->
 
140
          Stream.junk strm__;
 
141
          let rest = strm__ in
 
142
          Stream.icons data1
 
143
            (Stream.icons data2 (Stream.slazy (fun _ -> in_quote rest)))
 
144
      | _ -> raise (Stream.Error "")
 
145
      end
 
146
  | Some (Some '\"', _, _ as data) ->
 
147
      Stream.junk strm__;
 
148
      let rest = strm__ in
 
149
      Stream.icons data (Stream.slazy (fun _ -> remove_comment rest))
 
150
  | Some data ->
 
151
      Stream.junk strm__;
 
152
      let rest = strm__ in
 
153
      Stream.icons data (Stream.slazy (fun _ -> in_quote rest))
 
154
  | _ -> Stream.sempty
 
155
 
 
156
let rec merge_text (strm__ : _ Stream.t) =
 
157
  match Stream.peek strm__ with
 
158
    Some (Text s) -> Stream.junk strm__; do_merge s strm__
 
159
  | Some e ->
 
160
      Stream.junk strm__;
 
161
      let rest = strm__ in
 
162
      Stream.icons e (Stream.slazy (fun _ -> merge_text rest))
 
163
  | _ -> Stream.sempty
 
164
and do_merge s (strm__ : _ Stream.t) =
 
165
  match Stream.peek strm__ with
 
166
    Some (Text s') -> Stream.junk strm__; do_merge (s ^ s') strm__
 
167
  | Some e ->
 
168
      Stream.junk strm__;
 
169
      let rest = strm__ in
 
170
      Stream.icons (Text s)
 
171
        (Stream.icons e (Stream.slazy (fun _ -> merge_text rest)))
 
172
  | _ -> Stream.sempty
 
173
 
 
174
let lexer s =
 
175
  let rec parse (strm__ : _ Stream.t) =
 
176
    match Stream.peek strm__ with
 
177
      Some (Some '{', _, _) ->
 
178
        Stream.junk strm__;
 
179
        let rest = strm__ in
 
180
        Stream.icons Brace_l (Stream.slazy (fun _ -> parse rest))
 
181
    | Some (Some '}', _, _) ->
 
182
        Stream.junk strm__;
 
183
        let rest = strm__ in
 
184
        Stream.icons Brace_r (Stream.slazy (fun _ -> parse rest))
 
185
    | Some (Some ':', _, _) ->
 
186
        Stream.junk strm__;
 
187
        let rest = strm__ in
 
188
        Stream.icons Colon (Stream.slazy (fun _ -> parse rest))
 
189
    | Some (Some ',', _, _) ->
 
190
        Stream.junk strm__;
 
191
        let rest = strm__ in
 
192
        Stream.icons Comma (Stream.slazy (fun _ -> parse rest))
 
193
    | Some (Some '\"', _, _) -> Stream.junk strm__; quote strm__
 
194
    | Some
 
195
        (Some ('\r' | '\n' | '\133' | '\t'), _, _ |
 
196
         _, (`Zs | `Zl | `Zp), _) ->
 
197
        Stream.junk strm__; parse strm__
 
198
    | Some e -> Stream.junk strm__; text (Stream.icons e strm__)
 
199
    | _ -> Stream.sempty
 
200
  and quote s =
 
201
    let buf = Utf8Buffer.create 16 in
 
202
    let rec loop (strm__ : _ Stream.t) =
 
203
      match Stream.peek strm__ with
 
204
        Some (Some '\\', _, u1) ->
 
205
          Stream.junk strm__;
 
206
          begin match Stream.peek strm__ with
 
207
            Some (_, _, u2) ->
 
208
              Stream.junk strm__;
 
209
              let rest = strm__ in
 
210
              Utf8Buffer.add_char buf u1;
 
211
              Utf8Buffer.add_char buf u2;
 
212
              loop rest
 
213
          | _ -> raise (Stream.Error "")
 
214
          end
 
215
      | Some (Some '\"', _, _) ->
 
216
          Stream.junk strm__;
 
217
          let rest = strm__ in
 
218
          let s = Utf8Buffer.contents buf in
 
219
          let s' = unescape s in
 
220
          Stream.icons (Text s') (Stream.slazy (fun _ -> parse rest))
 
221
      | Some (_, _, u) ->
 
222
          Stream.junk strm__;
 
223
          let rest = strm__ in Utf8Buffer.add_char buf u; loop rest
 
224
      | _ -> failwith "A quote is not enclosed."
 
225
    in
 
226
    loop s
 
227
  and text s =
 
228
    let buf = Utf8Buffer.create 16 in
 
229
    let rec loop (strm__ : _ Stream.t) =
 
230
      match Stream.peek strm__ with
 
231
        Some
 
232
          (Some ('\r' | '\n' | '\133' | '\t'), _, _ |
 
233
           _, (`Zs | `Zl | `Zp), _) ->
 
234
          Stream.junk strm__;
 
235
          let rest = strm__ in
 
236
          let s = Utf8Buffer.contents buf in
 
237
          let s' = unescape s in
 
238
          Stream.icons (Text s') (Stream.slazy (fun _ -> parse rest))
 
239
      | Some (Some ('{' | '}' | ':' | ',' | '\"'), _, _ as e) ->
 
240
          Stream.junk strm__;
 
241
          let rest = strm__ in
 
242
          let s = Utf8Buffer.contents buf in
 
243
          let s' = unescape s in
 
244
          Stream.icons (Text s')
 
245
            (Stream.slazy (fun _ -> parse (Stream.icons e rest)))
 
246
      | Some (_, _, u) ->
 
247
          Stream.junk strm__;
 
248
          let rest = strm__ in Utf8Buffer.add_char buf u; loop rest
 
249
      | _ ->
 
250
          let s = Utf8Buffer.contents buf in
 
251
          let s' = unescape s in Stream.ising (Text s')
 
252
    in
 
253
    loop s
 
254
  in
 
255
  let p = prep s in
 
256
  let p1 = remove_comment p in
 
257
  let tokens = parse p1 in
 
258
  let tokens1 = merge_text tokens in let l = stream_to_list tokens1 in l
 
259
 
 
260
let string_to_binary s =
 
261
  let n = String.length s / 2 in
 
262
  let b = String.create n in
 
263
  for i = 0 to n - 1 do
 
264
    let d = int_of_string ("0x" ^ String.sub s (i * 2) 2) in
 
265
    b.[i] <- Char.chr d
 
266
  done;
 
267
  b
 
268
 
 
269
let root = ref ""
 
270
 
 
271
let load_file filename =
 
272
  let file =
 
273
    if Filename.is_implicit filename then Filename.concat !root filename
 
274
    else filename
 
275
  in
 
276
  let c = open_in_bin file in
 
277
  let buf = Buffer.create 16 in
 
278
  try while true do Buffer.add_channel buf c 1 done; assert false with
 
279
    End_of_file -> Buffer.contents buf
 
280
 
 
281
type data =
 
282
    Table of (string, data) Hashtbl.t
 
283
  | Array_data of data array
 
284
  | String_data of string
 
285
  | Binary of string
 
286
  | Int of int
 
287
  | Intvect of int array
 
288
  | Tagged of string * data
 
289
 
 
290
let rec parse_intvect l a =
 
291
  match l with
 
292
    Text num :: Comma :: rest -> parse_intvect rest (int_of_string num :: a)
 
293
  | Text num :: rest ->
 
294
      Intvect (Array.of_list (List.rev (int_of_string num :: a))), rest
 
295
  | _ -> Intvect (Array.of_list (List.rev a)), l
 
296
 
 
297
let rec parse_table l a =
 
298
  match parse l with
 
299
    Some d, rest -> parse_table rest (d :: a)
 
300
  | None, rest ->
 
301
      let tbl = Hashtbl.create (List.length a) in
 
302
      let proc ent =
 
303
        match ent with
 
304
          Tagged (name, data) -> Hashtbl.add tbl name data
 
305
        | _ -> failwith "A broken table entry."
 
306
      in
 
307
      List.iter proc a; Table tbl, rest
 
308
and parse_array l a =
 
309
  match l with
 
310
    Brace_l :: rest ->
 
311
      let (data, rest) = parse_unknown rest in
 
312
      begin match rest with
 
313
        Brace_r :: Comma :: rest -> parse_array rest (data :: a)
 
314
      | Brace_r :: rest -> parse_array rest (data :: a)
 
315
      | _ -> failwith "A brace is not enclosed."
 
316
      end
 
317
  | Text text :: Comma :: rest -> parse_array rest (String_data text :: a)
 
318
  | Text text :: rest ->
 
319
      Array_data (Array.of_list (List.rev (String_data text :: a))), rest
 
320
  | _ -> Array_data (Array.of_list (List.rev a)), l
 
321
and parse_unknown l =
 
322
  match l with
 
323
    Text text :: Brace_r :: rest -> String_data text, Brace_r :: rest
 
324
  | Text text :: Comma :: rest -> parse_array l []
 
325
  | Text text :: rest -> parse_table l []
 
326
  | _ -> parse_array l []
 
327
and parse l =
 
328
  match l with
 
329
    Text tname :: Colon :: Text "table" :: Brace_l :: rest ->
 
330
      let (data, rest) = parse_table rest [] in
 
331
      begin match rest with
 
332
        Brace_r :: rest -> Some (Tagged (tname, data)), rest
 
333
      | _ -> failwith "A brace is not enclosed."
 
334
      end
 
335
  | Text tname :: Colon :: Text "array" :: Brace_l :: rest ->
 
336
      let (data, rest) = parse_array rest [] in
 
337
      begin match rest with
 
338
        Brace_r :: rest -> Some (Tagged (tname, data)), rest
 
339
      | _ -> failwith "A brace is not enclosed."
 
340
      end
 
341
  | Text tname :: Colon :: Text "string" :: Brace_l :: Text data :: Brace_r ::
 
342
    rest ->
 
343
      Some (Tagged (tname, String_data data)), rest
 
344
  | Text tname :: Colon :: Text "bin" :: Brace_l :: Text data :: Brace_r ::
 
345
    rest ->
 
346
      let b = string_to_binary data in Some (Tagged (tname, Binary b)), rest
 
347
  | Text tname :: Colon :: Text "import" :: Brace_l :: Text filename ::
 
348
    Brace_r :: rest ->
 
349
      prerr_endline "Warning : file loading is not supported.";
 
350
      Some (Tagged (tname, Binary "")), rest
 
351
  | Text tname :: Colon :: Text "int" :: Brace_l :: Text num :: Brace_r ::
 
352
    rest ->
 
353
      let n = int_of_string num in Some (Tagged (tname, Int n)), rest
 
354
  | Text tname :: Colon :: Text "intvector" :: Brace_l :: rest ->
 
355
      let (data, rest) = parse_intvect rest [] in
 
356
      begin match rest with
 
357
        Brace_r :: rest -> Some (Tagged (tname, data)), rest
 
358
      | _ -> failwith "A brace is not enclosed."
 
359
      end
 
360
  | Text name :: Brace_l :: rest ->
 
361
      let (data, rest) = parse_unknown rest in
 
362
      begin match rest with
 
363
        Brace_r :: rest -> Some (Tagged (name, data)), rest
 
364
      | _ -> failwith "A brace is not enclosed."
 
365
      end
 
366
  | _ -> None, l
 
367
 
 
368
let col_parse s =
 
369
  let s = Utf8NF.nfd s in
 
370
  let lexbuf = Lexing.from_string s in
 
371
  let ace_info = ColParser.main ColLexer.token lexbuf in cetbl_of ace_info
 
372
 
 
373
let localedef =
 
374
  function
 
375
    Table tbl ->
 
376
      let col_info =
 
377
        try
 
378
          Some
 
379
            (match Hashtbl.find tbl "CollationElements" with
 
380
               Table tbl ->
 
381
                 begin match Hashtbl.find tbl "Sequence" with
 
382
                   String_data s -> col_parse s
 
383
                 | _ -> assert false
 
384
                 end
 
385
             | _ -> assert false)
 
386
        with
 
387
          Not_found -> None
 
388
      in
 
389
      {Unidata.col_info = col_info}
 
390
  | _ -> assert false
 
391
 
 
392
let main () =
 
393
  let cs = Stream.of_channel readfile in
 
394
  let stream = CharEncoding.ustream_of enc cs in
 
395
  let lexed = lexer stream in
 
396
  let (data, rest) = parse_table lexed [] in
 
397
  if rest <> [] then failwith "Strange trailing data.";
 
398
  let proc key entry =
 
399
    let locale_info = localedef entry in
 
400
    let file = Filename.concat dir (key ^ ".mar") in
 
401
    let c = open_out_bin file in output_value c locale_info
 
402
  in
 
403
  match data with
 
404
    Table tbl -> Hashtbl.iter proc tbl
 
405
  | _ -> failwith "Broken data."
 
406
    
 
407
let _ = main ()