(*********************************************************************************)

(*                Cameleon                                                       *)
(*                                                                               *)
(*    Copyright (C) 2005,2006 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                                          *)
(*                                                                               *)
(*********************************************************************************)


(* $Id: cam_files.ml 590 2007-09-05 12:57:58Z zoggy $ *)

module O = Config_file

type file_type = string

type rule =
    {
      rule_name : string ;
      rule_f : string array -> string -> bool ;
    }

let ft_unknown = "unknown"

(**

Configuration

*)


let rc_ft = Filename.concat Cam_rc.rc_dir "file_types.ini"
let ft_ini = new O.group
let save_ft () = ft_ini#write rc_ft
let load_ft () = ft_ini#read rc_ft

let value_to_ft_handler v =
  match v with
    O.Raw.Tuple [O.Raw.String name ; O.Raw.List l] ->
      let f acc = function
          O.Raw.String s -> s :: acc
        | _ -> acc
      in
      (name, List.rev (List.fold_left f [] l))
  | _ ->
      prerr_endline "value_to_ft_handler";
      raise Not_found

let ft_handler_to_value (ft, handlers) =
  O.Raw.Tuple
    [ O.Raw.String ft ;
      O.Raw.List (List.map (fun s -> O.Raw.String s) handlers);
    ]

let ft_handler_cp_wrapper =
  { O.to_raw = ft_handler_to_value ;
    O.of_raw = value_to_ft_handler ;
  }

let value_to_rule v =
  match v with
    O.Raw.Tuple [O.Raw.String ft; O.Raw.String rule] ->
      (ft, rule)
  | _ ->
      prerr_endline "value_to_rules";
      raise Not_found

let rule_to_value (ft, rule) =
  O.Raw.Tuple
    [ O.Raw.String ft ;
      O.Raw.String rule ;
    ]

let rule_cp_wrapper =
  { O.to_raw = rule_to_value ;
    O.of_raw = value_to_rule ;
  }

let default_editor_command = "chamo_open_file"
let default_ft_rules_and_handlers =
  [
    "regexp \".*\\\\.ml[ily]?$\"""OCaml source", [default_editor_command] ;
    "regexp \".*[mM]akefile$\"""Makefile", [default_editor_command] ;
    "regexp \".*\\\\.in$\"""Autoconf input file", [default_editor_command] ;
    "regexp \".*\\\\.txt$\"""Text file", [default_editor_command] ;
    "regexp \".*\\\\.htm[l]?$\"""HTML file", [default_editor_command] ;
    "regexp \".*\\\\.cvsignore$\"""CVS ignore file", [default_editor_command] ;
    "regexp \".*\\\\.sch$\"""DBForge schema", [Printf.sprintf "system %s" Cam_installation.dbforge_gui] ;
    "regexp \".*\\\\.rep$\"""Report template", [Printf.sprintf "system %s" Cam_installation.report_gui] ;
    "regexp \".*\\\\.rss$\"""RSS feed", ["open_rss_file"];
  ]

let default_ft_rules = List.map
    (fun (r,ft,_) -> (ft,r))
    default_ft_rules_and_handlers

let default_ft_handlers = List.map
    (fun (_,ft,com) -> (ft,com))
    default_ft_rules_and_handlers

let ft_rules = new O.list_cp rule_cp_wrapper
    ~group: ft_ini ["file_type_rules"]
    default_ft_rules
    ""

let ft_handlers = new O.list_cp ft_handler_cp_wrapper
    ~group: ft_ini ["file_type_handlers"]
    default_ft_handlers
    ""

let default_open_file_command =  new O.string_cp ~group: Cam_rc.gui_ini
    ["file_types_view" ; "open_file_command"] default_editor_command ""



(**

Configuring the file type rules

*)


module C = Configwin

