(***********************************************************************)
(*                                                                     *)
(*                          OCamlP3l                                   *)
(*                                                                     *)
(* (C) 2004-2007                                                       *)
(*             Roberto Di Cosmo (dicosmo@dicosmo.org)                  *)
(*             Zheng Li (zli@lip6.fr)                                  *)
(*             Pierre Weis (Pierre.Weis@inria.fr)                      *)
(*             Francois Clement (Francois.Clement@inria.fr)            *)
(*                                                                     *)
(* Based on original Ocaml P3L System                                  *)
(* (C) 1997 by                                                         *)
(*             Roberto Di Cosmo (dicosmo@ens.fr)                       *)
(*             Marco Danelutto (marcod@di.unipi.it)                    *)
(*             Xavier Leroy  (Xavier.Leroy@inria.fr)                   *)
(*             Susanna Pelagatti (susanna@di.unipi.it)                 *)
(*                                                                     *)
(* 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 (at your option) 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.                *)
(*                                                                     *)
(***********************************************************************)

(* BASIC DEFINITIONS *)

let version = "2.03";;

(* Reserved keys *)
let keys = [
  "gra"; "-graphical";
  "par"; "-parallel";
  "seq"; "-sequential";
  "thr"; "-thread";
  "gra"; "-graphical";
  "v"; "version"; "-version"; 
  "help";"-help";
];;

type exe =
   | Byt | Bin | Top;;
type semantic =
   | Seq | Par | Gra ;;
type model =
   | Process | Thread ;;

(* Semantics evaluation association list =
   sem * (sem_name * sem_ext_lib * sem_obj * sem_obj_open) *)
let sem_assoc = [
    (Seq, ("sequential",
           [],
           ["command_options"; "p3lstream"; "streams"; "seqp3l"],
           ["Seqp3l"]));
    (Gra, ("graphical",
           ["graphics"],
           ["command_options"; "p3lstream"; "grafp3l"],
           ["Grafp3l"]));
    (Par, ("parallel",
           ["unix"],
           ["command_options"; "p3lstream"; "basedefs"; "server";
            "commlib"; "parp3l"; "template"; "nodecode"],
           ["Nodecode";"Parp3l"]))
];;

