(**************************************************************************)
(*  ocaml-gettext: a library to translate messages                        *)
(*                                                                        *)
(*  Copyright (C) 2003-2008 Sylvain Le Gall <sylvain@le-gall.net>         *)
(*                                                                        *)
(*  This library is free software; you can redistribute it and/or         *)
(*  modify it under the terms of the GNU Lesser General Public            *)
(*  License as published by the Free Software Foundation; either          *)
(*  version 2.1 of the License, or (at your option) any later version;    *)
(*  with the OCaml static compilation exception.                          *)
(*                                                                        *)
(*  This library 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     *)
(*  Lesser General Public License for more details.                       *)
(*                                                                        *)
(*  You should have received a copy of the GNU Lesser General Public      *)
(*  License along with this library; if not, write to the Free Software   *)
(*  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307   *)
(*  USA                                                                   *)
(**************************************************************************)

(** Ocaml-gettext tools.
    @author Sylvain Le Gall
  *)

(** Helper program to : 
  - extract translatable strings from OCaml source,
  - compile PO file,
  - install MO file,
  - merge POT and PO file.
*)

open GettextTypes;;
open GettextCategory;;
open GettextUtils;;
open FilePath.DefaultPath;;

IFDEF CAMOMILE THEN
module OcamlGettextRealize = GettextCamomile.Open
ELSE IFDEF STUB THEN
module OcamlGettextRealize =  GettextStub.Native
ELSE
module OcamlGettextRealize =  GettextDummy.Dummy
ENDIF
ENDIF
;;

module OcamlGettext = Gettext.Program
(
  struct
    let textdomain   = "ocaml-gettext"
    let codeset      = None
    let dir          = None
    let dependencies = Gettext.init
  end
)
( OcamlGettextRealize )
;;

type action = 
    Extract
  | Compile
  | Install 
  | Uninstall
  | Merge
  | Version
  | VersionShort
;;

type t =
  {
    action_option               : action option;
    extract_command             : string;
    extract_default_option      : string;
    extract_filename_options    : (string * string) list;
    extract_pot                 : string;
    compile_output_file_option  : string option;
    install_language_option     : string option;
    install_category            : GettextCategory.category;
    install_textdomain_option   : string option;
    install_destdir             : string;
    uninstall_language_option   : string option;
    uninstall_category          : GettextCategory.category;
    uninstall_textdomain_option : string option;
    uninstall_orgdir            : string;
    merge_filename_pot          : string;
    merge_backup_extension      : string;
    input_files                 : string list;
    strict                      : bool;
  }
;;

exception ActionRequired;;
exception InstallUninstallTooManyFilename;;
exception CompileTooManyFilename;;

