aboutsummaryrefslogtreecommitdiffhomepage
path: root/ide/utils/config_file.ml
blob: 4d0aabeb6a6a16365c5fa89c04d53678542d5a81 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
(*********************************************************************************)
(*                Cameleon                                                       *)
(*                                                                               *)
(*    Copyright (C) 2005 Institut National de Recherche en Informatique et       *)
(*    en Automatique. All rights reserved.                                       *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Library General Public License as            *)
(*    published by the Free Software Foundation; either version 2 of the         *)
(*    License, or  any later version.                                            *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
(*    GNU Library General Public License for more details.                       *)
(*                                                                               *)
(*    You should have received a copy of the GNU Library General Public          *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(* TODO *)
(* section comments *)
(* better obsoletes: no "{}", line cuts *)

(* possible improvements: *)
(* use lex/yacc instead of genlex to be more robust, efficient, allow arrays and other types, read comments. *)
(* description and help, level (beginner/advanced/...) for each cp *)
(* find an option from its name and group *)
(* class hooks *)
(* get the sections of a group / of a file *)
(* read file format from inifiles and ConfigParser *)


(* Read the mli before reading this file! *)


(* ******************************************************************************** *)
(* ******************************** misc utilities ******************************** *)
(* ******************************************************************************** *)
(* This code is intended to be usable without any dependencies. *)

(* pipeline style, see for instance Raw.of_channel. *)
let (|>) x f  = f x

(* as List.assoc, but applies f to the element matching [key] and returns the list
where this element has been replaced by the result of f. *)
let rec list_assoc_remove key f = function
  | [] -> raise Not_found
  | (key',value) as elt :: tail ->
      if key <> key'
      then elt :: list_assoc_remove key f tail
      else match f value with
        | None -> tail
        | Some a -> (key',a) :: tail

(* reminiscent of String.concat. Same as [Queue.iter f1 queue]
   but calls [f2 ()] between each calls to f1.
   Does not call f2 before the first call nor after the last call to f2.
   Could be more efficient with a richer module interface of Queue.
*)
let queue_iter_between f1 f2 queue =
(*   let f flag elt = if flag then f2 (); (f1 elt:unit); true in *)
  let f flag elt = if flag then f2 (); f1 elt; true in
  ignore (Queue.fold f false queue)

let list_iter_between f1 f2 = function
    [] -> ()
  | a::[] -> f1 a
  | a::tail -> f1 a; List.iter (fun elt -> (f2 ():unit); f1 elt) tail
(*   | a::tail -> f1 a; List.iter (fun elt -> f2 (); f1 elt) tail *)
(* !! types ??? *)

(* to ensure that strings will be parsed correctly by Genlex.
It's more comfortable not to have quotes around the string, but sometimes it's necessary. *)
exception Unsafe_string
let safe_string s =
  if s = ""
  then "\"\""
  else if (
    try match s.[0] with
      | 'a'..'z' | 'A'..'Z' ->
          for i = 1 to String.length s - 1 do
            match s.[i] with
                'a'..'z' | 'A'..'Z' | '_' | '0'..'9' -> ()
              | _ -> raise Unsafe_string
          done;
        false
      | _ ->
          try
            string_of_int (int_of_string s) <> s ||
            string_of_float (float_of_string s) <> s
          with Failure "int_of_string" | Failure "float_of_string" -> true
    with Unsafe_string -> true)
  then Printf.sprintf "\"%s\"" (String.escaped s)
  else s


(* ******************************************************************************** *)
(* ************************************* core ************************************* *)
(* ******************************************************************************** *)

module Raw = struct
  type cp =
    | String of string
    | Int of int
    | Float of float
    | List of cp list
    | Tuple of cp list
    | Section of (string * cp) list

(* code generated by
camlp4 pa_o.cmo pa_op.cmo pr_o.cmo -- -o config_file_parser.ml -impl config_file_parser.ml4
Unreadable on purpose, edit the file config_file_parser.ml4 rather than editing this (huge) lines. Then manually copy-paste here the content of config_file_parser.ml.
Could be one day rewritten with ocamllex/yacc to be more robust, efficient, allow arrays, read comments...*)
  module Parse = struct
    let lexer = Genlex.make_lexer ["="; "{"; "}"; "["; "]"; ";"; "("; ")"; ","]
    let rec file l (strm__ : _ Stream.t) = match try Some (ident strm__) with Stream.Failure -> None with Some id -> begin match Stream.peek strm__ with Some (Genlex.Kwd "=") -> Stream.junk strm__; let v = try value strm__ with Stream.Failure -> raise (Stream.Error "") in begin try file ((id, v) :: l) strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> raise (Stream.Error "") end | _ -> List.rev l
    and value (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Kwd "{") -> Stream.junk strm__; let v = try file [] strm__ with Stream.Failure -> raise (Stream.Error "") in begin match Stream.peek strm__ with Some (Genlex.Kwd "}") -> Stream.junk strm__; Section v | _ -> raise (Stream.Error "") end | Some (Genlex.Ident s) -> Stream.junk strm__; String s | Some (Genlex.String s) -> Stream.junk strm__; String s | Some (Genlex.Int i) -> Stream.junk strm__; Int i | Some (Genlex.Float f) -> Stream.junk strm__; Float f | Some (Genlex.Char c) -> Stream.junk strm__; String (String.make 1 c) | Some (Genlex.Kwd "[") -> Stream.junk strm__; let v = try list [] strm__ with Stream.Failure -> raise (Stream.Error "") in List v | Some (Genlex.Kwd "(") -> Stream.junk strm__; let v = try list [] strm__ with Stream.Failure -> raise (Stream.Error "") in Tuple v | _ -> raise Stream.Failure
    and ident (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Ident s) -> Stream.junk strm__; s | Some (Genlex.String s) -> Stream.junk strm__; s | _ -> raise Stream.Failure
    and list l (strm__ : _ Stream.t) = match Stream.peek strm__ with Some (Genlex.Kwd ";") -> Stream.junk strm__; begin try list l strm__ with Stream.Failure -> raise (Stream.Error "") end | Some (Genlex.Kwd ",") -> Stream.junk strm__; begin try list l strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> match try Some (value strm__) with Stream.Failure -> None with Some v -> begin try list (v :: l) strm__ with Stream.Failure -> raise (Stream.Error "") end | _ -> match Stream.peek strm__ with Some (Genlex.Kwd "]") -> Stream.junk strm__; List.rev l | Some (Genlex.Kwd ")") -> Stream.junk strm__; List.rev l | _ -> raise Stream.Failure
  end

  open Format
  (* formating convention: the caller has to open the box, close it and flush the output *)
  (* remarks on Format:
     set_margin forces a call to set_max_indent
     sprintf et bprintf are flushed at each call*)

  (* pretty print a Raw.cp *)
  let rec save formatter = function
    | String s -> fprintf formatter "%s" (safe_string s) (* How can I cut lines and *)
    | Int i -> fprintf formatter "%d" i             (* print backslashes just before the \n? *)
    | Float f -> fprintf formatter "%g" f
    | List l ->
        fprintf formatter "[@[<b0>";
        list_iter_between
          (fun v -> fprintf formatter "@[<b2>"; save formatter v; fprintf formatter "@]")
          (fun () -> fprintf formatter ";@ ")
          l;
        fprintf formatter "@]]"
    | Tuple l ->
        fprintf formatter "(@[<b0>";
        list_iter_between
          (fun v -> fprintf formatter "@[<b2>"; save formatter v; fprintf formatter "@]")
          (fun () -> fprintf formatter ",@ ")
          l;
        fprintf formatter "@])"
    | Section l ->
        fprintf formatter "{@;<0 2>@[<hv0>";
        list_iter_between
          (fun (name,value) ->
             fprintf formatter "@[<hov2>%s =@ @[<b2>" name;
             save formatter value;
             fprintf formatter "@]@]";)
          (fun () -> fprintf formatter "@;<2 0>")
          l;
        fprintf formatter "@]}"

(*   let to_string r = save str_formatter r; flush_str_formatter () *)
  let to_channel out_channel r =
    let f = formatter_of_out_channel out_channel in
    fprintf f "@[<b2>"; save f r; fprintf f "@]@?"

  let of_string s = s |> Stream.of_string |> Parse.lexer |> Parse.value

  let of_channel in_channel =
    let result = in_channel |> Stream.of_channel |> Parse.lexer |> Parse.file [] in
    close_in in_channel;
    result
end

(* print the given string in a way compatible with Format.
   Truncate the lines when needed, indent the newlines.*)
let print_help formatter =
  String.iter (function
   | ' ' -> Format.pp_print_space formatter ()
   | '\n' -> Format.pp_force_newline formatter ()
   | c -> Format.pp_print_char formatter c)

type 'a wrappers = {
 to_raw : 'a -> Raw.cp;
 of_raw : Raw.cp -> 'a}

class type ['a] cp = object
(*   method private to_raw = wrappers.to_raw *)
(*   method private of_raw = wrappers.of_raw *)
(*   method private set_string s = s |> Raw.of_string |> self#of_raw |> self#set *)
  method add_hook : ('a -> 'a -> unit) -> unit
  method get : 'a
  method get_default : 'a
  method set : 'a -> unit
  method reset : unit

  method get_formatted : Format.formatter -> unit
  method get_default_formatted : Format.formatter -> unit
  method get_help_formatted : Format.formatter -> unit

  method get_name : string list
  method get_short_name : string option
  method set_short_name : string -> unit
  method get_help : string
  method get_spec : Arg.spec

  method set_raw : Raw.cp -> unit
end

type groupable_cp = <
  get_name : string list;
  get_short_name : string option;
  get_help : string;

  get_formatted : Format.formatter -> unit;
  get_default_formatted : Format.formatter -> unit;
  get_help_formatted : Format.formatter -> unit;
  get_spec : Arg.spec;

  reset : unit;
  set_raw : Raw.cp -> unit; >

exception Double_name
exception Missing_cp of groupable_cp
exception Wrong_type of (out_channel -> unit)

(* Two exceptions to stop the iteration on queues. *)
exception Found
exception Found_cp of groupable_cp

(* The data structure to store the cps.
It's a tree, each node is a section, and a queue of sons with their name.
Each leaf contains a cp. *)
type 'a nametree =
  | Immediate of 'a
  | Subsection of ((string * 'a nametree) Queue.t)
      (* this Queue must be nonempty for group.read.choose *)

class group = object (self)
  val mutable cps = Queue.create () (* hold all the added cps, in a nametree. *)

  method add : 'a. 'a cp -> unit = fun original_cp ->
    let cp = (original_cp :> groupable_cp) in
    (* function called when we reach the end of the list cp#get_name. *)
    let add_immediate name cp queue =
      Queue.iter (fun (name',_) -> if name = name' then raise Double_name) queue;
      Queue.push (name, Immediate cp) queue in
    (* adds the cp with name [first_name::last_name] in section [section]. *)
    let rec add_in_section section first_name last_name cp queue =
      let sub_add = match last_name with (* what to do once we have find the correct section *)
        | [] -> add_immediate first_name
        | middle_name :: last_name -> add_in_section first_name middle_name last_name in
      try
        Queue.iter
          (function
             | name, Subsection subsection when name = section ->
                 sub_add cp subsection; raise Found
             | _ -> ())
          queue;
        let sub_queue = Queue.create () in
        sub_add cp sub_queue;
        Queue.push (section, Subsection sub_queue) queue
      with Found -> () in
    (match cp#get_name with
      | [] -> failwith "empty name"
      | first_name :: [] -> add_immediate first_name cp cps
      | first_name :: middle_name :: last_name ->
          add_in_section first_name middle_name last_name cp cps)

  method write ?(with_help=true) filename =
    let out_channel = open_out filename in
    let formatter = Format.formatter_of_out_channel out_channel in
    let print = Format.fprintf formatter in
    print "@[<v>";
    let rec save_queue formatter =
      queue_iter_between
        (fun (name,nametree) -> save_nametree name nametree)
        (Format.pp_print_cut formatter)
    and save_nametree name = function
      | Immediate cp ->
          if with_help && cp#get_help <> "" then
            (print "@[<hov3>(* "; cp#get_help_formatted formatter;
             print "@ *)@]@,");
          Format.fprintf formatter "@[<hov2>%s =@ @[<b2>" (safe_string name);
          cp#get_formatted formatter;
          print "@]@]"
      | Subsection queue ->
          Format.fprintf formatter "%s = {@;<0 2>@[<v>" (safe_string name);
          save_queue formatter queue;
          print "@]@,}" in
    save_queue formatter cps;
    print "@]@."; close_out out_channel

  method read ?obsoletes ?(no_default=false)
      ?(on_type_error = fun groupable_cp raw_cp output filename in_channel ->
          close_in in_channel;
          Printf.eprintf
            "Type error while loading configuration parameter %s from file %s.\n%!"
            (String.concat "." groupable_cp#get_name) filename;
          output stderr;
          exit 1)
      filename =
    (* [filename] is created if it doesn't exist. In this case there is no need to read it. *)
    match Sys.file_exists filename with false -> self#write filename | true ->
    let in_channel = open_in filename in
    (* what to do when a cp is missing: *)
    let missing cp default = if no_default then raise (Missing_cp cp) else default in
    (* returns a cp contained in the nametree queue, which must be nonempty *)
    let choose queue =
      let rec iter q = Queue.iter (function
        | _, Immediate cp -> raise (Found_cp cp)
        | _, Subsection q -> iter q) q in
      try iter queue; failwith "choose" with Found_cp cp -> cp in
    (* [set_and_remove raw_cps nametree] sets the cp of [nametree] to their value
       defined in [raw_cps] and returns the remaining raw_cps. *)
    let set_cp cp value =
      try cp#set_raw value
      with Wrong_type output -> on_type_error cp value output filename in_channel in
    let rec set_and_remove raw_cps = function
      | name, Immediate cp ->
          (try list_assoc_remove name (fun value -> set_cp cp value; None) raw_cps
           with Not_found -> missing cp raw_cps)
      | name, Subsection queue ->
          (try list_assoc_remove name
             (function
                | Raw.Section l ->
                    (match remainings l queue with
                       | [] -> None
                       | l -> Some (Raw.Section l))
                | r -> missing (choose queue) (Some r))
             raw_cps
           with Not_found -> missing (choose queue) raw_cps)
    and remainings raw_cps queue = Queue.fold set_and_remove raw_cps queue in
    let remainings = remainings (Raw.of_channel in_channel) cps in
    (* Handling of cps defined in filename but not belonging to self. *)
    if remainings <> [] then match obsoletes with
      | Some filename ->
          let out_channel =
            open_out filename in
(*             open_out_gen [Open_wronly; Open_creat; Open_append; Open_text] 0o666 filename in *)
          let formatter = Format.formatter_of_out_channel out_channel in
          Format.fprintf formatter "@[<v>";
          Raw.save formatter (Raw.Section remainings);
          Format.fprintf formatter "@]@.";
          close_out out_channel
      | None -> ()

  method command_line_args ~section_separator =
    let print = Format.fprintf Format.str_formatter in (* shortcut *)
    let result = ref [] in let push x = result := x :: !result in
    let rec iter = function
      | _, Immediate cp ->
          let key = "-" ^ String.concat section_separator cp#get_name in
          let spec = cp#get_spec in
          let doc = (
            print "@[<hv5>";
            Format.pp_print_as Format.str_formatter (String.length key +3) "";
            if cp#get_help <> ""
            then (print "@,@[<b2>"; cp#get_help_formatted Format.str_formatter; print "@]@ ")
            else print "@,";
            print "@[<hv>@[current:@;<1 2>@[<hov1>"; cp#get_formatted Format.str_formatter;
            print "@]@],@ @[default:@;<1 2>@[<b2>"; cp#get_default_formatted Format.str_formatter;
            print "@]@]@]@]";
            Format.flush_str_formatter ()) in
          (match cp#get_short_name with
            | None -> ()
            | Some short_name -> push ("-" ^ short_name,spec,""));
          push (key,spec,doc)
      | _, Subsection queue -> Queue.iter iter queue in
    Queue.iter iter cps;
    List.rev !result
end


(* Given wrappers for the type 'a, cp_custom_type defines a class 'a cp. *)
class ['a] cp_custom_type wrappers
  ?group:(group:group option) name ?short_name default help =
object (self)
  method private to_raw = wrappers.to_raw
  method private of_raw = wrappers.of_raw

  val mutable value = default
    (* output *)
  method get = value
  method get_default = default
  method get_formatted formatter = self#get |> self#to_raw |> Raw.save formatter
  method get_default_formatted formatter = self#get_default |> self#to_raw |> Raw.save formatter
    (* input *)
  method set v = let v' = value in value <- v; self#exec_hooks v' v
  method set_raw v = self#of_raw v |> self#set
  method private set_string s = s |> Raw.of_string |> self#of_raw |> self#set
  method reset = self#set self#get_default

  (* name *)
  val mutable shortname = short_name
  method get_name = name
  method get_short_name = shortname
  method set_short_name s = shortname <- Some s

  (* help *)
  method get_help = help
  method get_help_formatted formatter = print_help formatter self#get_help
  method get_spec = Arg.String self#set_string

  (* hooks *)
  val mutable hooks = []
  method add_hook f = hooks <- (f:'a->'a->unit) :: hooks
  method private exec_hooks v' v = List.iter (fun f -> f v' v) hooks

  initializer match group with Some g -> g#add (self :> 'a cp) | None -> ()
end


(* ******************************************************************************** *)
(* ****************************** predefined classes ****************************** *)
(* ******************************************************************************** *)

let int_wrappers = {
  to_raw = (fun v -> Raw.Int v);
  of_raw = function
    | Raw.Int v -> v
    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
                                "Raw.Int expected, got %a\n%!" Raw.to_channel r))}
class int_cp ?group name ?short_name default help = object (self)
  inherit [int] cp_custom_type int_wrappers ?group name ?short_name default help
  method get_spec = Arg.Int self#set
end

let float_wrappers = {
  to_raw = (fun v -> Raw.Float v);
  of_raw = function
    | Raw.Float v -> v
    | Raw.Int v -> float v
    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
                                "Raw.Float expected, got %a\n%!" Raw.to_channel r))
}
class float_cp ?group name ?short_name default help = object (self)
  inherit [float] cp_custom_type float_wrappers ?group name ?short_name default help
  method get_spec = Arg.Float self#set
end

(* The Pervasives version is too restrictive *)
let bool_of_string s =
  match String.lowercase s with
    | "false" | "no" | "n" | "0" -> false (* "0" and "1" aren't used. *)
    | "true" | "yes" | "y" | "1" -> true
    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
                                "Raw.Bool expected, got %s\n%!" r))
let bool_wrappers = {
  to_raw = (fun v -> Raw.String (string_of_bool v));
  of_raw = function
    | Raw.String v -> bool_of_string v
    | Raw.Int v -> v <> 0
    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
                                "Raw.Bool expected, got %a\n%!" Raw.to_channel r))
}
class bool_cp ?group name ?short_name default help = object (self)
  inherit [bool] cp_custom_type bool_wrappers ?group name ?short_name default help
  method get_spec = Arg.Bool self#set
end

let string_wrappers = {
  to_raw = (fun v -> Raw.String v);
  of_raw = function
    | Raw.String v -> v
    | Raw.Int v -> string_of_int v
    | Raw.Float v -> string_of_float v
    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
                                "Raw.String expected, got %a\n%!" Raw.to_channel r))
}
class string_cp ?group name ?short_name default help = object (self)
  inherit [string] cp_custom_type string_wrappers ?group name ?short_name default help
  method private of_string s = s
  method get_spec = Arg.String self#set
end

let list_wrappers wrappers = {
  to_raw = (fun l -> Raw.List (List.map wrappers.to_raw l));
  of_raw = function
    | Raw.List l -> List.map wrappers.of_raw l
    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
                                "Raw.List expected, got %a\n%!" Raw.to_channel r))
}
class ['a] list_cp wrappers = ['a list] cp_custom_type (list_wrappers wrappers)

let option_wrappers wrappers = {
  to_raw = (function
    | Some v -> wrappers.to_raw v
    | None -> Raw.String "");
  of_raw = function
    | Raw.String s as v -> (
        if s = "" || s = "None" then None
        else if String.length s >= 5 && String.sub s 0 5 = "Some "
        then Some (wrappers.of_raw (Raw.String (String.sub s 5 (String.length s -5))))
        else Some (wrappers.of_raw v))
    | r -> Some (wrappers.of_raw r)}
class ['a] option_cp wrappers = ['a option] cp_custom_type (option_wrappers wrappers)

let enumeration_wrappers enum =
  let switched = List.map (fun (string,cons) -> cons,string) enum in
  {to_raw = (fun v -> Raw.String (List.assq v switched));
   of_raw = function
     | Raw.String s ->
         (try List.assoc s enum
          with Not_found -> failwith (Printf.sprintf "%s isn't a known constructor" s))
     | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
                                "Raw enumeration expected, got %a\n%!" Raw.to_channel r))
}
class ['a] enumeration_cp enum ?group name ?short_name default help = object (self)
  inherit ['a] cp_custom_type (enumeration_wrappers enum)
    ?group name ?short_name default help
  method get_spec = Arg.Symbol (List.map fst enum, (fun s -> self#set (List.assoc s enum)))
end

let tuple2_wrappers wrapa wrapb = {
  to_raw = (fun (a,b) -> Raw.Tuple [wrapa.to_raw a; wrapb.to_raw b]);
  of_raw = function
    | Raw.Tuple [a;b] -> wrapa.of_raw a, wrapb.of_raw b
    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
                                "Raw.Tuple 2 expected, got %a\n%!" Raw.to_channel r))
}
class ['a, 'b] tuple2_cp wrapa wrapb = ['a*'b] cp_custom_type (tuple2_wrappers wrapa wrapb)

let tuple3_wrappers wrapa wrapb wrapc = {
  to_raw = (fun (a,b,c) -> Raw.Tuple[wrapa.to_raw a; wrapb.to_raw b; wrapc.to_raw c]);
  of_raw = function
    | Raw.Tuple [a;b;c] -> wrapa.of_raw a, wrapb.of_raw b, wrapc.of_raw c
    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
                                "Raw.Tuple 3 expected, got %a\n%!" Raw.to_channel r))
}
class ['a,'b,'c] tuple3_cp wrapa wrapb wrapc =
  ['a*'b*'c] cp_custom_type (tuple3_wrappers wrapa wrapb wrapc)

let tuple4_wrappers wrapa wrapb wrapc wrapd = {
  to_raw=(fun (a,b,c,d)->Raw.Tuple[wrapa.to_raw a;wrapb.to_raw b;wrapc.to_raw c;wrapd.to_raw d]);
  of_raw = function
    | Raw.Tuple [a;b;c;d] -> wrapa.of_raw a, wrapb.of_raw b, wrapc.of_raw c, wrapd.of_raw d
    | r -> raise (Wrong_type (fun outchan -> Printf.fprintf outchan
                                "Raw.Tuple 4 expected, got %a\n%!" Raw.to_channel r))
}
class ['a,'b,'c,'d] tuple4_cp wrapa wrapb wrapc wrapd =
  ['a*'b*'c*'d] cp_custom_type (tuple4_wrappers wrapa wrapb wrapc wrapd)

class string2_cp = [string,string] tuple2_cp string_wrappers string_wrappers
(* class color_cp = string_cp *)
class font_cp = string_cp
class filename_cp = string_cp


(* ******************************************************************************** *)
(******************** Backward compatibility with module Flags.****************** *)
(* ******************************************************************************** *)

type 'a option_class = 'a wrappers
type 'a option_record = 'a cp
type options_file = {mutable filename:string; group:group}

let create_options_file filename = {filename = filename; group = new group}
let set_options_file options_file filename = options_file.filename <- filename
let load {filename=f; group = g} = g#read f
let append {group=g} filename = g#read filename
let save {filename=f; group = g} = g#write ~with_help:false f
let save_with_help {filename=f; group = g} = g#write ~with_help:true f
let define_option {group=group} name help option_class default =
  (new cp_custom_type option_class ~group name default help)
let option_hook cp f = cp#add_hook (fun _ _ -> f ())

let  string_option = string_wrappers
let   color_option = string_wrappers
let    font_option = string_wrappers
let     int_option =    int_wrappers
let    bool_option =   bool_wrappers
let   float_option =  float_wrappers
let string2_option = tuple2_wrappers string_wrappers string_wrappers

let option_option = option_wrappers
let list_option = list_wrappers
let sum_option = enumeration_wrappers
let tuple2_option (a,b) = tuple2_wrappers a b
let tuple3_option (a,b,c) = tuple3_wrappers a b c
let tuple4_option (a,b,c,d) = tuple4_wrappers a b c d

let ( !! ) cp = cp#get
let ( =:= ) cp value = cp#set value

let shortname cp = String.concat ":" cp#get_name
let get_help cp = cp#get_help

type option_value =
  Module of option_module
| StringValue of  string
| IntValue of int
| FloatValue of float
| List of option_value list
| SmallList of option_value list
and option_module = (string * option_value) list

let rec value_to_raw = function
  | Module a -> Raw.Section (List.map (fun (name,value) -> name, value_to_raw value) a)
  | StringValue a -> Raw.String a
  | IntValue a -> Raw.Int a
  | FloatValue a -> Raw.Float a
  | List a -> Raw.List (List.map value_to_raw a)
  | SmallList a -> Raw.Tuple (List.map value_to_raw a)
let rec raw_to_value = function
  | Raw.String a -> StringValue a
  | Raw.Int a -> IntValue a
  | Raw.Float a -> FloatValue a
  | Raw.List a -> List (List.map raw_to_value a)
  | Raw.Tuple a -> SmallList (List.map raw_to_value a)
  | Raw.Section a -> Module (List.map (fun (name,value) -> name, raw_to_value value) a)

let define_option_class _ of_option_value to_option_value =
  {to_raw = (fun a -> a |> to_option_value |> value_to_raw);
   of_raw = (fun a -> a |> raw_to_value |> of_option_value)}

let to_value {to_raw = to_raw} a = a |> to_raw |> raw_to_value
let from_value {of_raw = of_raw} a = a |> value_to_raw |> of_raw

let of_value_w wrappers a = a |> value_to_raw |> wrappers.of_raw
let to_value_w wrappers a = a |> wrappers.to_raw |> raw_to_value
(* fancy indentation when finishing this stub code, not good style :-) *)
let value_to_string : option_value -> string = of_value_w string_option
let  string_to_value = to_value_w  string_option
let value_to_int     = of_value_w     int_option
let     int_to_value = to_value_w     int_option
let value_to_bool    = of_value_w    bool_option
let    bool_to_value = to_value_w    bool_option
let value_to_float   = of_value_w   float_option
let   float_to_value = to_value_w   float_option
let value_to_string2 = of_value_w string2_option
let string2_to_value = to_value_w string2_option
let value_to_list of_value =
  let wrapper = define_option_class "" of_value (fun _ -> failwith "value_to_list") in
  of_value_w (list_option wrapper)
let list_to_value to_value =
  let wrapper = define_option_class "" (fun _ -> failwith "value_to_list") to_value in
  to_value_w (list_option wrapper)