rc.mll 11.3 KB
Newer Older
MARCHE Claude's avatar
MARCHE Claude committed
1 2
(**************************************************************************)
(*                                                                        *)
3
(*  Copyright (C) 2010-2011                                               *)
4 5 6
(*    François Bobot                                                      *)
(*    Jean-Christophe Filliâtre                                           *)
(*    Claude Marché                                                       *)
Jean-Christophe Filliâtre's avatar
Jean-Christophe Filliâtre committed
7
(*    Andrei Paskevich                                                    *)
MARCHE Claude's avatar
MARCHE Claude committed
8 9 10
(*                                                                        *)
(*  This software is free software; you can redistribute it and/or        *)
(*  modify it under the terms of the GNU Library General Public           *)
Jean-Christophe Filliâtre's avatar
Jean-Christophe Filliâtre committed
11
(*  License version 2.1, with the special exception on linking            *)
MARCHE Claude's avatar
MARCHE Claude committed
12 13 14 15 16 17 18 19 20
(*  described in file LICENSE.                                            *)
(*                                                                        *)
(*  This software 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.                  *)
(*                                                                        *)
(**************************************************************************)

{
21 22 23
open Lexing
open Format
open Util
MARCHE Claude's avatar
MARCHE Claude committed
24

25 26 27 28 29 30
let get_home_dir () =
  try Sys.getenv "HOME"
  with Not_found ->
    (* try windows env var *)
    try Sys.getenv "USERPROFILE"
    with Not_found -> ""
31

MARCHE Claude's avatar
MARCHE Claude committed
32 33 34 35 36 37 38
type rc_value =
  | RCint of int
  | RCbool of bool
  | RCfloat of float
  | RCstring of string
  | RCident of string

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

(* Error handling *)

(* exception SyntaxError *)
exception ExtraParameters of string
exception MissingParameters of string
(* exception UnknownSection of string *)
exception UnknownField of string
(* exception MissingSection of string *)
exception MissingField of string
exception DuplicateSection of string
exception DuplicateField of string * rc_value * rc_value
exception StringExpected of string * rc_value
exception IdentExpected of string * rc_value
exception IntExpected of string * rc_value
exception BoolExpected of string * rc_value

let error ?loc e = match loc with
  | None -> raise e
  | Some loc -> raise (Loc.Located (loc, e))

(* conf files *)

let print_rc_value fmt = function
  | RCint i -> fprintf fmt "%d" i
  | RCbool b -> fprintf fmt "%B" b
  | RCfloat f -> fprintf fmt "%f" f
  | RCstring s -> fprintf fmt "%S" s (* "%s"  %S ? *)
  | RCident s -> fprintf fmt "%s" s

let () = Exn_printer.register (fun fmt e -> match e with
  (* | SyntaxError -> *)
  (*     fprintf fmt "syntax error" *)
  | ExtraParameters s ->
      fprintf fmt "section '%s': header too long" s
  | MissingParameters s ->
      fprintf fmt "section '%s': header too short" s
  (* | UnknownSection s -> *)
  (*     fprintf fmt "unknown section '%s'" s *)
  | UnknownField s ->
      fprintf fmt "unknown field '%s'" s
  (* | MissingSection s -> *)
  (*     fprintf fmt "section '%s' is missing" s *)
  | MissingField s ->
      fprintf fmt "field '%s' is missing" s
  | DuplicateSection s ->
      fprintf fmt "section '%s' is already given" s
  | DuplicateField (s,u,v) ->
      fprintf fmt "cannot set field '%s' to %a, as it is already set to %a"
        s print_rc_value v print_rc_value u
  | StringExpected (s,v) ->
      fprintf fmt "cannot set field '%s' to %a: a string is expected"
        s print_rc_value v
  | IdentExpected (s,v) ->
      fprintf fmt "cannot set field '%s' to %a: an identifier is expected"
        s print_rc_value v
  | IntExpected (s,v) ->
      fprintf fmt "cannot set field '%s' to %a: an integer is expected"
        s print_rc_value v
  | e -> raise e)

100 101 102 103 104 105 106 107 108 109
type section = rc_value list Mstr.t
type family  = (string * section) list
type ofamily  = (string option * section) list
type t = ofamily Mstr.t

let empty = Mstr.empty
let empty_section = Mstr.empty

let make_t tl =
  let add_key acc (key,value) =
110
    let l = Mstr.find_default key [] acc in
111 112 113 114 115 116
    Mstr.add key (value::l) acc in
  let add_section t (args,sectionl) =
    let sname,arg = match args with
      | []    -> assert false
      | [sname]    -> sname,None
      | [sname;arg] -> sname,Some arg
117
      | sname::_     -> raise (ExtraParameters sname) in
118 119
    let m = List.fold_left add_key empty_section sectionl in
    let m = Mstr.map List.rev m in
120
    let l = Mstr.find_default sname [] t in
121 122 123 124 125 126 127 128
    Mstr.add sname ((arg,m)::l) t in
  List.fold_left add_section empty tl

let get_section t sname =
  try
    let l = Mstr.find sname t in
    match l with
      | [None,v] -> Some v
129 130
      | [Some _,_] -> raise (ExtraParameters sname)
      | _ -> raise (DuplicateSection sname)
131 132 133 134 135 136
  with Not_found -> None

let get_family t sname =
  try
    let l = Mstr.find sname t in
    let get (arg,section) =
137
      (match arg with None -> raise (MissingParameters sname) | Some v -> v,
138 139 140 141 142 143 144 145 146 147 148 149 150
        section) in
    List.map get l
  with Not_found -> []


let set_section t sname section =
  Mstr.add sname [None,section] t

let set_family t sname sections =
  if sections = [] then Mstr.remove sname t else
    let set (arg,section) = (Some arg,section) in
    Mstr.add sname (List.map set sections) t

151 152 153 154 155 156 157
let get_value read section key =
  let l = Mstr.find key section in
  match l with
    | []  -> assert false
    | [v] -> read key v
    | v1::v2::_ -> raise (DuplicateField (key,v1,v2))

158 159
let get_value read ?default section key =
  try
160
    get_value read section key
161 162
  with Not_found ->
    match default with
163
      | None -> raise (MissingField key)
164 165
      | Some v -> v

166 167 168
let get_valueo read section key =
  try
    Some (get_value read section key)
169
  with MissingField _ -> None
170

171 172 173
let get_valuel read ?default section key =
  try
    let l = Mstr.find key section in
174
    List.map (read key) l
175 176
  with Not_found ->
    match default with
177
      | None -> raise (MissingField key)
178
      | Some v -> v
179

180 181 182 183 184 185 186 187 188
let set_value write ?default section key value =
  let actually_write = match default with
    | None -> true
    | Some default -> default <> value in
  if actually_write
  then Mstr.add key [write value] section
  else section

let set_valuel write ?default section key valuel =
189
  if valuel = [] then Mstr.remove key section else
190 191 192 193 194 195
    let actually_write = match default with
      | None -> true
      | Some default -> default <> valuel in
    if actually_write
    then Mstr.add key (List.map write valuel) section
    else Mstr.remove key section
196

197
let rint k = function
MARCHE Claude's avatar
MARCHE Claude committed
198
  | RCint n -> n
199
  | v -> raise (IntExpected (k,v))
MARCHE Claude's avatar
MARCHE Claude committed
200

201 202
let wint i = RCint i

203
let rbool k = function
MARCHE Claude's avatar
MARCHE Claude committed
204
  | RCbool b -> b
205
  | v -> raise (BoolExpected (k,v))
MARCHE Claude's avatar
MARCHE Claude committed
206

207 208
let wbool b = RCbool b

209
let rstring k = function
MARCHE Claude's avatar
MARCHE Claude committed
210
  | RCident s | RCstring s -> s
211
  | v -> raise (StringExpected (k,v))
MARCHE Claude's avatar
MARCHE Claude committed
212

213 214 215 216
let wstring s = RCstring s

let get_int = get_value rint
let get_intl = get_valuel rint
217 218
let get_into = get_valueo rint

219 220 221 222 223
let set_int = set_value wint
let set_intl = set_valuel wint

let get_bool = get_value rbool
let get_booll = get_valuel rbool
224
let get_boolo = get_valueo rbool
225 226 227 228 229
let set_bool = set_value wbool
let set_booll = set_valuel wbool

let get_string = get_value rstring
let get_stringl = get_valuel rstring
230
let get_stringo = get_valueo rstring
231 232 233 234 235
let set_string = set_value wstring
let set_stringl = set_valuel wstring

let check_exhaustive section keyl =
  let test k _ = if Sstr.mem k keyl then ()
236
    else raise (UnknownField k) in
237 238
  Mstr.iter test section

MARCHE Claude's avatar
MARCHE Claude committed
239 240
let buf = Buffer.create 17

241
let current_rec = ref []
MARCHE Claude's avatar
MARCHE Claude committed
242 243 244 245 246 247 248 249 250
let current_list = ref []
let current = ref []

let push_field key value =
  current_list := (key,value) :: !current_list

let push_record () =
  if !current_list <> [] then
    current := (!current_rec,List.rev !current_list) :: !current;
251
  current_rec := [];
MARCHE Claude's avatar
MARCHE Claude committed
252 253
  current_list := []

254 255 256
  exception SyntaxError of string
  let syntax_error s = raise (SyntaxError s)

MARCHE Claude's avatar
MARCHE Claude committed
257 258 259 260 261
}

