driver/cmdOpt.ml

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