(* Configuration *)
(* $Id$ *)

type t =
| List of t list
| Boolean of bool
| Integer of int
| String of string
| Tuple of t list
| Record of (string * handle) list ref
and handle = {
  mutable status : status;
  mutable value : t
} and status =
| Dont_change (* don't save to user configuration file *)
| Save (* should be saved when other values are saved *)
| Changed (* was changed, needs saving *)
;;

type context = {
  mutable filename : string option;
  cache : (string, t) Hashtbl.t;
  config : handle
};;

let handle v = { status = Dont_change; value = v };;

(*** comment_killer_line_counter *)
let comment_killer_line_counter lc s =
  let rec state0 = parser
  | [< 'c; s >] ->
    (match c with
    | '#' -> state1 s
    | '\n' -> incr lc; [< 'c; state0 s >]
    | _ -> [< 'c; state0 s >])
  | [< >] -> [< >]
  and state1 = parser
  | [< 'c; s >] ->
    if c = '\n' then
      begin
      incr lc;
      [< '' '; state0 s >]
      end
    else
      state1 s
  | [< >] -> [< >]
  in
  state0 s
;;
(* ***)

let keywords = [".";"{";"}";"(";")";"[";"]";",";";";":";"true";"false";"on";"off";"yes";"no"];;

(*** parse_config *)
let parse_config s =
  (* parses record contents.  string * handle list *)
  let rec parse_record ?(toplevel=false) r = parser
    | [< '(Genlex.Ident k); h = parse_record2; s >] -> parse_record ~toplevel ((k,h)::r) s
    | [< '(Genlex.Kwd "}") >] -> if toplevel then raise Stream.Failure else r
    | [< >] -> if toplevel then r else raise Stream.Failure
  (* returns a handle *)
  and parse_record2 = parser
    | [< '(Genlex.Kwd ":"); v = parse_stuff2 >] -> handle v
    | [< '(Genlex.Kwd "{"); hl = parse_record [] >] -> handle (Record(ref hl))
    | [< '(Genlex.Kwd "."); '(Genlex.Ident k); h = parse_record2 >] -> handle (Record(ref [k,h]))
  (* returns a t *)
  and parse_stuff2 = parser
    | [< '(Genlex.Kwd "{"); hl = parse_record [] >] -> Record(ref hl)
    | [< '(Genlex.Int i) >] -> Integer i
    | [< '(Genlex.Kwd ("true"|"on"|"yes")) >] -> Boolean true
    | [< '(Genlex.Kwd ("false"|"off"|"no")) >] -> Boolean false
    | [< '(Genlex.String w) >] -> String w
    | [< '(Genlex.Kwd "("); x = parse_tuple [] >] -> Tuple(x)
    | [< '(Genlex.Kwd "["); x = parse_list [] >] -> List(x)
  and parse_tuple l = parser
    | [< x = parse_stuff2; s >] -> parse_tuple2 (x::l) s
    | [< >] -> parse_tuple2 l s
  and parse_tuple2 l = parser
    | [< '(Genlex.Kwd ")") >] -> List.rev l
    | [< '(Genlex.Kwd ","); s >] -> parse_tuple l s
  and parse_list l = parser
    | [< x = parse_stuff2; s >] -> parse_list2 (x::l) s
    | [< >] -> parse_list2 l s
  and parse_list2 l = parser
    | [< '(Genlex.Kwd "]") >] -> List.rev l
    | [< '(Genlex.Kwd ";"); s >] -> parse_list l s
  in
  parse_record ~toplevel:true [] s
;;
(* ***)

exception Parse_error of int * string;;
exception Semantic_error of string;;
exception Key_not_found of string;;
exception No_default_value of string;;
exception Is_not_a_record of string;;
exception Type_error of string * string;;
exception No_filename;;

(*** create_context *)
let create_context ?(config = None) fn =
  let t = match config with None -> Record(ref []) | Some t -> t in
  { filename = fn;
    cache = Hashtbl.create 16;
    config = handle t }
;;
(* ***)
(*** iter_over_keys *)
let iter_over_keys f t =
  let rec loop ks = function
    | Tuple _|List _|Boolean _|Integer _|String _ -> f ks
    | Record(lr) -> List.iter (fun (k,h) -> loop (k::ks) h.value) !lr
  in
  loop [] t
;;
(* ***)
(*** change_status_all *)
let change_status_all f t =
  let rec loop = function
  | Record(lr) ->
      List.iter
        (fun (k,h) ->
          h.status <- f h.status;
          loop h.value)
        !lr
  | (Tuple l|List l) -> List.iter loop l
  | Boolean _|Integer _|String _ -> ()
  in
  loop t;;
(* ***)
(*** needs_saving *)
let rec needs_saving = function
  | Record(lr) ->
      List.exists (fun (k,h) -> h.status <> Dont_change or needs_saving h.value) !lr
  | (Tuple l|List l) -> List.exists needs_saving l
  | Boolean _|Integer _|String _ -> false
;;
(* ***)
(*** filter_changed *)
let filter_changed ctx t =
  let rec loop ks r = function
    | (k,h)::u ->
      if h.status <> Dont_change or needs_saving h.value then
        begin
          match h.value with
          | Tuple _|List _|Boolean _|Integer _|String _ -> loop ks ((k,h)::r) u
          | Record(lr) ->
              if List.exists (fun (_,h) -> h.status <> Dont_change or needs_saving h.value) !lr then
                loop
                  ks
                  ((k,{ status = h.status; value = loop (k::ks) [] !lr})::r)
                  u
              else
                loop ks r u
        end
      else
        loop ks r u
    | [] -> Record(ref r)
  in
  match ctx.config.value with
  | Record(lr) -> loop [] [] !lr
  | t -> t
;;
(* ***)
(*** get_config *)
let get_config ctx = ctx.config.value;;
(* ***)
(*** set_config *)
let set_config ctx t =
  ctx.config.value <- t;
  ctx.config.status <- Changed;
  Hashtbl.clear ctx.cache
;;
(* ***)
(*** coalesce *)
let coalesce ?(merge=false) t =
  let rec coalesce path = function
  | List(l) -> List(List.map (coalesce path) l)
  | (Boolean _|Integer _|String _) as x -> x
  | Tuple(l) -> Tuple(List.map (coalesce path) l)
  | Record(lr) ->
      let l = !lr in
      let rec loop r = function
        | (k,h)::y ->
            let v = coalesce (k::path) h.value in
            if List.mem_assoc k r then
              begin
                let h' = List.assoc k r in
                let (s,v) =
                  match (v, h'.value) with
                  (*| List(l1),List(l2) -> Dont_change,List(l1@l2)*)
                  | Record(lr1),Record(lr2) ->
                      (Dont_change,coalesce (k::path) (Record(ref ((!lr1)@(!lr2))))) (* ? *)
                  | _ ->
                      if merge then
                        match h.status,h'.status with
                        | ((Save|Changed),Dont_change) -> (Changed, h.value)
                        | (Dont_change,(Save|Changed)) -> (Changed, h'.value)
                        | (Dont_change,Dont_change) -> (Changed, h'.value)
                        | _ ->
                          raise (Semantic_error
                            (Printf.sprintf "Cannot join changed values for key %s under %s"
                              k
                              (String.concat "." path)))
                      else
                        raise
                          (Semantic_error
                            (Printf.sprintf "Cannot join values for key %s under %s"
                              k
                              (String.concat "." path)))
                in
                loop ((k, {status = s; value = v})::(List.remove_assoc k r)) y
              end
            else
              loop ((k,h)::r) y
        | [] -> Record(ref r)
      in
      loop [] l
  in
  coalesce [] t
;;
(* ***)
(*** parse_string *)
let parse_string w =
  let ts =
    (Genlex.make_lexer keywords)
    (Stream.of_string w)
  in
  parse_config ts
;;
(* ***)
(*** dump *)
let dump ?(show_status=false) f t =
  let rec loop ?(top=false) = function
    | List(l) ->
        Format.fprintf f "[@[";
        let y = ref false in
        List.iter (fun x ->
          if !y then Format.fprintf f ";@ ";
          loop x;
          y := true) l;
        Format.fprintf f "@]]"
    | Tuple(l) ->
        Format.fprintf f "(@[";
        let y = ref false in
        List.iter (fun x ->
          if !y then Format.fprintf f ",@ ";
          loop x;
          y := true) l;
        Format.fprintf f "@])"
    | Boolean true -> Format.fprintf f "true"
    | Boolean false -> Format.fprintf f "false"
    | String w -> Format.fprintf f "%S" w
    | Integer x -> Format.fprintf f "%d" x
    | Record lr ->
        let l = !lr in
        if not top then Format.fprintf f "{@[";
        let y = ref false in
        List.iter (fun (k,h) ->
          let x = h.value in
          if not top or !y & top then Format.fprintf f "@\n";
          y := true;
          if show_status then
            Format.fprintf f "(* %s *) "
              (match h.status with
               | Dont_change -> "Don't change"
               | Save -> "Save"
               | Changed -> "Changed")
          else
            ();
          begin
            match x with
            | Record(_) -> Format.fprintf f "%s " k;
            | _ -> Format.fprintf f "%s: " k;
          end;
          loop x) l;
        if not top then Format.fprintf f "@]@\n}"
  in
  loop ~top:true t
;;
(* ***)
(*** load_from_file *)
let load_from_file fn =
  let ic = open_in fn in
  let lc = ref 1 in
  let ts =
    (Genlex.make_lexer keywords)
    (comment_killer_line_counter lc (Stream.of_channel ic))
  in
  let pe x =
    close_in ic;
    raise (Parse_error(!lc,x))
  in
  try
    let t = parse_config ts in
    close_in ic;
    coalesce (Record(ref t))
  with
  | Parsing.Parse_error -> pe "Lexical error"
  | (Stream.Error(_)|Stream.Failure) -> pe "Syntax error"
;;
(* ***)
(*** load *)
let load ?(merge_with=[]) primary_fn default_fns =
  let errors = ref [] in
  let res = ref (List.map (fun x -> ("root",handle x)) merge_with) in
  List.iter (fun fn ->
    try
      let t = load_from_file fn in
      let h =
        if Some fn = primary_fn then
          begin
            change_status_all (fun _ -> Save) t;
            { status = Save;
              value = t }
          end
        else
          { status = Dont_change;
            value = t }
      in
      (*Format.printf ">>> From file %S:\n" fn;
      dump ~show_status:true Format.std_formatter t;*)
      res := ("root",h)::!res
    with
    | x -> errors := (fn,x)::!errors)
    (match primary_fn with None -> default_fns | Some fn -> fn::default_fns);
  let t =
    match coalesce ~merge:true (Record(res)) with
    | Record(lr) ->
        begin
          match !lr with
          | [_,h] -> h.value
          | [] -> Record(ref [])
          | _ ->
              assert false
        end
    | _ -> assert false
  in
  ({ filename = primary_fn;
     cache = Hashtbl.create 16;
     config = handle t }, !errors)
;;
(* ***)
(*** split_at_dots *)
let split_at_dots u =
  let m = String.length u in
  let rec loop r i j =
    if i >= m then
      List.rev r
    else
      if j = m or u.[j] = '.' then
        loop ((String.sub u i (j - i))::r) (j + 1) (j + 1)
      else
        loop r i (j + 1)
  in
  loop [] 0 0
;;
(* ***)
(*** access *)
let access ?(set = false) ?default ctx k =
  try
    (* First, check if the value is already in cache (except if set is true). *)
    if set then raise Not_found
    else Hashtbl.find ctx.cache k
  with
  | Not_found ->
      (* Value is notin cache, we'll have to dig it up. *)
      let ks = split_at_dots k in (* Split the key into components *)
      (* loop h kl searches and eventually creates or updates the value named kl
       * in h, which msut be a handle to a record
       *)
      let rec loop (h : handle) kl =
        match kl with
        | [] ->
            (* An empty selector selects the current handle
             * whose value is returned, or changed *)
            if set then
              (* We must change the value *)
              match default with
              | None -> raise (No_default_value(k))
              | Some t ->
                (* Compare the stored and actual values *)
                if h.value <> t then
                  begin
                    h.status <- Changed;
                    h.value <- t;
                    Hashtbl.remove ctx.cache k; (* invalidate cache entry *)
                    t
                  end
                else
                  begin
                    (* Return the value stored in the cell. *)
                    h.value
                  end
            else
              h.value
        | k1::ks ->
          (* The selector is not empty.  We must first select k1 in h
           * and then proceed. *)
          match h.value with
          | Record(lr) ->
            (* All right, we are accessing a record ; k1 should be a member of it. *)
            begin
              let l = !lr in
              match
                (* Try to get the handle for k1 in the record. *)
                try
                  Some(List.assoc k1 l)
                with
                | Not_found -> None
              with
              | Some h' ->
                  (* We have found the handle for k1. *)
                  (* Recursively call loop on it. *)
                  loop h' ks
              | None ->
                  (* Handle for k1 not found in current record.
                   * We'll need to create it. *)
                  match default with
                  | None ->
                      (* There is no default.  What are we supposed to write ?? *)
                      raise (Key_not_found k)
                  | Some t' ->
                      begin
                        (* The value of this handle, or one of its subhandles
                         * will be changed. Therefore we set the status of this
                         * handle to Changed. *)
                        h.status <- Changed;
                        if ks = [] then
                          begin
                            (* This is the penultimate handle.
                             * In other words h is the handle
                             * of the record that will contain
                             * the value to be changed.
                             *)
                            lr := (k1,{ status = Changed; value = t' })::!lr;
                            t'
                          end
                        else
                          begin
                            (* This is not yet the penultimate handle.
                             * In other words we still need to create
                             * subsrecords. *)
                            let h'' = { status = Changed;
                                        value = Record(ref []) }
                            in
                            lr := (k1,h'')::!lr;
                            loop h'' ks
                          end
                      end
            end
          | _ ->
              dump Format.std_formatter ctx.config.value;
              raise (Is_not_a_record k)
      in
      loop ctx.config ks
;;
(* ***)
(*** get, set, to_*, get_*, set_* *)
let get = access;;
let set ctx k (x : t) = ignore (access ~set:true ?default:(Some x) ctx k);;

let to_int ?(k="") = function Integer i -> i | _ -> raise (Type_error(k,"Integer"));;
let to_string ?(k="") = function String w -> w | _ -> raise (Type_error(k,"String"));;
let to_bool ?(k="") = function Boolean x -> x | _ -> raise (Type_error(k,"Boolean"));;
let to_pair f g ?(k="") = function Tuple[x;y] -> (f x, g y) | _ -> raise (Type_error(k,"Pair"));;
let to_list f ?(k="") = function List l -> List.map f l | _ -> raise (Type_error(k,"List"));;

let ( <~< ) f (g : ?k:'a -> 'b -> 'c) ?default ctx k = g ~k (f ?default ctx k);;

let get_int ?default ctx k =
  to_int ~k
    (get ?default:(match default with None -> None | Some i -> Some(Integer i))
     ctx k);;
let get_bool ?default ctx k =
  to_bool ~k
    (get ?default:(match default with None -> None | Some x -> Some(Boolean x))
     ctx k);;
let get_string ?default ctx k =
  to_string ~k
    (get ?default:(match default with None -> None | Some w -> Some(String w))
     ctx k);;
let get_list ?default f ctx k = to_list f ~k (get ?default ctx k);;
let get_pair ?default f g ctx k = to_pair f g ~k (get ?default ctx k);;

let set_int ctx k i = set ctx k (Integer i);;
let set_string ctx k w = set ctx k (String w);;
let set_bool ctx k x = set ctx k (Boolean x);;

let set_pair ctx k (x, y) = set ctx k (Tuple[x;y]);;
(* ***)
(*** duplicate *)
let rec duplicate = function
  | Record(lr) -> Record(ref (List.map (fun (k,h) -> (k,{ h with value = duplicate h.value })) !lr))
  | List(l) -> List(List.map duplicate l)
  | Tuple(l) -> Tuple(List.map duplicate l)
  | (String _ | Integer _ | Boolean _) as x -> x
;;
(* ***)
(*** duplicate_context *)
let duplicate_context ctx =
  let h = handle (duplicate ctx.config.value) in
  h.status <- ctx.config.status;
  { ctx with
    cache = Hashtbl.create 16;
    config = h }
;;
(* ***)
(*** save *)
let save ctx =
  match ctx.filename with
  | None -> raise No_filename
  | Some filename ->
    if true or ctx.config.status <> Dont_change then
      begin
        let oc = open_out filename in
        try
          let l = Unix.localtime (Unix.gettimeofday ()) in
          Printf.fprintf oc "(* %S written on %04d-%02d-%02d %02d:%02d:%02d *)\n"
            filename
            (l.Unix.tm_year + 1900)
            (l.Unix.tm_mon + 1)
            l.Unix.tm_mday
            l.Unix.tm_hour
            l.Unix.tm_min
            l.Unix.tm_sec;
          Printf.fprintf oc "(* Configuration values are preserved but formatting and comments\n   \
                                will be lost on next write. *)\n";
          let t = filter_changed ctx ctx.config in
          let f = Format.formatter_of_out_channel oc in
          dump f t;
          Format.pp_print_flush f ();
          close_out oc;
          change_status_all
            (function Changed|Save -> Save | Dont_change -> Dont_change)
            ctx.config.value;
        with
        | x ->
            close_out oc;
            raise x
      end
    else
      ()
;;
(* ***)
(*** set_filename *)
let set_filename ctx f = ctx.filename <- f;;
(* ***)