let space = [' ' '\t' '\r' '\n']+
let digit = ['0'-'9']
let letter = ['a'-'z' 'A'-'Z']
262
let ident = (letter | '_') (letter | digit | '_' | '-' | '+' | '.') *
263
let sign = '-' | '+'
MARCHE Claude's avatar
MARCHE Claude committed
264 265 266 267 268 269
let integer = sign? digit+
let mantissa = ['e''E'] sign? digit+
let real = sign? digit* '.' digit* mantissa?
let escape = ['\\''"''n''t''r']

rule record = parse
270
  | space
MARCHE Claude's avatar
MARCHE Claude committed
271
      { record lexbuf }
272
  | '#' [^'\n']* ('\n' | eof)
273
      { record lexbuf }
274 275
  | '[' (ident as key) space*
      { header [key] lexbuf }
276
  | eof
MARCHE Claude's avatar
MARCHE Claude committed
277
      { push_record () }
278
  | (ident as key) space* '=' space*
MARCHE Claude's avatar
MARCHE Claude committed
279 280
      { value key lexbuf }
  | _ as c
281
      { syntax_error ("invalid keyval pair starting with " ^ String.make 1 c) }
MARCHE Claude's avatar
MARCHE Claude committed
282

283 284 285 286 287 288 289 290
and header keylist = parse
  | (ident as key) space*
      { header (key::keylist) lexbuf }
  | ']'
      { push_record ();
        current_rec := List.rev keylist;
        record lexbuf }
  | eof
