
open Utils

let force_link_all = ref true

let link_all () =
  if !force_link_all
  then ["-linkall"]
  else []

let usage () =
  Printf.eprintf "Usage: %s <options> <files>\n" (Filename.basename Sys.argv.(0));
  Printf.eprintf "SPECIFIC OPTIONS:\n";
  Printf.eprintf "  -package <name>\tRefer to package when compiling\n";
  Printf.eprintf "  -no-autoload\t\tDo not load commonly used syntax extensions (deriving, lwt, js_of_ocaml, tyxml)\n";
  if !kind <> `Client then
    Printf.eprintf "  -infer\t\tOnly infer the type of values sent by the server\n";
  Printf.eprintf "  -dir <dir>\t\tThe directory for generated files (default %S)\n"
    (if !kind = `Client then default_client_dir else default_server_dir);
  Printf.eprintf "  -type-dir <dir>\tThe directory to read server type files from (default %S)\n"
    default_type_dir;
  Printf.eprintf "  -server-types-ext <ext> The extension for server type files (default %S)\n"
    default_server_types_ext;
  if !kind = `Client then
    Printf.eprintf "  -jsopt <opt>\t\tAppend option <opt> to js_of_ocaml invocation\n";
  Printf.eprintf "  -ppopt <p>\t\tAppend option <opt> to preprocessor invocation\n";
  Printf.eprintf "  -predicates <p>\tAdd predicate <p> when resolving package properties\n";
  Printf.eprintf "  -ppx";
  Printf.eprintf "\t\t\tUse the PPX Eliom syntax extension (default: Camlp4)\n";
  Printf.eprintf "\t\t\tThe above description only applies to the first\n";
  Printf.eprintf "\t\t\tappearance of -ppx in the list of flags. Subsequent\n";
  Printf.eprintf "\t\t\tappearances require an argument and specify a\n";
  Printf.eprintf "\t\t\tPPX preprocessor to use (see STANDARD OPTIONS).\n";
  if !kind = `Client then
    Printf.eprintf "  -dont-force-linkall\t\tDo not add linkall option by default\n";
  create_filter !compiler ["-help"] (help_filter 2 "STANDARD OPTIONS:");
  if !kind = `Client then
    create_filter !js_of_ocaml ["-help"] (help_filter 1 "JS_OF_OCAML OPTIONS:");
  exit 1

(** Context *)

let jsopt : string list ref = ref []
let output_name : string option ref = ref None

type mode = [ `Link | `Compile | `Infer | `Library  | `Pack | `Obj | `Shared | `Interface ]

let mode : mode ref = ref `Link

let do_compile () = !mode <> `Infer
let do_interface () = !mode = `Interface
let do_dump = ref false

let create_process ?in_ ?out ?err ?on_error name args =
  wait ?on_error (create_process ?in_ ?out ?err name args)