let file_type_choices () =
  List.sort compare
    (Cam_misc.list_remove_doubles (List.map fst ft_rules#get))

type conf_ft = { mutable conf_ft : string ; mutable conf_rule : string ; }
let params_for_ft_rule available_rules ft =
  let param_ft = C.combo
      ~new_allowed:true
      ~blank_allowed:false
      ~f:(fun s -> ft.conf_ft <- Glib.Convert.locale_from_utf8 s)
      Cam_messages.file_type
      (file_type_choices ())
      (Glib.Convert.locale_to_utf8 ft.conf_ft)
  in
  let param_rule = C.combo
      ~new_allowed:true
      ~blank_allowed:false
      ~f: (fun s -> ft.conf_rule <- Glib.Convert.locale_from_utf8 s)
      Cam_messages.rule
      (List.map (fun r -> r.rule_name) available_rules)
      (Glib.Convert.locale_to_utf8 ft.conf_rule)
  in
  [ param_ft ; param_rule ]

let edit_ft_rules available_rules =
  let l = List.map
      (fun (ft, rule) -> { conf_ft = ft ; conf_rule = rule })
      ft_rules#get
  in
  let apply l =
    ft_rules#set
      (List.map (fun c -> (c.conf_ft, c.conf_rule)) l);
    save_ft ()
  in
  let edit c =
    let params = params_for_ft_rule available_rules c in
    ignore (C.simple_get Cam_messages.edit
              ~width: 300
              ~height: 100
              params
           );
    c
  in
  let add () =
    let c = { conf_ft = "" ; conf_rule = "" } in
    let params = params_for_ft_rule available_rules c in
    match C.simple_get Cam_messages.add
        ~width: 300
        ~height: 100
        params
    with
      C.Return_ok -> [c]
    | _ -> []
  in
  let display c =
    [ Glib.Convert.locale_to_utf8 c.conf_ft ;
      Glib.Convert.locale_to_utf8 c.conf_rule ;
    ]
  in
  let param = C.list
      ~f: apply
      ~edit
      ~add
      ~titles: [Cam_messages.file_type ; Cam_messages.rule ]
      ""
      display l
  in
  ignore
    (C.simple_get Cam_messages.file_types_rules
       ~width: 400
       ~height: 500
       [param]
    )

(**

Configuring the file type handlers

*)


type conf_fth =
    { mutable conf_ft : string ;
      mutable conf_hdls : string list;
    }

let params_for_ft ft =
  let param_ft = C.combo
      ~new_allowed:false
      ~blank_allowed:false
      ~f:(fun s -> ft.conf_ft <- Glib.Convert.locale_from_utf8 s)
      Cam_messages.file_type
      (file_type_choices ())
      (Glib.Convert.locale_to_utf8 ft.conf_ft)
  in
  let param_hdl r = C.combo
      ~new_allowed:true
      ~blank_allowed:false
      ~f: (fun s -> r := Glib.Convert.locale_from_utf8 s)
      Cam_messages.command
      (Cam_commands.available_command_names ())
      (Glib.Convert.locale_to_utf8 !r)
  in
  let param_hdl_list =
    let apply l = ft.conf_hdls <- l in
    let edit com =
      let r = ref com in
      let param = param_hdl r in
      ignore (C.simple_get Cam_messages.edit
                ~width: 300
                ~height: 100
                [param]
             );
      !r
    in
    let add () =
      let com = ref "" in
      let param = param_hdl com in
      match C.simple_get Cam_messages.add
          ~width: 300
          ~height: 100
          [param]
      with
        C.Return_ok -> [!com]
      | _ -> []
    in
    let display com = [ Glib.Convert.locale_to_utf8 com ] in
    C.list
      ~f: apply
      ~edit
      ~add
      ~titles: [Cam_messages.commands ]
      ""
      display ft.conf_hdls
  in
  [ param_ft ; param_hdl_list ]

let edit_ft_handlers () =
  let l = List.map
      (fun (ft, coms) -> { conf_ft = ft ; conf_hdls = coms })
      ft_handlers#get
  in
  let apply l =
    ft_handlers#set
      (List.map (fun c -> (c.conf_ft, c.conf_hdls)) l);
    save_ft ()
  in
  let edit c =
    let params = params_for_ft c in
    ignore (C.simple_get Cam_messages.edit
              ~width: 300
              ~height: 300
              params
           );
    c
  in
  let add () =
    let c = { conf_ft = "" ; conf_hdls = [] } in
    let params = params_for_ft c in
    match C.simple_get Cam_messages.add
        ~width: 300
        ~height: 300
        params
    with
      C.Return_ok -> [c]
    | _ -> []
  in
  let display c =
    [ Glib.Convert.locale_to_utf8 c.conf_ft ;
      Glib.Convert.locale_to_utf8
        (match c.conf_hdls with h :: _ -> h | _ -> "") ;
    ]
  in
  let param = C.list
      ~f: apply
      ~edit
      ~add
      ~titles: [Cam_messages.file_type ; Cam_messages.default_command ]
      ""
      display l
  in
  ignore
    (C.simple_get Cam_messages.file_types_handlers
       ~width: 400
       ~height: 500
       [param]
    )

(**

File types rules

*)


let rules : (string, rule) Hashtbl.t = Hashtbl.create 13

let register_rule r =
  try
    ignore(Hashtbl.find rules r.rule_name);
    failwith (Printf.sprintf "Rule %s already registered." r.rule_name)
  with
    Not_found ->
      Hashtbl.add rules r.rule_name r

let file_types () = (List.map fst ft_rules#get) @ [ft_unknown]

let file_type_of_file filename =
  let rec iter = function
      [] -> ft_unknown
    | (ft,command) :: q ->
        let args = Cam_commands.string_to_argv command in
        let len = Array.length args in
        if len < 1 then
          iter q
        else
          let rule_name = args.(0) in
          let params = Array.sub args 1 (len - 1) in
          try
            let r = Hashtbl.find rules rule_name in
            if r.rule_f params filename then ft else iter q
          with
            Not_found ->
              prerr_endline (Printf.sprintf "Unknown file type rule %s" rule_name);
              iter q
  in
  iter ft_rules#get


let _regexp_rule args f =
  let len = Array.length args in
   if len < 1 then
     false
   else
     (
      let re = Str.regexp args.(0) in
      Str.string_match re f 0
     )
let _ = register_rule
    { rule_name = "regexp" ;
      rule_f = _regexp_rule ;
    }

(**

File types handlers

We need to associate:
  • file type -> handler commands (kept in configuration file)
  • handler name -> function
*)



(* file type -> commands *)
let file_type_handlers : (file_type, string list) Hashtbl.t = Hashtbl.create 13

let associate_handler ft com =
(*
  prerr_endline (Printf.sprintf "associate_handler %s -> %s" ft com);
*)

  try
    let l = Hashtbl.find file_type_handlers ft in
    Hashtbl.replace file_type_handlers ft
      (l @ [com])
  with
    Not_found ->
      Hashtbl.add file_type_handlers ft [com]

(**

Launchin commands on files

*)


let command_on_files com files =
  let s = Printf.sprintf
      "%s %s"
      com
      (String.concat " " (List.map Filename.quote files))
  in
  Cam_commands.eval_command s


let edition_commands_menu_entries ?line f : GToolbox.menu_entry list =
  let ftype = file_type_of_file f in
  let l =
    try Hashtbl.find file_type_handlers ftype
    with Not_found -> []
  in
  let f_com com =
    fun () ->
      command_on_files com
        (f :: (match line with None -> [] | Some n -> [string_of_int n]))
  in
  match l with
    [] ->
      Cam_dbg.print ~level: 3 (Printf.sprintf "no handlers found for file type %s" ftype);
      let com = default_open_file_command#get in
      [
        `I (Cam_misc.escape_menu_label com, f_com com)
      ]
  | [com] ->
      [`I (Cam_misc.escape_menu_label com, f_com com)]
  | com::q ->
      let entries = List.map
          (fun com -> `I (Cam_misc.escape_menu_label com, f_com com))
          q
      in
      [ `I (Cam_misc.escape_menu_label com, f_com com) ;
        `M (Cam_messages.use_, entries) ;
      ]

let popup_file_commands_menu f =
  match edition_commands_menu_entries f with
    [] -> ()
  | entries ->
      GToolbox.popup_menu
        ~button: 3 ~time: Int32.zero
        ~entries



(**/**)


let _configure_ft_rules args =
  let available_rules = Hashtbl.fold
      (fun _ r acc -> r :: acc)
      rules
      []
  in
  edit_ft_rules available_rules

let _ = Cam_commands.register
    { Cam_commands.com_name = Cam_constant.com_configure_ft_rules ;
      Cam_commands.com_args = [| |] ;
      Cam_commands.com_more_args = None ;
      Cam_commands.com_f = _configure_ft_rules;
    }

let _configure_ft_handlers args =
  edit_ft_handlers ();
  Hashtbl.clear file_type_handlers ;
  List.iter
    (fun (ft, l) -> List.iter (associate_handler ft) l)
    ft_handlers#get

let _ = Cam_commands.register
    { Cam_commands.com_name = Cam_constant.com_configure_ft_handlers ;
      Cam_commands.com_args = [| |] ;
      Cam_commands.com_more_args = None ;
      Cam_commands.com_f = _configure_ft_handlers;
    }

let _ = load_ft ()
let _ = List.iter
    (fun (ft, l) -> List.iter (associate_handler ft) l)
    ft_handlers#get