ocamltarzan.ml

open Common

(*****************************************************************************)
(* Purpose *)
(*****************************************************************************)

(* cf readme.txt  *)

(*****************************************************************************)
(* Flags *)
(*****************************************************************************)

let config_version = "0.2"

let verbose = ref false

let choice = ref "sof"

(* action mode *)
let action = ref ""

(*****************************************************************************)
(* Helpers *)
(*****************************************************************************)

let pa_cmo_of_choice s = 
  ("pa_" ^ s  ^".cmo")

(*****************************************************************************)
(* Main action *)
(*****************************************************************************)

(*
ocamlc -I ../commons unix.cma str.cma ../commons/commons.cma ocamltarzan.ml 

  add: TYPE_CONV_PATH "Ast_c"
  uncomment the with xxx
  process with pa_xxx
  filter the generated file to get only the generated stuff
*)


let path_pa = 
  "pa/"

let tmpfile = "/tmp/xxx.ml"
let tmpfile2 = "/tmp/yyy.ml"

(* must add pr_o.cmo when not run interactively from the shell ... *)
let cmd file = 
  spf "camlp4o -o %s -I %s pa_type_conv.cmo %s  pr_o.cmo %s " 
    tmpfile2 path_pa 
    (match !choice with
    (* original code *)
    | "sexp" -> "pa_sexp_conv.cmo"
    | "bin" -> "pa_bin_prot.cmo"

    | "rpc" -> "pa_rpc.cmo"

    (* pad modifications of existing pa *)
    | "sof" -> "pa_sof.cmo" (* aka show *)
    | "ofs" -> "pa_ofs.cmo" (* aka read *)

    (* used to be vi, but then works less with the regexp
     * using !choice below in grouped' *)
     
    | "v" -> "pa_visitor.cmo"
    | "map" -> "pa_map.cmo"
    | "iter_env" -> "pa_iter_env.cmo"

    | "tof" -> "pa_tof.cmo" (* was type.cmo pa_type.cmo *)

    | "vof" -> "pa_vof.cmo" (* was pa_value.cmo *)
    | "ofv" -> "pa_ofv.cmo" (* was pa_value.cmo *)

    | "m" -> "pa_matcher.cmo"

    | s when Sys.file_exists ("pa/" ^ pa_cmo_of_choice s)  ->
        pa_cmo_of_choice s
    | s -> failwith ("no valid choice; can't find: pa/" ^ pa_cmo_of_choice s)
    )
    file 


let main_action file = 
  if !verbose then pr2 ("processing: " ^ file);
  let xs = Common.cat file in 
  let xs = "TYPE_CONV_PATH \"Xxx\"\n"::xs in
  let xs = xs |> List.map (fun s -> 
    if s =~ "[ \t]*(\\* with \\(.*\\)\\*).*"
    then 
      let _str = matched1 s in
      (* typeconv works by looking for a certain keyword after a with *)
      let str = !choice in 
      "   with " ^ str
    else s
  ) in
  Common2.uncat xs tmpfile;
  let fullcmd = cmd tmpfile in
  if !verbose then pr2 fullcmd;
  Common.command2 fullcmd;

  let ys = Common.cat tmpfile2 in

  (* let xs = xs |> Common.split_list_regexp "^[^ ]" in  *)

  let (_unclassif, grouped) = Common2.group_by_pre (fun x -> 
    x =~ "^[^ ]"
  ) ys 
  in
  
  let grouped' = grouped |> List.filter (fun (x,xs) -> 
    x =~ ".*_of_sexp.*" || x =~ ".* sexp_of.*"
    (* bugfix: when have some mutual recursive, the first entry
     * has just a let rec *)


    (* || x =~ "let rec" *)
    || x =~ "and" 

    || x =~ ".*bin_read_.*" || x =~ ".*bin_size_.*" 
    || x =~ ".*bin_write_.*" || x =~ ".*bin_sw.*"

    || x =~ (".*map_.*")
                                         
    || x =~ (".*" ^ !choice ^ "_.*")
    || x =~ (".*_" ^ !choice ^ ".*")
  )
  in
  let ys = grouped' |> List.map (fun (x,xs) -> x::xs) |> List.flatten in

  let modulename = 
    String.capitalize (Common2.fileprefix (Filename.basename file))
  in
  let ys = 
    (spf "(* generated by ocamltarzan with: %s *)\n" fullcmd)::
    ("open " ^ modulename ^ "\n")::
    ys in
  ys |> List.iter pr2;

  ()

(*****************************************************************************)
(* The options *)
(*****************************************************************************)

let all_actions () = 
 []

let options () = 
  [
    "-choice", Arg.Set_string choice, 
    (spf " <str> (default = %s)" !choice);

    "-verbose", Arg.Set verbose, 
    " ";
  ] @
  Common.options_of_actions action (all_actions()) @
  Common2.cmdline_flags_devel () @
  Common2.cmdline_flags_verbose () @
  Common2.cmdline_flags_other () @
  [
  "-version",   Arg.Unit (fun () -> 
    pr2 (spf "ocamltarzan version: %s" config_version);
    exit 0;
  ), 
    "  guess what";

  (* this can not be factorized in Common *)
  "-date",   Arg.Unit (fun () -> 
    pr2 "version: $Date: 2010/01/21 00:44:57 $";
    raise (Common.UnixExit 0)
    ), 
  "   guess what";
  ] @
  []

(*****************************************************************************)
(* Main entry point *)
(*****************************************************************************)

let main () = 
  let usage_msg = 
    "Usage: " ^ Filename.basename Sys.argv.(0) ^ 
      " [options] <file or dir> " ^ "\n" ^ "Options are:"
  in
  (* does side effect on many global flags *)
  let args = Common.parse_options (options()) usage_msg Sys.argv in

  (* must be done after Arg.parse, because Common.profile is set by it *)
  Common.profile_code "Main total" (fun () -> 

    (match args with
   
    (* --------------------------------------------------------- *)
    (* actions, useful to debug subpart *)
    (* --------------------------------------------------------- *)
    | xs when List.mem !action (Common.action_list (all_actions())) -> 
        Common.do_action !action xs (all_actions())

    | _ when not (Common.null_string !action) -> 
        failwith ("unrecognized action or wrong params: " ^ !action)

    (* --------------------------------------------------------- *)
    (* main entry *)
    (* --------------------------------------------------------- *)
    | [x] -> 
        main_action x

    (* --------------------------------------------------------- *)
    (* empty entry *)
    (* --------------------------------------------------------- *)
    | x::y::xs -> 
        failwith "too many arguments"

    | [] -> 
        Common.usage usage_msg (options()); 
        failwith "too few arguments"
    )
  )



(*****************************************************************************)
let _ =
  Common.main_boilerplate (fun () -> 
      main ();
  )