let rec check_or_create_dir name =
  if name <> "/" then
    try ignore(Unix.stat name) with Unix.Unix_error _ ->
      check_or_create_dir (Filename.dirname name);
      try Unix.mkdir name 0o777 with
      (* this append sometime with // compilation *)
      | Unix.Unix_error (Unix.EEXIST,_,_) -> ()
      | Unix.Unix_error (_,_,_) ->
        Printf.eprintf "Unexpected error while creating directory %S" name

let prefix_output_dir name =
  match !build_dir with
  | "" -> name
  | d -> d ^ "/" ^ name

let chop_extension_if_any name =
  try Filename.chop_extension name with Invalid_argument _ -> name

let output_prefix ?(ty = false) name =
  let name =
    match !output_name with
    | None ->
      if !mode = `Infer || ty
      then prefix_type_dir name
      else prefix_output_dir name
    | Some n ->
      if !mode = `Compile || !mode = `Infer
      then (output_name := None; n)
      else prefix_output_dir name in
  check_or_create_dir (Filename.dirname name);
  chop_extension_if_any name

let set_mode m =
  if !mode = `Link then
    ( if
      (m = `Shared && !kind <> `ServerOpt) ||
      (m = `Infer && !kind = `Client) ||
      (m = `Interface && !kind = `Client)
      then
        usage ()
      else
        mode := m )
  else
    let args =
      let basic_args = ["-pack"; "-a"; "-c"; "output-obj"] in
      let infer_args = if !kind <> `Client then ["-i"; "-infer"] else [] in
      let shared_args = if !kind <> `ServerOpt then ["-shared"] else [] in
      basic_args @ infer_args @ shared_args
    in
    Printf.eprintf
      "Please specify at most one of %s\n%!"
      (String.concat ", " args);
    exit 1

let get_product_name () = match !output_name with
  | None ->
    Printf.eprintf
      "Please specify the name of the output file, using option -o\n%!";
    exit 1
  | Some name ->
    check_or_create_dir (Filename.dirname name);
    name

let build_library () =
  create_process !compiler (
    ["-a" ; "-o"  ; get_product_name () ]
    @ get_common_include ()
    @ !args )

let build_pack () =
  create_process !compiler (
    [ "-pack" ; "-o"  ; get_product_name () ]
    @ get_common_include ()
    @ !args )

let build_obj () =
  create_process !compiler (
    ["-output-obj" ; "-o"  ; get_product_name () ]
    @ get_common_include ()
    @ !args )

let build_shared () =
  create_process !compiler (
    ["-shared" ; "-o"  ; get_product_name () ]
    @ get_common_include ()
    @ !args )

let get_thread_opt () = match !kind with
  | `Client -> []
  | `Server | `ServerOpt -> ["-thread"]

let obj_ext () = if !kind = `ServerOpt then ".cmx" else ".cmo"

(* Process ml and mli files *)

let compile_ocaml ~impl_intf file =
  let obj =
    let ext = match impl_intf with
      | `Impl -> obj_ext ()
      | `Intf -> ".cmi"
    in
    output_prefix file ^ ext in
  create_process !compiler (
    ["-c" ;
     "-o" ; obj ]
    @ !args
    @ get_thread_opt ()
    @ get_common_include ()
    @ get_common_ppx ()
    @ preprocess_opt ~ocaml:true !ppopt
    @ [impl_intf_opt impl_intf; file] )

let output_ocaml_interface file =
  create_process !compiler (
    [ "-i" ]
    @ !args
    @ get_common_include ()
    @ get_common_ppx ()
    @ preprocess_opt ~ocaml:true !ppopt
    @ [file] )

let process_ocaml ~impl_intf file =
  if do_compile () then
    compile_ocaml ~impl_intf file;
  if !mode = `Interface then
    output_ocaml_interface file

let compile_obj file =
  if do_compile () then
    ( create_process !compiler (!args @ [file]);
      args := !args @ [output_prefix file ^ ext_obj] )

(* Process eliom and eliomi files *)

let run_command s =
  let v = Sys.command s in
  if v != 0 then
    failwith (Printf.sprintf "Warning: command [%s] returned %d" s v)

(* WARNING: if you change this, also change inferred_type_prefix in
   ppx/ppx_eliom_utils.ml and ocamlbuild/ocamlbuild_eliom.ml *)
let inferred_type_prefix = "eliom_inferred_type_"

(* FIXME!

   run_sed is a temporary hack to parse weakly monomorphic types of
   the following forms:

   '_a
   _[< ... ]
   _[> ... ]

   It also removes type indices foo/2 (in case of ambiguity in
   module interfaces).

   These appear in type_mli files, but they are not accepted by
   the OCaml parser.  *)
let run_sed file =
  run_command ("sed -i -e 's$/[1-9][0-9]*$$g' " ^ file);
  run_command ("sed -i -e 's/_\\[\\([<>]\\)/[\\1/g' " ^ file);
  run_command
    (Printf.sprintf
       "sed -i -e \"s/'\\(_[a-z0-9_]*\\)/'%s\\1/g\" %s"
       inferred_type_prefix file);
  (* For some sed implementations, [-e] is interpreted as an argument
     to [-i], resulting in copy of the original file named [file ^
     "-e"]. If we find such a file, remove it. Slightly less messy
     than doing OS detection beforehand. *)
  let file_e = file ^ "-e" in
  if Sys.file_exists file_e then Sys.remove file_e

let compile_server_type_eliom file =
  let obj = output_prefix ~ty:true file ^ !server_types_file_ext
  and ppopts = !ppopt @ (if !pp_mode = `Ppx then [] else ["-impl"]) in
  if !do_dump then begin
    let camlp4, ppopt =
      get_pp_dump [] ("-printer" :: "o" :: ppopts @ [file]) in
    create_process camlp4 ppopt;
    exit 0
  end;
  let out = Unix.openfile obj [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC] 0o666 in
  let on_error _ =
    Unix.close out;
    Sys.remove obj
  in
  create_process ~out ~on_error !compiler (
    [ "-i" ]
    @ !args
    @ get_common_include ()
    @ get_common_ppx ()
    @ preprocess_opt ~kind:`Types ppopts
    @ ["-impl"; file] );
  Unix.close out;
  if !pp_mode = `Ppx then run_sed obj

let output_eliom_interface ~impl_intf file =
  if !do_dump then begin
    Printf.eprintf "Dump (-dump) not supported for interface inference (-i).";
    exit 1
  end;
  let indent ch =
    let spaces =
      match !pp_mode with
      | `Ppx -> ""
      | `Camlp4 -> "  "
    in
    try
      while true do
        let line = input_line ch in
        Printf.printf "%s%s\n" spaces line
      done
    with End_of_file -> ()
  in
  let args kind =
    let ppopts = get_ppopts ~impl_intf file in
    [ "-i" ]
    @ [ "-intf-suffix"; ".eliomi" ]
    @ !args
    @ get_common_include ~kind ()
    @ get_common_ppx ~kind ()
    @ preprocess_opt ~kind ppopts
    @ [ impl_intf_opt impl_intf; file ]
  and open_block str =
    match !pp_mode with
    | `Ppx ->
      Printf.printf "[%%%%%s.start]\n" str
    | `Camlp4 ->
      Printf.printf "{%s{\n" str
  and close_block () =
    match !pp_mode with
    | `Ppx ->
      ()
    | `Camlp4 ->
      print_endline "}}"
  in
  Printf.printf
    "(* WARNING generated in an ad-hoc fashion. Use with care! *)\n";
  open_block "server";
  create_filter !compiler (args `Server) indent;
  close_block ();
  open_block "client";
  create_filter !compiler (args `Client) indent;
  close_block ()

let compile_eliom ~impl_intf file =
  let obj =
    let ext = match !kind with
      | `Client -> ".cmo"
      | `Server | `ServerOpt -> obj_ext ()
    in
    output_prefix file ^ ext
  in
  let ppopts = get_ppopts ~impl_intf file in
  (* if !do_dump then begin *)
  (*   let camlp4, ppopt = get_pp_dump pkg ("-printer" :: "o" :: ppopts @ [file]) in *)
  (*   create_process camlp4 ppopt; *)
  (*   exit 0 *)
  (* end; *)
  create_process !compiler (
    [ "-c" ; "-o"  ; obj ]
    @ [ "-intf-suffix"; ".eliomi" ]
    @ get_thread_opt ()
    @ !args
    @ get_common_include ()
    @ get_common_ppx ()
    @ preprocess_opt ppopts
    @ [impl_intf_opt impl_intf; file] );
  args := !args @ [obj]

let process_eliom ~impl_intf file =
  match !mode with
  | `Infer when impl_intf = `Impl ->
    compile_server_type_eliom file
  | `Interface ->
    output_eliom_interface ~impl_intf file
  | _ ->
    compile_eliom ~impl_intf file

let build_server ?(name = "a.out") () =
  ignore name;
  fail "Linking eliom server is not yet supported"
(* TODO ? Build a staticaly linked ocsigenserver. *)

let build_client () =
  let name = chop_extension_if_any (get_product_name ()) in
  let exe = prefix_output_dir (Filename.basename name) in
  check_or_create_dir (Filename.dirname exe);
  let js = name ^ ".js" in
  create_process !compiler (
    ["-o"  ;  exe ]
    @ link_all ()
    @ get_common_include ()
    @ get_client_lib ()
    @ !args );
  create_process !js_of_ocaml (
    ["-o" ; js ]
    @ get_client_js ()
    @ !jsopt
    @ [exe] )

let process_option () =
  let i = ref 1
  and ppx = ref false in
  while !i < Array.length Sys.argv do
    match Sys.argv.(!i) with
    | "-help" | "--help" -> usage ()
    | "-no-autoload" -> autoload_predef := false; incr i
    | "-dont-force-linkall"->
      if !kind <> `Client then usage ();
      force_link_all := false; incr i
    | "-i" -> set_mode `Interface; incr i
    | "-c" -> set_mode `Compile; incr i
    | "-a" -> set_mode `Library; incr i
    | "-pack" -> set_mode `Pack; incr i
    | "-output-obj" -> set_mode `Obj; incr i
    | "-shared" -> set_mode `Shared; incr i
    | "-infer" -> set_mode `Infer; incr i
    | "-verbose" -> verbose := true; args := !args @ ["-verbose"] ;incr i
    | "-vmthread" -> Printf.eprintf "The -vmthread option isn't supported yet."; exit 1
    | "-o" ->
      if !i+1 >= Array.length Sys.argv then usage ();
      output_name := Some Sys.argv.(!i+1);
      i := !i+2
    | "-dump" ->
      do_dump := not !do_dump;
      i := !i+1
    | "-ppx" when not !ppx ->
      ppx := true;
      pp_mode := `Ppx;
      i := !i+1
    | "-dir" ->
      if !i+1 >= Array.length Sys.argv then usage ();
      build_dir := Sys.argv.(!i+1);
      i := !i+2
    | "-type-dir" ->
      if !i+1 >= Array.length Sys.argv then usage ();
      type_dir := Sys.argv.(!i+1);
      i := !i+2
    | "-server-types-ext" ->
      if !i+1 >= Array.length Sys.argv then usage ();
      server_types_file_ext := Sys.argv.(!i+1);
      i := !i+2
    | "-package" ->
      if !i+1 >= Array.length Sys.argv then usage ();
      package := !package @ split ',' Sys.argv.(!i+1);
      i := !i+2
    | "-predicates" ->
      if !i+1 >= Array.length Sys.argv then usage ();
      predicates := !predicates @ split ',' Sys.argv.(!i+1);
      i := !i+2
    | "-pp" ->
      if !i+1 >= Array.length Sys.argv then usage ();
      pp := Some Sys.argv.(!i+1);
      i := !i+2
    | "-jsopt" ->
      if !kind <> `Client then usage ();
      if !i+1 >= Array.length Sys.argv then usage ();
      jsopt := !jsopt @ [Sys.argv.(!i+1)];
      i := !i+2
    | "-ppopt" ->
      if !i+1 >= Array.length Sys.argv then usage ();
      ppopt := !ppopt @ [Sys.argv.(!i+1)];
      i := !i+2
    | "-intf" ->
      if !i+1 >= Array.length Sys.argv then usage ();
      process_eliom ~impl_intf:`Intf Sys.argv.(!i+1);
      i := !i+2
    | "-impl" ->
      if !i+1 >= Array.length Sys.argv then usage ();
      process_eliom ~impl_intf:`Impl Sys.argv.(!i+1);
      i := !i+2
    | arg when Filename.check_suffix arg ".mli" ->
      process_ocaml ~impl_intf:`Intf arg;
      incr i
    | arg when Filename.check_suffix arg ".ml" ->
      process_ocaml ~impl_intf:`Impl arg;
      incr i
    | arg when Filename.check_suffix arg ".eliom" ->
      process_eliom ~impl_intf:`Impl arg;
      incr i
    | arg when Filename.check_suffix arg ".eliomi" ->
      process_eliom ~impl_intf:`Intf arg;
      incr i
    | arg when Filename.check_suffix arg ".c" ->
      compile_obj arg; incr i
    | arg -> args := !args @ [arg]; incr i
  done;
  match !mode with
  | `Library -> build_library ()
  | `Pack -> build_pack ()
  | `Obj -> build_obj ()
  | `Shared -> build_shared ()
  | `Link when !kind = `Client -> build_client ()
  | `Link (* Server and ServerOpt *) -> build_server ?name:(!output_name) ()
  | `Compile | `Infer | `Interface -> ()

let main () =
  let cmd = Filename.basename Sys.argv.(0) in
  let cmd =
    try
      let idx = String.index cmd '.' in
      String.sub cmd 0 idx
    with Not_found -> cmd in
  let k =
    match cmd with
    | "eliomopt" ->
      compiler := ocamlopt;
      build_dir := default_server_dir;
      `ServerOpt
    | "eliomcp" ->
      compiler := ocamlcp;
      build_dir := default_server_dir;
      `Server
    | "js_of_eliom" ->
      compiler := ocamlc;
      build_dir := default_client_dir;
      `Client
    | "eliomc" ->
      compiler := ocamlc;
      build_dir := default_server_dir;
      `Server
    | s ->
      Format.eprintf "exec name not recognize %S: fallback to ocamlc@." s;
      compiler := ocamlc;
      build_dir := default_server_dir;
      `Server
  in
  kind := k;
  process_option ()

let _ = main ()
