driver/cmdOpt.ml

   1 open Base
   2 open OptParse
   3
   4 type output_type =
   5     Ho | Abc | Abcx | Swfx | Swf
   6
   7 type scm = {
   8   scm_cmd:  string;
   9   includes: string;
  10   link_std: bool
  11 }
  12
  13 type abc = {
  14   abc_cmd: string
  15 }
  16
  17 type abcx = {
  18   abcx_cmd: string;
  19   template: string;
  20   size: int * int;
  21   bg_color: Color.t;
  22 }
  23
  24 type swfx = {
  25   swfx_cmd:string;
  26 }
  27
  28 type general = {
  29   verbose:    bool;
  30   just_print: bool;
  31   keep_files: bool;
  32 }
  33
  34 type t = {
  35   inputs:  string list;
  36   output: string;
  37   general: general;
  38   scm:  scm;
  39   abc:  abc;
  40   abcx: abcx;
  41   swfx: swfx;
  42 }
  43
  44 let opt_parser =
  45   OptParser.make ~version:Config.version ~usage:"habc [options] <file>" ()
  46
  47 let str_option ~default ~metavar ?short_name ?long_name ~help () =
  48   let store =
  49     StdOpt.str_option ~default ~metavar () in
  50   let _ =
  51     OptParser.add opt_parser
  52       ?short_name
  53       ?long_name ~help store in
  54     store
  55
  56 let no_metavar x =  {
  57   x with Opt.option_metavars = []
  58 }
  59
  60 let str_callback ?short_name ?long_name ~help f =
  61   let opt = {
  62     Opt.option_metavars = [];
  63     option_defhelp = Some help;
  64     option_get = (fun _ -> raise Opt.No_value);
  65     option_set_value = (fun _ -> ());
  66     option_set = (fun _ _ ->
  67                     f ();
  68                     exit 0)
  69   } in
  70     OptParser.add opt_parser
  71       ?short_name
  72       ?long_name ~help opt
  73
  74
  75 let int_option ~default ~metavar ?short_name ?long_name ~help () =
  76   let store =
  77     StdOpt.int_option ~default ~metavar () in
  78   let _ =
  79     OptParser.add opt_parser
  80       ?short_name ?long_name ~help store in
  81     store
  82
  83 let bool_option ~default ?short_name ?long_name ~help () =
  84   let store =
  85     if not default then
  86       StdOpt.store_true ()
  87     else
  88       StdOpt.store_false () in
  89   let _ =
  90     OptParser.add opt_parser
  91       ?short_name ?long_name ~help store in
  92     store
  93
  94 let _ =
  95   str_callback ~long_name:"conf" ~help:"Print configure and exit"
  96     (fun _ ->
  97        Printf.printf "version:          %s\n" @@ Std.dump Config.version;
  98        Printf.printf "bin_dir:          %s\n" @@ Std.dump Config.bin_dir;
  99        Printf.printf "share_dir:        %s\n" @@ Std.dump Config.share_dir;
 100        Printf.printf "lib_dir:          %s\n" @@ Std.dump Config.lib_dir;
 101        Printf.printf "default_includes: %s\n" @@ Std.dump Config.default_includes;
 102        Printf.printf "default_template: %s\n" @@ Std.dump Config.default_template;
 103        Printf.printf "path_sep:         %s\n" @@ Std.dump Config.path_sep;
 104        Printf.printf "exe:              %s\n" @@ Std.dump Config.exe;
 105        exit 0)
 106
 107 let scm =
 108   let cmd =
 109     str_option
 110       ~default:(Config.bin_dir ^ "/habc-scm" ^ Config.exe)
 111       ~metavar:"<cmd>"
 112       ~long_name:"scm"
 113       ~help:"Use <cmd> to compile scm to abc" () in
 114   let includes =
 115     str_option
 116       ~default:""
 117       ~metavar:"<dir ..>"
 118       ~short_name:'I'
 119       ~help:"Add <dir ..> to the list of include directories" () in
 120   let no_std =
 121     bool_option
 122       ~default:true
 123       ~long_name:"no_std"
 124       ~help:"without std library" () in
 125   let default =
 126     Config.default_includes
 127     +> List.filter Sys.file_exists
 128     +> String.concat Config.path_sep in
 129     fun () -> {
 130       scm_cmd  = Opt.get cmd;
 131       includes = default ^ Config.path_sep ^ Opt.get includes;
 132       link_std = Opt.get no_std
 133     }
 134
 135 let abc =
 136   let cmd =
 137     str_option
 138       ~default:(Config.bin_dir ^ "/habc-xml" ^ Config.exe)
 139       ~metavar:"<cmd>"
 140       ~long_name:"abcx"
 141       ~help:"Use <cmd> to compile abc to abcx" () in
 142     fun () -> {
 143        abc_cmd = Opt.get cmd
 144      }
 145
 146 let abcx =
 147   let cmd =
 148     str_option
 149       ~default:"m4"
 150       ~metavar:"<cmd>"
 151       ~long_name:"swfx"
 152       ~help:"Use <cmd> to compile abcx to swfx" () in
 153   let width =
 154     int_option
 155       ~default:800
 156       ~metavar:"<width>"
 157       ~short_name:'W'
 158       ~long_name:"width"
 159       ~help:"Set stage width by pixel" () in
 160   let height =
 161     int_option
 162       ~default:600
 163       ~metavar:"<height>"
 164       ~short_name:'H'
 165       ~long_name:"height"
 166       ~help:"Set stage height by pixel" () in
 167   let bg_color =
 168     str_option
 169       ~default:"rgb(134,156,167)"
 170       ~metavar:"<color>"
 171       ~long_name:"bg"
 172       ~help:"stage background color" () in
 173   let template =
 174     str_option
 175       ~default:Config.default_template
 176       ~metavar:"<tempalte>"
 177       ~long_name:"template"
 178       ~help:"swfx template" () in
 179     fun () -> {
 180       abcx_cmd = Opt.get cmd;
 181       bg_color = Color.parse @@ Opt.get bg_color;
 182       size     = (20 * Opt.get width,20 * Opt.get height); (* convert pixel to twips *)
 183       template = Opt.get template;
 184     }
 185
 186 let swfx =
 187   let cmd =
 188     str_option
 189       ~default:"swfmill"
 190       ~metavar:"<cmd>"
 191       ~long_name:"swf"
 192       ~help:"Use <cmd> to compile swfx to swf" () in
 193     fun () -> {
 194        swfx_cmd = Opt.get cmd
 195     }
 196
 197 let general =
 198   let verbose =
 199     bool_option
 200       ~default:false
 201       ~short_name:'v'
 202       ~long_name:"verbose"
 203       ~help:"Print calls to external command" () in
 204   let just_print =
 205     bool_option
 206       ~default:false
 207       ~short_name:'n'
 208       ~long_name:"just-print"
 209       ~help:"Don't actually run any commands; just print them" () in
 210   let keep_files =
 211     bool_option
 212       ~default:false
 213       ~short_name:'k'
 214       ~long_name:"keep-files"
 215       ~help:"Keep temporary files" () in
 216     fun () -> {
 217       verbose    = Opt.get verbose;
 218       just_print = Opt.get just_print;
 219       keep_files = Opt.get keep_files
 220     }
 221
 222 let output_type =
 223   let ho =
 224     bool_option
 225       ~default:false ~short_name:'c' ~help:"compile only" () in
 226   let abc =
 227     bool_option
 228       ~default:false ~long_name:"abc-stage" ~help:"(no doc)" () in
 229   let abcx =
 230     bool_option
 231       ~default:false ~long_name:"abcx-stage" ~help:"(no doc)" () in
 232   let swfx =
 233     bool_option
 234       ~default:false ~long_name:"swfx-stage" ~help:"(no doc)" () in
 235     fun () ->
 236       if Opt.get ho then
 237         Ho
 238       else if Opt.get abc then
 239         Abc
 240       else if Opt.get abcx then
 241         Abcx
 242       else if Opt.get swfx then
 243         Swfx
 244       else
 245         Swf
 246
 247 let parse args =
 248   let output =
 249     str_option
 250       ~default:"a"
 251       ~metavar:"<file>"
 252       ~short_name:'o'
 253       ~help:"Set output filename" () in
 254   let inputs =
 255      OptParser.parse_argv opt_parser in
 256     match inputs with
 257         [] ->
 258           OptParser.usage opt_parser ();
 259           exit 0
 260       | x::_ ->
 261           let o =
 262             Opt.get output ^
 263               match output_type () with
 264                   Ho   -> ".ho"
 265                 | Abc  -> ".abc"
 266                 | Abcx -> ".abcx"
 267                 | Swfx -> ".swfx"
 268                 | Swf  -> ".swf" in
 269             {
 270               inputs      = inputs;
 271               output      = o;
 272               general     = general ();
 273               scm         = scm  ();
 274               abc         = abc  ();
 275               abcx        = abcx ();
 276               swfx        = swfx ();
 277             }