291
      { syntax_error "unterminated header" }
292
  | _ as c
293
      { syntax_error ("invalid header starting with " ^ String.make 1 c) }
294

MARCHE Claude's avatar
MARCHE Claude committed
295 296 297 298 299 300 301
and value key = parse
  | integer as i
      { push_field key (RCint (int_of_string i));
        record lexbuf }
  | real as r
      { push_field key (RCfloat (float_of_string r));
        record lexbuf }
302
  | '"'
MARCHE Claude's avatar
MARCHE Claude committed
303
      { Buffer.clear buf;
304
        string_val key lexbuf }
MARCHE Claude's avatar
MARCHE Claude committed
305 306 307 308 309 310 311 312 313 314
  | "true"
      { push_field key (RCbool true);
        record lexbuf }
  | "false"
      { push_field key (RCbool false);
        record lexbuf }
  | ident as id
      { push_field key (RCident (*kind_of_ident*) id);
        record lexbuf }
  | eof
315
      { syntax_error "unterminated keyval pair" }
316
  | _ as c
317
      { syntax_error ("invalid value starting with " ^ String.make 1 c) }
MARCHE Claude's avatar
MARCHE Claude committed
318

319 320
and string_val key = parse
  | '"'
MARCHE Claude's avatar
MARCHE Claude committed
321
      { push_field key (RCstring (Buffer.contents buf));
322
        record lexbuf
MARCHE Claude's avatar
MARCHE Claude committed
323 324 325 326
      }
  | [^ '\\' '"'] as c
      { Buffer.add_char buf c;
        string_val key lexbuf }
327
  | '\\' (['\\''\"'] as c)
MARCHE Claude's avatar
MARCHE Claude committed
328 329 330 331 332
      { Buffer.add_char buf c;
        string_val key lexbuf }
  | '\\' 'n'
      { Buffer.add_char buf '\n';
        string_val key lexbuf }
333 334
  | '\\' '\n'
      { string_val key lexbuf }
MARCHE Claude's avatar
MARCHE Claude committed
335 336 337 338 339
  | '\\' (_ as c)
      { Buffer.add_char buf '\\';
        Buffer.add_char buf c;
        string_val key lexbuf }
  | eof
340
      { syntax_error "unterminated string" }
MARCHE Claude's avatar
MARCHE Claude committed
341 342 343 344


{

345 346 347 348 349
let from_channel cin =
  current := [];
  record (from_channel cin);
  make_t !current

350 351 352
exception CannotOpen of string * string
exception SyntaxErrorFile of string * string

353 354
let from_file f =
  let c =
355
    try open_in f with Sys_error s -> raise (CannotOpen (f, s))
356
  in
357
  try
358
    let r = from_channel c in close_in c; r
359
  with
360 361 362 363
    | SyntaxError s -> close_in c; raise (SyntaxErrorFile (f, s))
    | e -> close_in c; raise e

let () = Exn_printer.register (fun fmt e -> match e with
364
  | CannotOpen (_, s) ->
365
      Format.fprintf fmt "system error: `%s'" s
366
  | SyntaxErrorFile (f, s) ->
367 368
      Format.fprintf fmt "syntax error in %s: %s" f s
  | _ -> raise e)
369

370
let to_formatter fmt t =
371
  let print_kv k fmt v = fprintf fmt "%s = %a" k print_rc_value v in
372 373 374 375
  let print_kvl fmt k vl = Pp.print_list Pp.newline (print_kv k) fmt vl in
  let print_section sname fmt (h,l) =
    fprintf fmt "[%s %a]@\n%a"
      sname (Pp.print_option Pp.string) h
376
      (Pp.print_iter22 Mstr.iter Pp.newline print_kvl) l in
377
  let print_sectionl fmt sname l =
378
    Pp.print_list Pp.newline2 (print_section sname) fmt l in
379 380 381
  let print_t fmt t =
    Pp.print_iter22 Mstr.iter Pp.newline2 print_sectionl fmt t in
  print_t fmt t;
382
  pp_print_newline fmt ()
383

384 385
let to_channel cout t =
  to_formatter (formatter_of_out_channel cout) t
386

387 388 389 390
let to_file s t =
  let out = open_out s in
  to_channel out t;
  close_out out
391

MARCHE Claude's avatar
MARCHE Claude committed
392
}