← Back to branch summary

~ubuntu-branches/ubuntu/wily/coq-doc/wily

« back to all changes in this revision

Viewing changes to ide/utils/uoptions.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stéphane Glondu, Stéphane Glondu, Samuel Mimram
  • Date: 2010-01-07 22:50:39 UTC
  • mfrom: (1.2.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20100107225039-n3cq82589u0qt0s2
Tags: 8.2pl1-1
http://bugs.debian.org/563669
http://bugs.debian.org/543545
[ Stéphane Glondu ]
* New upstream release (Closes: #563669)
  - remove patches
* Packaging overhaul:
  - use git, advertise it in Vcs-* fields of debian/control
  - use debhelper 7 and dh with override
  - use source format 3.0 (quilt)
* debian/control:
  - set Maintainer to d-o-m, set Uploaders to Sam and myself
  - add Homepage field
  - bump Standards-Version to 3.8.3
* Register PDF documentation into doc-base
* Add debian/watch
* Update debian/copyright

[ Samuel Mimram ]
* Change coq-doc's description to mention that it provides documentation in
  pdf format, not postscript, closes: #543545.

Show diffs side-by-side

added added

removed removed

Lines of Context:
ide/utils/uoptions.ml
 
1
(**************************************************************************)
 
2
(*                   Cameleon                                             *)
 
3
(*                                                                        *)
 
4
(*      Copyright (C) 2002 Institut National de Recherche en Informatique et   *)
 
5
(*      en Automatique. All rights reserved.                              *)
 
6
(*                                                                        *)
 
7
(*      This program is free software; you can redistribute it and/or modify  *)
 
8
(*      it under the terms of the GNU General Public License as published by  *)
 
9
(*      the Free Software Foundation; either version 2 of the License, or  *)
 
10
(*      any later version.                                                *)
 
11
(*                                                                        *)
 
12
(*      This program is distributed in the hope that it will be useful,   *)
 
13
(*      but WITHOUT ANY WARRANTY; without even the implied warranty of    *)
 
14
(*      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the     *)
 
15
(*      GNU General Public License for more details.                      *)
 
16
(*                                                                        *)
 
17
(*      You should have received a copy of the GNU General Public License  *)
 
18
(*      along with this program; if not, write to the Free Software       *)
 
19
(*      Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA          *)
 
20
(*      02111-1307  USA                                                   *)
 
21
(*                                                                        *)
 
22
(*      Contact: Maxence.Guesdon@inria.fr                                *)
 
23
(**************************************************************************)
 
24
 
 
25
(** Simple options:
 
26
  This will enable very simple configuration, by a mouse-based configurator.
 
27
  Flags.will be defined by a special function, which will also check
 
28
  if a value has been provided  by the user in its .gwmlrc file.
 
29
  The .gwmlrc will be created by a dedicated tool, which could be used
 
30
  to generate both .gwmlrc and .efunsrc files.
 
31
 
 
32
Note: this is redundant, since such options could also be better set
 
33
in the .Xdefaults file (using Xrm to load them). Maybe we should merge
 
34
both approaches in a latter release.
 
35
  
 
36
   Code from Fabrice Le Fessant.
 
37
 
 
38
    *)
 
39
  
 
40
type option_value =
 
41
    Module of option_module
 
42
  | StringValue of string
 
43
  | IntValue of int
 
44
  | FloatValue of float
 
45
  | List of option_value list
 
46
  | SmallList of option_value list
 
47
and option_module = (string * option_value) list
 
48
;;
 
49
 
 
50
 
 
51
 
 
52
type 'a option_class =
 
53
  { class_name : string;
 
54
    from_value : option_value -> 'a;
 
55
    to_value : 'a -> option_value;
 
56
    mutable class_hooks : ('a option_record -> unit) list }
 
57
  
 
58
and 'a option_record =
 
59
  { option_name : string list;
 
60
    option_class : 'a option_class;
 
61
    mutable option_value : 'a;
 
62
    option_help : string;
 
63
    mutable option_hooks : (unit -> unit) list;
 
64
    mutable string_wrappers : (('a -> string) * (string -> 'a)) option;
 
65
    option_file : options_file;
 
66
  }
 
67
  
 
68
and options_file = {
 
69
    mutable file_name : string; 
 
70
    mutable file_options : Obj.t option_record list;
 
71
    mutable file_rc : option_module;
 
72
    mutable file_pruned : bool;
 
73
  }
 
74
;;
 
75
 
 
76
let create_options_file name =
 
77
  ignore
 
78
    (
 
79
     if not (Sys.file_exists name) then
 
80
       let oc = open_out name in 
 
81
       close_out oc
 
82
    );
 
83
  {
 
84
    file_name = name;
 
85
    file_options =[];
 
86
    file_rc = [];
 
87
    file_pruned = false;
 
88
  }
 
89
  
 
90
let set_options_file opfile name = opfile.file_name <- name
 
91
 
 
92
let
 
93
  define_option_class
 
94
    (class_name : string)
 
95
    (from_value : option_value -> 'a)
 
96
    (to_value : 'a -> option_value) =
 
97
  let c =
 
98
    {class_name = class_name; 
 
99
      from_value = from_value; 
 
100
      to_value = to_value;
 
101
     class_hooks = []}
 
102
  in
 
103
  c
 
104
;;  
 
105
 
 
106
(*
 
107
let filename =
 
108
  ref
 
109
    (Filename.concat Sysenv.home
 
110
       ("." ^ Filename.basename Sys.argv.(0) ^ "rc"))
 
111
;;
 
112
let gwmlrc = ref [];;
 
113
 
 
114
let options = ref [];;
 
115
*)
 
116
 
 
117
let rec find_value list m =
 
118
  match list with
 
119
    [] -> raise Not_found
 
120
  | name :: tail ->
 
121
      let m = List.assoc name m in
 
122
      match m, tail with
 
123
        _, [] -> m
 
124
      | Module m, _ :: _ -> find_value tail m
 
125
      | _ -> raise Not_found
 
126
;;
 
127
 
 
128
let prune_file file =
 
129
  file.file_pruned <- true
 
130
 
 
131
let
 
132
  define_option
 
133
    (opfile : options_file)
 
134
    (option_name : string list)
 
135
    (option_help : string)
 
136
    (option_class : 'a option_class)
 
137
    (default_value : 'a) =
 
138
  let o =
 
139
    {option_name = option_name; 
 
140
      option_help = option_help;
 
141
      option_class = option_class; 
 
142
      option_value = default_value;
 
143
      string_wrappers = None;
 
144
      option_hooks = []; 
 
145
      option_file = opfile; }
 
146
  in
 
147
  opfile.file_options <- (Obj.magic o : Obj.t option_record) ::
 
148
    opfile.file_options;
 
149
  o.option_value <-
 
150
    begin try o.option_class.from_value (find_value option_name 
 
151
        opfile.file_rc) with
 
152
      Not_found -> default_value
 
153
    | e ->
 
154
        Printf.printf "Flags.define_option, for option %s: "
 
155
          (match option_name with
 
156
             [] -> "???"
 
157
           | name :: _ -> name);
 
158
        Printf.printf "%s" (Printexc.to_string e);
 
159
        print_newline ();
 
160
        default_value
 
161
    end;
 
162
  o
 
163
;;
 
164
 
 
165
  
 
166
open Genlex;;
 
167
  
 
168
let lexer = make_lexer ["="; "{"; "}"; "["; "]"; ";"; "("; ")"; ","; "."];;
 
169
  
 
170
let rec parse_gwmlrc (strm__ : _ Stream.t) =
 
171
  match
 
172
    try Some (parse_id strm__) with
 
173
      Stream.Failure -> None
 
174
  with
 
175
    Some id ->
 
176
      begin match Stream.peek strm__ with
 
177
        Some (Kwd "=") ->
 
178
          Stream.junk strm__;
 
179
          let v =
 
180
            try parse_option strm__ with
 
181
              Stream.Failure -> raise (Stream.Error "")
 
182
          in
 
183
          let eof =
 
184
            try parse_gwmlrc strm__ with
 
185
              Stream.Failure -> raise (Stream.Error "")
 
186
          in
 
187
          (id, v) :: eof
 
188
      | _ -> raise (Stream.Error "")
 
189
      end
 
190
  | _ -> []
 
191
and parse_option (strm__ : _ Stream.t) =
 
192
  match Stream.peek strm__ with
 
193
    Some (Kwd "{") ->
 
194
      Stream.junk strm__;
 
195
      let v =
 
196
        try parse_gwmlrc strm__ with
 
197
          Stream.Failure -> raise (Stream.Error "")
 
198
      in
 
199
      begin match Stream.peek strm__ with
 
200
        Some (Kwd "}") -> Stream.junk strm__; Module v
 
201
      | _ -> raise (Stream.Error "")
 
202
      end
 
203
  | Some (Ident s) -> Stream.junk strm__; StringValue s
 
204
  | Some (String s) -> Stream.junk strm__; StringValue s
 
205
  | Some (Int i) -> Stream.junk strm__; IntValue i
 
206
  | Some (Float f) -> Stream.junk strm__; FloatValue f
 
207
  | Some (Char c) ->
 
208
      Stream.junk strm__;
 
209
      StringValue (let s = String.create 1 in s.[0] <- c; s)
 
210
  | Some (Kwd "[") ->
 
211
      Stream.junk strm__;
 
212
      let v =
 
213
        try parse_list strm__ with
 
214
          Stream.Failure -> raise (Stream.Error "")
 
215
      in
 
216
      List v
 
217
  | Some (Kwd "(") ->
 
218
      Stream.junk strm__;
 
219
      let v =
 
220
        try parse_list strm__ with
 
221
          Stream.Failure -> raise (Stream.Error "")
 
222
      in
 
223
      List v
 
224
  | _ -> raise Stream.Failure
 
225
and parse_id (strm__ : _ Stream.t) =
 
226
  match Stream.peek strm__ with
 
227
    Some (Ident s) -> Stream.junk strm__; s
 
228
  | Some (String s) -> Stream.junk strm__; s
 
229
  | _ -> raise Stream.Failure
 
230
and parse_list (strm__ : _ Stream.t) =
 
231
  match Stream.peek strm__ with
 
232
    Some (Kwd ";") ->
 
233
      Stream.junk strm__;
 
234
      begin try parse_list strm__ with
 
235
        Stream.Failure -> raise (Stream.Error "")
 
236
      end
 
237
  | Some (Kwd ",") ->
 
238
      Stream.junk strm__;
 
239
      begin try parse_list strm__ with
 
240
        Stream.Failure -> raise (Stream.Error "")
 
241
      end
 
242
  | Some (Kwd ".") ->
 
243
      Stream.junk strm__;
 
244
      begin try parse_list strm__ with
 
245
        Stream.Failure -> raise (Stream.Error "")
 
246
      end
 
247
  | _ ->
 
248
      match
 
249
        try Some (parse_option strm__) with
 
250
          Stream.Failure -> None
 
251
      with
 
252
        Some v ->
 
253
          let t =
 
254
            try parse_list strm__ with
 
255
              Stream.Failure -> raise (Stream.Error "")
 
256
          in
 
257
          v :: t
 
258
      | _ ->
 
259
          match Stream.peek strm__ with
 
260
            Some (Kwd "]") -> Stream.junk strm__; []
 
261
          | Some (Kwd ")") -> Stream.junk strm__; []
 
262
          | _ -> raise Stream.Failure
 
263
;;
 
264
 
 
265
let exec_hooks o =
 
266
  List.iter
 
267
    (fun f ->
 
268
       try f () with
 
269
         _ -> ())
 
270
    o.option_hooks
 
271
;;  
 
272
 
 
273
let exec_chooks o =
 
274
  List.iter
 
275
    (fun f ->
 
276
       try f o with
 
277
         _ -> ())
 
278
    o.option_class.class_hooks
 
279
;;  
 
280
  
 
281
let really_load filename options =
 
282
  let temp_file = filename ^ ".tmp" in
 
283
  if Sys.file_exists temp_file then begin
 
284
      Printf.printf 
 
285
        "File %s exists\n" temp_file;
 
286
      Printf.printf 
 
287
        "An error may have occurred during previous configuration save.\n";
 
288
      Printf.printf 
 
289
        "Please, check your configurations files, and rename/remove this file\n";
 
290
      Printf.printf "before restarting";
 
291
      print_newline ();
 
292
      exit 1
 
293
    end 
 
294
  else
 
295
    let ic = open_in filename in
 
296
    let s = Stream.of_channel ic in
 
297
    try
 
298
      let stream = lexer s in
 
299
      let list =
 
300
        try parse_gwmlrc stream with
 
301
          e ->
 
302
            Printf.printf "At pos %d/%d" (Stream.count s) (Stream.count stream);
 
303
            print_newline ();
 
304
            raise e
 
305
      in
 
306
      List.iter
 
307
        (fun o ->
 
308
          try
 
309
            o.option_value <-
 
310
              o.option_class.from_value (find_value o.option_name list);
 
311
            exec_chooks o;
 
312
            exec_hooks o
 
313
          with
 
314
            e ->
 
315
             ()
 
316
        )
 
317
        options;
 
318
      list
 
319
    with
 
320
      e ->
 
321
        Printf.printf "Error %s in %s" (Printexc.to_string e) filename;
 
322
        print_newline ();
 
323
        []
 
324
;;
 
325
      
 
326
let load opfile =
 
327
  try opfile.file_rc <- really_load opfile.file_name opfile.file_options with
 
328
    Not_found -> 
 
329
      Printf.printf "No %s found" opfile.file_name; print_newline ()
 
330
;;
 
331
 
 
332
let append opfile filename =
 
333
  try opfile.file_rc <-
 
334
    really_load filename opfile.file_options @ opfile.file_rc with
 
335
    Not_found -> 
 
336
      Printf.printf "No %s found" filename; print_newline ()
 
337
;;
 
338
      
 
339
let ( !! ) o = o.option_value;;
 
340
let ( =:= ) o v = o.option_value <- v; exec_chooks o; exec_hooks o;;
 
341
    
 
342
let value_to_string v =
 
343
  match v with
 
344
    StringValue s -> s
 
345
  | IntValue i -> string_of_int i
 
346
  | FloatValue f -> string_of_float f
 
347
  | _ -> failwith "Flags. not a string option"
 
348
;;
 
349
      
 
350
let string_to_value s = StringValue s;;
 
351
  
 
352
let value_to_int v =
 
353
  match v with
 
354
    StringValue s -> int_of_string s
 
355
  | IntValue i -> i
 
356
  | _ -> failwith "Flags. not an int option"
 
357
;;
 
358
 
 
359
let int_to_value i = IntValue i;;
 
360
 
 
361
(* The Pervasives version is too restrictive *)
 
362
let bool_of_string s =
 
363
  match String.lowercase s with
 
364
    "true" -> true
 
365
  | "false" -> false
 
366
  | "yes" -> true
 
367
  | "no" -> false
 
368
  | "y" -> true
 
369
  | "n" -> false
 
370
  | _ -> invalid_arg "bool_of_string"
 
371
;;
 
372
 
 
373
let value_to_bool v =
 
374
  match v with
 
375
    StringValue s -> bool_of_string s
 
376
  | IntValue v when v = 0 -> false
 
377
  | IntValue v when v = 1 -> true
 
378
  | _ -> failwith "Flags. not a bool option"
 
379
;;
 
380
let bool_to_value i = StringValue (string_of_bool i);;
 
381
 
 
382
let value_to_float v =
 
383
  match v with
 
384
    StringValue s -> float_of_string s
 
385
  | FloatValue f -> f
 
386
  | _ -> failwith "Flags. not a float option"
 
387
;; 
 
388
 
 
389
let float_to_value i = FloatValue i;;
 
390
 
 
391
let value_to_string2 v =
 
392
  match v with
 
393
    List [s1; s2] | SmallList [s1;s2] -> 
 
394
      value_to_string s1, value_to_string s2
 
395
  | _ -> failwith "Flags. not a string2 option"
 
396
;;
 
397
 
 
398
let string2_to_value (s1, s2) = SmallList [StringValue s1; StringValue s2];;
 
399
 
 
400
let value_to_list v2c v =
 
401
  match v with
 
402
    List l | SmallList l -> List.rev (List.rev_map v2c l)
 
403
  | StringValue s -> failwith (Printf.sprintf 
 
404
        "Flags. not a list option (StringValue [%s])" s)
 
405
  | FloatValue _ -> failwith "Flags. not a list option (FloatValue)"
 
406
  | IntValue _ -> failwith "Flags. not a list option (IntValue)"
 
407
  | Module _ -> failwith "Flags. not a list option (Module)"
 
408
;;
 
409
 
 
410
let list_to_value c2v l =
 
411
  List
 
412
    (List.fold_right
 
413
      (fun v list ->
 
414
          try c2v v :: list with
 
415
            _ -> list)
 
416
       l [])
 
417
;;
 
418
  
 
419
let smalllist_to_value c2v l =
 
420
  SmallList
 
421
    (List.fold_right
 
422
       (fun v list ->
 
423
          try c2v v :: list with
 
424
            _ -> list)
 
425
       l [])
 
426
;;
 
427
 
 
428
let string_option =
 
429
  define_option_class "String" value_to_string string_to_value
 
430
;;
 
431
let color_option =
 
432
  define_option_class "Color" value_to_string string_to_value
 
433
;;
 
434
let font_option = define_option_class "Font" value_to_string string_to_value;;
 
435
 
 
436
let int_option = define_option_class "Int" value_to_int int_to_value;;
 
437
 
 
438
let bool_option = define_option_class "Bool" value_to_bool bool_to_value;;
 
439
let float_option = define_option_class "Float" value_to_float float_to_value;;
 
440
 
 
441
let string2_option =
 
442
  define_option_class "String2" value_to_string2 string2_to_value
 
443
;;
 
444
 
 
445
let list_option cl =
 
446
  define_option_class (cl.class_name ^ " List") (value_to_list cl.from_value)
 
447
    (list_to_value cl.to_value)
 
448
;;
 
449
 
 
450
let smalllist_option cl =
 
451
  define_option_class (cl.class_name ^ " List") (value_to_list cl.from_value)
 
452
    (smalllist_to_value cl.to_value)
 
453
;;
 
454
 
 
455
let to_value cl = cl.to_value;;
 
456
let from_value cl = cl.from_value;;
 
457
  
 
458
let value_to_sum l v =
 
459
  match v with
 
460
    StringValue s -> List.assoc s l
 
461
  | _ -> failwith "Flags. not a sum option"
 
462
;;
 
463
  
 
464
let sum_to_value l v = StringValue (List.assq v l);;
 
465
  
 
466
let sum_option l =
 
467
  let ll = List.map (fun (a1, a2) -> a2, a1) l in
 
468
  define_option_class "Sum" (value_to_sum l) (sum_to_value ll)
 
469
;;
 
470
 
 
471
let exit_exn = Exit;;
 
472
let safe_string s =
 
473
  if s = "" then "\"\""
 
474
  else
 
475
    try
 
476
      match s.[0] with
 
477
        'a'..'z' | 'A'..'Z' ->
 
478
          for i = 1 to String.length s - 1 do
 
479
            match s.[i] with
 
480
              'a'..'z' | 'A'..'Z' | '_' | '0'..'9' -> ()
 
481
            | _ -> raise exit_exn
 
482
          done;
 
483
          s
 
484
      | _ ->
 
485
          if string_of_int (int_of_string s) = s ||
 
486
             string_of_float (float_of_string s) = s then
 
487
            s
 
488
          else raise exit_exn
 
489
    with
 
490
      _ -> Printf.sprintf "\"%s\"" (String.escaped s)
 
491
;;
 
492
 
 
493
let with_help = ref false;;
 
494
      
 
495
let rec save_module indent oc list =
 
496
  let subm = ref [] in
 
497
  List.iter
 
498
    (fun (name, help, value) ->
 
499
       match name with
 
500
         [] -> assert false
 
501
       | [name] ->
 
502
           if !with_help && help <> "" then
 
503
             Printf.fprintf oc "(* %s *)\n" help;
 
504
           Printf.fprintf oc "%s %s = " indent (safe_string name);
 
505
           save_value indent oc value;
 
506
           Printf.fprintf oc "\n"
 
507
       | m :: tail ->
 
508
           let p =
 
509
             try List.assoc m !subm with
 
510
               _ -> let p = ref [] in subm := (m, p) :: !subm; p
 
511
           in
 
512
           p := (tail, help, value) :: !p)
 
513
    list;
 
514
  List.iter
 
515
    (fun (m, p) ->
 
516
       Printf.fprintf oc "%s %s = {\n" indent (safe_string m);
 
517
       save_module (indent ^ "  ") oc !p;
 
518
       Printf.fprintf oc "%s}\n" indent)
 
519
    !subm
 
520
and save_list indent oc list =
 
521
  match list with
 
522
    [] -> ()
 
523
  | [v] -> save_value indent oc v
 
524
  | v :: tail ->
 
525
      save_value indent oc v; Printf.fprintf oc ", "; save_list indent oc tail
 
526
and save_list_nl indent oc list =
 
527
  match list with
 
528
    [] -> ()
 
529
  | [v] -> Printf.fprintf oc "\n%s" indent; save_value indent oc v
 
530
  | v :: tail ->
 
531
      Printf.fprintf oc "\n%s" indent;
 
532
      save_value indent oc v;
 
533
      Printf.fprintf oc ";";
 
534
      save_list_nl indent oc tail
 
535
and save_value indent oc v =
 
536
  match v with
 
537
    StringValue s -> Printf.fprintf oc "%s" (safe_string s)
 
538
  | IntValue i -> Printf.fprintf oc "%d" i
 
539
  | FloatValue f -> Printf.fprintf oc "%f" f
 
540
  | List l ->
 
541
      Printf.fprintf oc "[";
 
542
      save_list_nl (indent ^ "  ") oc l;
 
543
      Printf.fprintf oc "]"
 
544
  | SmallList l ->
 
545
      Printf.fprintf oc "(";
 
546
      save_list (indent ^ "  ") oc l;
 
547
      Printf.fprintf oc ")"
 
548
  | Module m -> 
 
549
      Printf.fprintf oc "{";
 
550
      save_module_fields (indent ^ "  ") oc m;
 
551
      Printf.fprintf oc "}"
 
552
      
 
553
and save_module_fields indent oc m =
 
554
  match m with
 
555
    [] -> ()
 
556
  | (name, v) :: tail ->
 
557
      Printf.fprintf oc "%s %s = " indent (safe_string name);
 
558
      save_value indent oc v;
 
559
      Printf.fprintf oc "\n";
 
560
      save_module_fields indent oc tail
 
561
;;
 
562
    
 
563
let save opfile =
 
564
  let filename = opfile.file_name in
 
565
  let temp_file = filename ^ ".tmp" in
 
566
  let old_file = filename ^ ".old" in
 
567
  let oc = open_out temp_file in
 
568
  save_module "" oc
 
569
    (List.map
 
570
      (fun o ->
 
571
        o.option_name, o.option_help,
 
572
        (try 
 
573
            o.option_class.to_value o.option_value 
 
574
          with
 
575
            e ->
 
576
              Printf.printf "Error while saving option \"%s\": %s"
 
577
                (try List.hd o.option_name with
 
578
                  _ -> "???")
 
579
              (Printexc.to_string e);
 
580
              print_newline ();
 
581
              StringValue ""))
 
582
    (List.rev opfile.file_options));
 
583
  if not opfile.file_pruned then begin
 
584
      Printf.fprintf oc
 
585
        "\n(*\n The following options are not used (errors, obsolete, ...) \n*)\n";
 
586
      List.iter
 
587
        (fun (name, value) ->
 
588
          try
 
589
            List.iter
 
590
              (fun o ->
 
591
                match o.option_name with
 
592
                  n :: _ -> if n = name then raise Exit
 
593
                | _ -> ())
 
594
            opfile.file_options;
 
595
            Printf.fprintf oc "%s = " (safe_string name);
 
596
            save_value "  " oc value;
 
597
            Printf.fprintf oc "\n"
 
598
          with
 
599
            _ -> ())
 
600
      opfile.file_rc;
 
601
    end;
 
602
  close_out oc;
 
603
  (try Sys.rename filename old_file with _ -> ());
 
604
  (try Sys.rename temp_file filename with _ -> ())
 
605
;;
 
606
 
 
607
let save_with_help opfile =
 
608
  with_help := true;
 
609
  begin try save opfile with
 
610
    _ -> ()
 
611
  end;
 
612
  with_help := false
 
613
;;
 
614
  
 
615
let option_hook option f = option.option_hooks <- f :: option.option_hooks;;
 
616
  
 
617
let class_hook option_class f =
 
618
  option_class.class_hooks <- f :: option_class.class_hooks
 
619
;;
 
620
 
 
621
let rec iter_order f list =
 
622
  match list with
 
623
    [] -> ()
 
624
  | v :: tail -> f v; iter_order f tail
 
625
;;
 
626
  
 
627
let help oc opfile =
 
628
  List.iter
 
629
    (fun o ->
 
630
       Printf.fprintf oc "OPTION \"";
 
631
       begin match o.option_name with
 
632
         [] -> Printf.fprintf oc "???"
 
633
       | [name] -> Printf.fprintf oc "%s" name
 
634
       | name :: tail ->
 
635
           Printf.fprintf oc "%s" name;
 
636
           iter_order (fun name -> Printf.fprintf oc ":%s" name) o.option_name
 
637
       end;
 
638
       Printf.fprintf oc "\" (TYPE \"%s\"): %s\n   CURRENT: \n"
 
639
         o.option_class.class_name o.option_help;
 
640
       begin try
 
641
         save_value "" oc (o.option_class.to_value o.option_value)
 
642
       with
 
643
         _ -> ()
 
644
       end;
 
645
       Printf.fprintf oc "\n")
 
646
    opfile.file_options;
 
647
  flush oc
 
648
;;
 
649
  
 
650
    
 
651
let tuple2_to_value (c1, c2) (a1, a2) =
 
652
  SmallList [to_value c1 a1; to_value c2 a2]
 
653
;;
 
654
  
 
655
let value_to_tuple2 (c1, c2) v =
 
656
  match v with
 
657
    List [v1; v2] -> from_value c1 v1, from_value c2 v2
 
658
  | SmallList [v1; v2] -> from_value c1 v1, from_value c2 v2
 
659
  | List l | SmallList l ->
 
660
      Printf.printf "list of %d" (List.length l);
 
661
      print_newline ();
 
662
      failwith "Flags. not a tuple2 list option"
 
663
  | _ -> failwith "Flags. not a tuple2 option"
 
664
;;
 
665
  
 
666
let tuple2_option p =
 
667
  define_option_class "tuple2_option" (value_to_tuple2 p) (tuple2_to_value p)
 
668
;;
 
669
  
 
670
let tuple3_to_value (c1, c2, c3) (a1, a2, a3) =
 
671
  SmallList [to_value c1 a1; to_value c2 a2; to_value c3 a3]
 
672
;;
 
673
let value_to_tuple3 (c1, c2, c3) v =
 
674
  match v with
 
675
    List [v1; v2; v3] -> from_value c1 v1, from_value c2 v2, from_value c3 v3
 
676
  | SmallList [v1; v2; v3] ->
 
677
      from_value c1 v1, from_value c2 v2, from_value c3 v3
 
678
  | _ -> failwith "Flags. not a tuple3 option"
 
679
;;
 
680
      
 
681
let tuple3_option p =
 
682
  define_option_class "tuple3_option" (value_to_tuple3 p) (tuple3_to_value p)
 
683
;;
 
684
 
 
685
let tuple4_to_value (c1, c2, c3, c4) (a1, a2, a3, a4) =
 
686
  SmallList [to_value c1 a1; to_value c2 a2; to_value c3 a3; to_value c4 a4]
 
687
;;
 
688
let value_to_tuple4 (c1, c2, c3, c4) v =
 
689
  match v with
 
690
    List [v1; v2; v3; v4] -> 
 
691
      (from_value c1 v1, from_value c2 v2, from_value c3 v3, from_value c4 v4)
 
692
  | SmallList [v1; v2; v3; v4] ->
 
693
      (from_value c1 v1, from_value c2 v2, from_value c3 v3, from_value c4 v4)
 
694
  | _ -> failwith "Flags. not a tuple4 option"
 
695
;;
 
696
      
 
697
let tuple4_option p =
 
698
  define_option_class "tuple4_option" (value_to_tuple4 p) (tuple4_to_value p)
 
699
;;
 
700
 
 
701
 
 
702
let shortname o = String.concat ":" o.option_name;;
 
703
let get_class o = o.option_class;;
 
704
let get_help o =
 
705
  let help = o.option_help in if help = "" then "No Help Available" else help
 
706
;;
 
707
 
 
708
 
 
709
let simple_options opfile =
 
710
  let list = ref [] in
 
711
  List.iter (fun o ->
 
712
      match o.option_name with
 
713
        [] | _ :: _ :: _ -> ()
 
714
      | [name] ->
 
715
          match o.option_class.to_value o.option_value with
 
716
            Module _ | SmallList _ | List _ -> 
 
717
              begin
 
718
                match o.string_wrappers with
 
719
                  None -> ()
 
720
                | Some (to_string, from_string) ->
 
721
                    list := (name, to_string o.option_value) :: !list   
 
722
              end
 
723
          | v -> 
 
724
              list := (name, value_to_string v) :: !list
 
725
  ) opfile.file_options;
 
726
  !list
 
727
 
 
728
let get_option opfile name =
 
729
  let rec iter name list = 
 
730
    match list with 
 
731
      [] -> raise Not_found
 
732
    | o :: list ->
 
733
        if o.option_name = name then o
 
734
        else iter name list
 
735
  in
 
736
  iter [name] opfile.file_options
 
737
  
 
738
  
 
739
let set_simple_option opfile name v =
 
740
  let o = get_option opfile name in
 
741
  begin
 
742
    match o.string_wrappers with
 
743
      None ->
 
744
        o.option_value <- o.option_class.from_value (string_to_value v);
 
745
    | Some (_, from_string) -> 
 
746
        o.option_value <- from_string v
 
747
  end;
 
748
  exec_chooks o; exec_hooks o;;
 
749
    
 
750
let get_simple_option opfile name =
 
751
  let o = get_option opfile name in
 
752
  match o.string_wrappers with
 
753
    None ->
 
754
      value_to_string (o.option_class.to_value o.option_value)
 
755
  | Some (to_string, _) -> 
 
756
      to_string o.option_value
 
757
  
 
758
let set_option_hook opfile name hook =
 
759
  let o = get_option opfile name in
 
760
  o.option_hooks <- hook :: o.option_hooks
 
761
  
 
762
let set_string_wrappers o to_string from_string =
 
763
  o.string_wrappers <- Some (to_string, from_string)
 
764
 
 
765
let simple_args opfile =
 
766
  List.map (fun (name, v) ->
 
767
      ("-" ^ name), 
 
768
      Arg.String (set_simple_option opfile name), 
 
769
      (Printf.sprintf "<string> : \t%s (current: %s)"
 
770
          (get_option opfile name).option_help
 
771
          v)
 
772
  ) (simple_options opfile)