driver/main.ml

   1 open Base
   2 open Rule
   3 open CmdOpt
   4
   5 let m4_opt xs =
   6   String.concat " " @@
   7     List.map (fun (x,y) ->
   8                 Printf.sprintf "-D%s=%s" x y)
   9     xs
  10
  11
  12 let rules = [
  13   one_to_one "scm" "ho"
  14     (fun {scm = {scm_cmd=scm_cmd; includes=includes; link_std=link_std}} input output ->
  15        [Printf.sprintf "%s -c -I %s -o %s %s %s"
  16           scm_cmd includes output
  17           (if link_std then "std.ho" else "")
  18           input ]);
  19   many_to_one ["scm"] "abc"
  20     (fun {scm = {scm_cmd=scm_cmd; includes=includes;link_std=link_std}} inputs output ->
  21        [Printf.sprintf "%s -I %s -o %s %s %s"
  22           scm_cmd includes output
  23           (if link_std then "std.ho" else "")
  24         @@ String.concat " " inputs ]);
  25   many_to_one ["scm";"ho"] "abc"
  26     (fun {scm = {scm_cmd=scm_cmd; includes=includes}} inputs output ->
  27        [Printf.sprintf "%s -I %s -o %s %s"
  28           scm_cmd includes output @@ String.concat " " inputs ]);
  29   many_to_one ["ho"] "abc"
  30     (fun {scm = {scm_cmd=scm_cmd; includes=includes}} inputs output ->
  31        [Printf.sprintf "%s -I %s -o %s %s"
  32           scm_cmd includes output @@ String.concat " " inputs ]);
  33   one_to_one "abc" "abcx"
  34     (fun {abc = {abc_cmd=abc_cmd}} input output ->
  35        [Printf.sprintf "%s %s > %s" abc_cmd input output]);
  36   one_to_one "abcx" "swfx"
  37     (fun { abcx = {
  38              abcx_cmd = m4;
  39              template = template;
  40              size     = (w,h);
  41              bg_color = {Color.red=r; green=g; blue=b};
  42            }} input output ->
  43        [Printf.sprintf "%s -I. %s %s > %s"
  44           m4
  45           (m4_opt [
  46              "__ABCX__"      ,input;
  47              "__MAIN_CLASS__","boot.Boot";
  48              "__WIDTH__"     ,string_of_int w;
  49              "__HEIGHT__"    ,string_of_int h;
  50              "__BG_RED__"    ,string_of_int r;
  51              "__BG_GREEN__"  ,string_of_int g;
  52              "__BG_BLUE__"   ,string_of_int b;
  53            ])
  54           template output]);
  55   one_to_one "swfx" "swf"
  56     (fun { swfx = { swfx_cmd=swfx_cmd } } input output ->
  57        [Printf.sprintf "%s xml2swf %s %s" swfx_cmd input output]);
  58 ]
  59
  60 let debug verbose str =
  61   if verbose then begin
  62     Printf.eprintf "--> %s\n" str;
  63     flush stderr
  64   end
  65
  66 let system {general={verbose=verbose}} cmd =
  67   let cmd' =
  68     Str.global_replace (Str.regexp "\\\\") "/" cmd in
  69     debug verbose cmd';
  70     Unix.system cmd'
  71
  72 let execute _ commands =
  73   open Unix in
  74   List.iter (fun s ->
  75                match system s with
  76                    Unix.WEXITED 0 ->
  77                      ()
  78                  | Unix.WEXITED n | WSIGNALED n | WSTOPPED n ->
  79                      prerr_endline "BUILD ERROR";
  80                      exit n)
  81     commands
  82
  83 let verbose {general={verbose=verbose}} s =
  84     if verbose then
  85       prerr_endline s
  86
  87 let main _ =
  88   let {inputs=inputs; output=output} as ctx =
  89     CmdOpt.parse () in
  90   let _ =
  91     verbose ctx @@ Printf.sprintf "Target: [%s] => %s\n" (String.concat "; " inputs) output in
  92   let commands =
  93     Rule.commands ctx rules inputs output in
  94     if ctx.general.just_print then
  95       List.iter print_endline commands
  96     else begin
  97       execute ctx commands;
  98       if not ctx.general.keep_files then
  99         List.iter Sys.remove @@ Rule.temp_files ctx rules inputs output
 100     end
 101
 102 let _ =
 103   if not !Sys.interactive then
 104     main ()