(* Parallel model association list =
   model * (model_name * model_ext_path * model_ext_lib * model_path *)
let model_assoc = [
    (Process, ("process", "", [], "vprocess"));
    (Thread, ("thread", "+threads", ["unix"; "threads"], "vthread"))
];;

(* Executable kind association list =
   exe * (exe_name * exe_cmd * exe_sfx_obj * exe_sfx_lib) *)
let exe_assoc = [
    (Byt, ("bytecode compiler", "ocamlc", "cmo", "cma"));
    (Bin, ("nativecode compiler", "ocamlopt", "cmx", "cmxa"));
    (Top, ("toplevel (bytecode)", "ocaml", "cmo", "cma"))
];;

(* Configuration *)
type config = {
  mutable exe : exe;
  mutable sem : semantic;
  mutable model : model;
  mutable args : string list;
  mutable path : string;
};;

(* default configuration *)
let default_configuration = {
  exe = Byt; sem = Seq; model = Process; args = []; path = "+ocamlp3l";
};;

(* Setting the semantics evaluation regime choice. *)
let set_gra () = default_configuration.sem <- Gra;;
let set_par () = default_configuration.sem <- Par;;
let set_seq () = default_configuration.sem <- Seq;;

(* Produce version/help information *)
let get_version () = 
  Printf.printf "OcamlP3l version: %s\n" version;
  exit 0;;
let get_help () = exit 0;;



(* Bulding the command line options for the semantics evaluation regime. *)
let make_gra_option opt_name =
  (opt_name, Arg.Unit set_gra, "Use graphical execution");;
let make_par_option opt_name =
  (opt_name, Arg.Unit set_par, "Use parallel execution");;
let make_seq_option opt_name =
  (opt_name, Arg.Unit set_seq, "Use sequential execution");;
let make_version_option opt_name =
  (opt_name, Arg.Unit get_version, "Print ocamlp3l version");;
let make_help_option opt_name =
  (opt_name, Arg.Unit get_help, "Print ocamlp3l help");;



(* Setting the model for parallelism. *)
let set_thr () = default_configuration.model <- Thread;;
let set_pro () = default_configuration.model <- Process;;

(* Bulding the command line options for the model for parallelism. *)
let make_thr_option opt_name =
  (opt_name, Arg.Unit set_thr, "Use the thread model for parallelism");;
let make_pro_option opt_name =
  (opt_name, Arg.Unit set_pro, "Use the process model for parallelism");;

(* Instantiate configuration *)
let set_args () =
  let argv_m = Array.of_list
    (List.fold_left
       (fun l s ->
          if String.get s 0 = '-' then
            let key = String.sub s 1 (String.length s - 1) in
            if not (List.mem key keys) then l @ ["-ext"; key] 
            else l @ [s]
          else l @ [s])
       [] (Array.to_list Sys.argv)
    ) in

  let speclist = [
      make_gra_option "-gra"; make_gra_option "--graphical";
      make_par_option "-par"; make_par_option "--parallel";
      make_seq_option "-seq"; make_seq_option "--sequential";

      make_thr_option "-thr"; make_thr_option "--thread";
      make_pro_option "-pro"; make_pro_option "--process";
      make_version_option "-v"; make_version_option "-version";
      make_version_option "--version";
      ("-ext",
       Arg.String
         (fun s ->
            default_configuration.args <- default_configuration.args @ ["-" ^ s]),
       "Internal use only")
  ] in
  try
    Arg.parse_argv argv_m speclist
      (fun s -> default_configuration.args <- default_configuration.args @ [s])
      "OcamlP3l can also accept most compiler options of OCaml."

  with
  | Arg.Bad msg -> Printf.eprintf "%s" msg; exit 2;
  | Arg.Help msg -> Printf.printf "%s" msg; exit 0;;

(* Add suffix string [suff] to filename [fname]. *)
let add_suffix suff fname = Printf.sprintf "%s.%s" fname suff;;

(* A command is constructed by the following parts in the following
   sequence:
   Cmd(exe) + ModOpt(model) + ModPath(model) + ModLib(model+exe) +
   SemLib(sem+exe) + SemObj(sem+exe) + UsrCmd *)
let get_cmd () =
  let exe_name, exe_cmd, exe_sfx_obj, exe_sfx_lib =
    List.assoc default_configuration.exe exe_assoc in
  let sem_name, sem_ext_lib, sem_obj, sem_obj_open =
    List.assoc default_configuration.sem sem_assoc in
  let model_name, model_ext_path, model_ext_lib, model_path =
    List.assoc default_configuration.model model_assoc in
  let rflatten l =
    let rec aux accu = function
      | [] -> accu
      | [] :: t -> aux accu t
      | (hh :: ht) :: t ->
        aux (if List.mem hh accu then accu else accu @ [hh]) (ht :: t) in
    aux [] l in
  let all_inc_path =
    (match model_ext_path with
     | "" -> []
     | x -> ["-I"; x]) @
    ["-I"; Filename.concat default_configuration.path model_path] in
  let all_ext_lib =
    List.map (add_suffix exe_sfx_lib)
      (rflatten [sem_ext_lib; model_ext_lib]) in
  let all_ext_obj =
    List.map (add_suffix exe_sfx_obj) sem_obj in
  let argv_lib = all_inc_path @ all_ext_lib @ all_ext_obj in
  let argv_usr =
    let argv_usr_dup_removed =
      List.filter
        (fun x -> not (List.mem x all_ext_lib))
        default_configuration.args in
    List.fold_left
      (fun l x ->
         if Filename.check_suffix x "3l"  then l @ ["-impl"; x] else
         if Filename.check_suffix x "3li" then l @ ["-intf"; x] else
         l @ [x]
      ) [] argv_usr_dup_removed in
  let argv_dst =
    let rec guess_exe_name = function
      | [] -> None
      | h :: _ when
          List.exists (Filename.check_suffix h) ["cmo"; "cmx"] ->
          Some (Filename.chop_extension h)
      | h1 :: h2 :: _ when h2 = "-impl" ->
          Some (Filename.chop_extension h1)
      | _ :: t -> guess_exe_name t in
    let exe_sfx_dst = "opt" in
    let sem_sfx_dst = String.sub sem_name 0 3 in
    if List.exists (fun x -> x = "-c" || x = "-o") argv_usr then []
    else match default_configuration.exe with
      | Top -> []
      | Byt ->
          (match guess_exe_name (List.rev argv_usr) with
          | None -> []
          | Some x -> ["-o"; add_suffix sem_sfx_dst x])
      | Bin ->
          (match guess_exe_name (List.rev argv_usr) with
           | None -> []
           | Some x ->
               ["-o"; String.concat "." [x; sem_sfx_dst; exe_sfx_dst]])
  in
  let desc =
    Printf.sprintf "Launch %s with %s semantics and %s model."
      exe_name sem_name model_name in
  (exe_cmd, argv_lib @ argv_usr @ argv_dst, sem_obj_open, desc)
;;

let make_open_cmd mods =
  List.map (fun x -> Printf.sprintf "open %s\\;\\;" x) mods;;

let make_main exe =
  let command, arguments, mods, description =
    set_args ();
    default_configuration.exe <- exe;
    get_cmd () in

  let open_cmd = make_open_cmd mods in

  let preproc_cmd =
    ["-pp "; "\"echo -n " ^ String.concat "" open_cmd ^ " | cat - \""] in

  let cmd = String.concat " " (command :: preproc_cmd @ arguments) in

  let main () =
    print_endline description;
    match Sys.command cmd with
    | 0 -> exit 0
    | n ->
      print_endline (
        Printf.sprintf
          "Command %s\nfailed with status %d, something went wrong."
          cmd n); 
      exit 2 in
  main;;

(** Other useful tools. *)

let get_path_list path =
  let rec split s =
    try
      let pos = String.index s ':' in
      String.sub s 0 pos ::
      split (String.sub s (pos + 1) ((String.length s) - pos - 1)) with
    | Not_found -> [s] in
  try split (Sys.getenv path) with
  | Not_found -> [];;
(** Get the user's system environment variable env. *)

let make_top_main exe =
  let command, arguments, mods, description =
    set_args ();
    default_configuration.exe <- exe;
    get_cmd () in

  let init_file_name = Filename.temp_file "ocamlp3l" ".ml" in

  let build_init_file () =
    let oc = open_out init_file_name in
    List.iter (fun m ->
      output_string oc (Printf.sprintf "open %s;;\n" m))
      mods;
    output_string oc (Printf.sprintf "Sys.remove %S;;\n" init_file_name);
    close_out oc in

  let cmd = String.concat " " ([command; "-init"; init_file_name] @ arguments) in

  let main () =
    build_init_file ();

    print_endline description;
    match Sys.command cmd with
    | 0 -> exit 0
    | n ->
      print_endline (
        Printf.sprintf
          "Command %s\nfailed with status %d, something went wrong."
          cmd n); 
      exit 2 in

   main;;