let string_of_exception exc =
  let s_ x = 
    OcamlGettext.s_ x
  in
  match exc with
    ActionRequired ->
      (s_ "You must specify one action.")
  | InstallUninstallTooManyFilename ->
      (s_ 
"You cannot specify at the same time a language, a textdomain 
and provide more than one file to install/uninstall : all files
will have the same destination filename.")
  | CompileTooManyFilename ->
      (s_ 
"You cannot specify a output filename and more than one 
filename : all the compiled file will have the same output filename")
  | _ ->
      Gettext.string_of_exception exc
;;

let do_extract t =
  let real_lst = 
    let rec extract_potfiles accu lst = 
      match lst with
       str :: lst when str = "POTFILES" ->
         let chn = open_in str
         in
         let new_accu = 
           let rec extract_potfiles_aux accu = 
             try
               let new_filename = 
                 input_line chn
               in
               extract_potfiles_aux (new_filename :: accu)
             with End_of_file ->
               accu
           in
           extract_potfiles_aux accu
         in
         close_in chn;
         extract_potfiles new_accu lst
      | str :: lst ->
          extract_potfiles (str :: accu) lst 
      | [] ->
          List.rev accu
    in
    extract_potfiles [] t.input_files
  in
  let map_filename_options = 
    List.fold_left ( 
      fun map (fl,options) -> 
        MapString.add fl options map
      ) MapString.empty t.extract_filename_options
  in
  GettextCompile.extract 
  t.extract_command 
  t.extract_default_option 
  map_filename_options
  real_lst 
  t.extract_pot
;;

let do_compile t =
  match (t.compile_output_file_option,t.input_files) with
   Some fl_mo, [fl_po] ->
     GettextCompile.compile fl_po fl_mo
  | None, lst ->
      let fl_mo_of_fl_po fl_po =
        (* BUG: should use add_extension *)
        (chop_extension fl_po)^".mo"
      in
      List.iter ( fun fl_po -> 
        GettextCompile.compile fl_po (fl_mo_of_fl_po fl_po)
        ) lst
  | Some _, [] ->
      ()
  | Some _, lst ->
      raise CompileTooManyFilename
;;

let guess_language_textdomain (language_option,textdomain_option) lst =
  (* Rules for guessing language : language[.textdomain].mo *)
  match (language_option,textdomain_option,lst) with
    Some language, Some textdomain, [fl_mo] ->
      [(language,textdomain,fl_mo)]
  | Some _, Some _, [] ->
      []
  | Some _, Some _, lst ->
      raise InstallUninstallTooManyFilename
  | Some language, None, lst ->
      List.map (fun fl_mo -> (language,(chop_extension fl_mo),fl_mo)) lst
  | None, Some textdomain, lst ->
      List.map (fun fl_mo -> ((chop_extension fl_mo),textdomain,fl_mo)) lst
  | None, None, lst ->
      List.map (fun fl_mo -> 
        (* BUG: should be able to have get_extension working *)
        (*
        let str_reduce = 
          chop_extension fl_mo
        in 
        * (((chop_extension str_reduce), (get_extension str_reduce)),fl_mo)*)
        raise (Failure
"FilePath suffers from a default with the handling of
chop/get_extension. This bug should disappears with 
newer version of ocaml-fileutils")
      ) lst
;;

let do_install t =
  let install (language,textdomain,fl_mo) =
    GettextCompile.install 
      t.strict
      t.install_destdir 
      language 
      t.install_category 
      textdomain 
      fl_mo
  in
  List.iter install (
    guess_language_textdomain
    (t.install_language_option,t.install_textdomain_option) 
    t.input_files
  )
;;

let do_uninstall t =
  let uninstall (language,textdomain,_) =
    GettextCompile.uninstall 
      t.uninstall_orgdir 
      language 
      t.uninstall_category 
      textdomain 
  in
    List.iter 
      uninstall 
      (guess_language_textdomain
         (t.uninstall_language_option,t.uninstall_textdomain_option) 
         t.input_files)
;;

let do_merge t =
  GettextCompile.merge t.merge_filename_pot t.input_files t.merge_backup_extension
;;

let do_action t = 
  match t.action_option with
    Some Extract ->
      do_extract t
  | Some Compile ->
      do_compile t
  | Some Install ->
      do_install t
  | Some Uninstall ->
      do_uninstall t
  | Some Merge ->
      do_merge t
  | Some Version ->
      (
        let (_,gettext_copyright) = 
          OcamlGettext.init
        in
        print_string gettext_copyright;
        print_newline ()
      )
  | Some VersionShort ->
      (
        print_string GettextConfig.version;
        print_newline ()
      )
  | None ->
      raise ActionRequired
;;
      
let () = 
  let spf x = 
    Printf.sprintf x
  in
  let f_ x = 
    OcamlGettext.f_ x
  in
  let s_ x = 
    OcamlGettext.s_ x
  in
  let t = ref
    {
      action_option               = None;
      extract_command             = "ocaml-xgettext";
      extract_default_option      = "-I +camlp4 pa_o.cmo";
      extract_filename_options    = [];
      extract_pot                 = "messages.pot";
      compile_output_file_option  = None;
      install_language_option     = None;
      install_category            = LC_MESSAGES;
      install_textdomain_option   = None;
      install_destdir             = GettextConfig.default_dir;
      uninstall_language_option   = None;
      uninstall_category          = LC_MESSAGES;
      uninstall_textdomain_option = None;
      uninstall_orgdir            = GettextConfig.default_dir;
      merge_filename_pot          = "messages.pot";
      merge_backup_extension      = "bak";
      input_files                 = [];
      strict                      = false;
    }
  in
  let actions = [
      "extract",   Extract;
      "compile",   Compile;
      "install",   Install;
      "uninstall", Uninstall;
      "merge",     Merge
    ]
  in
  let (gettext_args,gettext_copyright) = 
    OcamlGettext.init
  in
  let args = 
    Arg.align
    (
      [
        (
          "--action",
          Arg.Symbol 
          (
            (List.map fst actions),
            (fun symbol ->
              try
                t := { !t with action_option = Some (List.assoc symbol actions) }
              with Not_found ->
                raise (Arg.Bad (spf (f_ "Invalid action: %s.") symbol))
            )
          ),
          (
            (s_ "Action to execute. Default: none.") 
          )
        );
        (
          "--extract-command",
          Arg.String ( fun cmd ->
            t := { !t with extract_command = cmd }
          ),
          (
            spf (f_ "cmd Command to extract translatable strings from an OCaml source file. Default: %s.")
            !t.extract_command
          )
        );
        (
          "--extract-default-option",
          Arg.String ( fun default_option ->
            t := { !t with extract_default_option = default_option }
          ),
          (
            spf (f_ "options Default option used when extracting translatable strings. Default: %S.")
            !t.extract_default_option
          )
        );
        (
          "--extract-filename-option",
          Arg.Tuple (
            let filename = ref ""
            in
            [
              Arg.String ( fun str -> filename := str );
              Arg.String ( fun options -> 
                t := { !t with extract_filename_options =
                  (!filename,options) ::
                  !t.extract_filename_options
                }
              )
            ]
          ),
          (
            spf (f_ "filename options Per filename option used when extracting strings from the specified filename. Default: %s.")
            (string_of_list (
              List.map ( fun (str1,str2) -> 
                spf "(%s,%s)" str1 str2
                ) !t.extract_filename_options
              )
            )
          )
        );
        (
          "--extract-pot",
          (
            Arg.String ( fun str ->
              t := { !t with extract_pot = str }
            )
          ),
          spf (f_ "filename POT file to write when extracting translatable strings. Default: %s.")
          !t.extract_pot
        );
        (
          "--compile-output",
          (
            Arg.String ( fun str ->
              t := { !t with compile_output_file_option = Some str }
            )
          ),
          (s_ "filename MO file to write when compiling a PO file. Default: name of the PO file with \".mo\" extension.")
        );
        (
          "--install-language",
          (
            Arg.String ( fun str ->
              t := { !t with install_language_option = Some str }
            )
          ),
          (s_ "language Language to use when installing a MO file. Default: try to guess it from the name of the MO file.")
        );
        (
          "--install-category",
          (
            Arg.String ( fun str ->
              t := { !t with install_category = GettextCategory.category_of_string str }
            )
          ),
          spf (f_ "category Category to use when installing a MO file. Default: %s.")
          (GettextCategory.string_of_category !t.install_category)
        );
        (
          "--install-textdomain",
          (
            Arg.String ( fun str ->
              t := { !t with install_textdomain_option = Some str }
            )
          ),
          (s_ "textdomain Textdomain to use when installing a MO file. Default: try to guess it from the name of the MO file.")
        );
        (
          "--install-destdir",
          (
            Arg.String ( fun str ->
              t := { !t with install_destdir = str }
            )
          ),
          spf (f_ "dirname Base dir used when installing a MO file. Default: %s.")
          !t.install_destdir
        );
        (
          "--strict",
          Arg.Unit (fun () -> t := {!t with strict = true}),
          spf (f_ " Additional check are errors during install. Default: %b.")
            !t.strict
        );
        (
          "--uninstall-language",
          (
            Arg.String ( fun str ->
              t := { !t with uninstall_language_option = Some str }
            )
          ),
          (s_ "language Language to use when uninstalling a MO file. Default: try to guess it from the name of the MO file.")
        );
        (
          "--uninstall-category",
          (
            Arg.String ( fun str ->
              t := { !t with uninstall_category = GettextCategory.category_of_string str }
            )
          ),
          spf (f_ "category Category to use when uninstalling a MO file.  Default: %s.")
          (GettextCategory.string_of_category !t.uninstall_category)
        );
        (
          "--uninstall-textdomain",
          (
            Arg.String ( fun str ->
              t := { !t with uninstall_textdomain_option = Some str }
            )
          ),
          (s_ "textdomain Textdomain to use when uninstalling a MO file. Default: try to guess it from the name of the MO file.")
        );
        (
          "--uninstall-orgdir",
          (
            Arg.String ( fun str ->
              t := { !t with uninstall_orgdir = str }
            )
          ),
          spf (f_ "dirname Base dir used when uninstalling a MO file. Default: %s.")
          !t.uninstall_orgdir
        );
        (
          "--merge-pot",
          ( 
            Arg.String ( fun str ->
              t := { !t with merge_filename_pot = str }
            )
          ),
          spf (f_ "filename POT file to use as a master for merging PO file. Default: %s.")
          !t.merge_filename_pot
        );
        (
          "--merge-backup-extension",
          (
            Arg.String ( fun str ->
              t := { !t with merge_backup_extension = str }
            )
          ),
          spf (f_ "extension Backup extension to use when moving PO file which have been merged. Default: %s.")
          !t.merge_backup_extension
        );
        (
          "--version",
          (
            Arg.Unit ( fun () ->
              t := { !t with action_option = Some Version }
            )
          ),
          (s_ " Returns version information on ocaml-gettext.")
        );
        (
          "--short-version",
          (
            Arg.Unit ( fun () ->
              t := { !t with action_option = Some VersionShort }
            )
          ),
          (s_ " Returns only the version string of ocaml-gettext.")
        );
    ] @ gettext_args
  )
  in
  let () = 
    Arg.parse 
    args
    (
      fun str ->
        t := { !t with input_files = str :: !t.input_files }
    )
    (
      spf (f_ "%s

Command: ocaml-gettext -action (%s) [options]
When trying to guess language and textdomain from a 
MO file, the rules applied are: language.textdomain.mo

Options:") 
      gettext_copyright
      (String.concat "|" (List.map fst actions))
    )
  in
  try
    do_action !t
  with exc ->
    (
      prerr_string (string_of_exception exc);
      prerr_newline ();
      prerr_string (s_ "An error occurs while processing.");
      prerr_newline ();
      exit 1
    )
;;