Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- open Cmdliner
- module type Config_t =
- sig
- type opt_level = O1 | O2 | O3
- val int_of_opt : opt_level -> int
- type config =
- { line_width : int
- ; colors : bool
- ; typecheck_only : bool
- ; opt_level : opt_level }
- val initialize : config -> bool
- exception Uninitialized
- val line_width : unit -> int
- val colors : unit -> bool
- val typecheck_only : unit -> bool
- val opt_level : unit -> opt_level
- end
- module Config : Config_t =
- struct
- type opt_level = O1 | O2 | O3
- let int_of_opt = function
- | O1 -> 1
- | O2 -> 2
- | O3 -> 3
- type config =
- { line_width : int
- ; colors : bool
- ; typecheck_only : bool
- ; opt_level : opt_level }
- exception Uninitialized
- let initialized = ref false
- let line_width_ref = ref None
- let colors_ref = ref None
- let typecheck_only_ref = ref None
- let opt_level_ref = ref None
- let initialize {line_width; colors; typecheck_only; opt_level} =
- match !initialized with
- | false ->
- initialized := true;
- line_width_ref := Some line_width;
- colors_ref := Some colors;
- typecheck_only_ref := Some typecheck_only;
- opt_level_ref := Some opt_level;
- true
- | true -> false
- let get r =
- match !r with
- | None -> raise Uninitialized
- | Some x -> x
- let line_width () = get line_width_ref
- let colors () = get colors_ref
- let typecheck_only () = get typecheck_only_ref
- let opt_level () = get opt_level_ref
- end
- let line_width =
- let doc = "Desired line width for pretty-printed terms, defaulting to 80" in
- Arg.(value & opt int 80 & info ["width"] ~docv:"INT" ~doc)
- let colors =
- let doc = "If true then pretty-printing will make use of colors" in
- Arg.(value & flag & info ["c"; "color"] ~docv:"BOOL" ~doc)
- let typecheck_only =
- let doc = "If true then skip the evaluation of the program" in
- Arg.(value & flag & info ["q"; "quick"] ~docv:"BOOL" ~doc)
- let opt_conv =
- let open Arg in
- let open Result in
- let open Config in
- conv
- ~docv:"OPT_LEVEL"
- ((fun s ->
- match conv_parser int s with
- | Ok i ->
- (match i with
- | 1 -> Ok O1
- | 2 -> Ok O2
- | 3 -> Ok O3
- | _ -> Error (`Msg ("Invalid optimization level " ^ string_of_int i)))
- | Error m -> Error m),
- fun f -> function
- | O1 -> conv_printer int f 1
- | O2 -> conv_printer int f 2
- | O3 -> conv_printer int f 3)
- let opt_level =
- let doc = "The level of optimization to be applied to the program" in
- Arg.(value & opt opt_conv O1 & info ["O"; "opt"] ~docv:"{1, 2, 3}" ~doc)
- let xc_info : Term.info =
- let doc = "A compiler for X" in
- let man = [`S Manpage.s_bugs] in
- Term.info "xc" ~version:"0.1" ~doc ~exits:Term.default_exits ~man
- let main () =
- Printf.printf "Line width: %d\n" (Config.line_width ());
- Printf.printf "Colors: %b\n" (Config.colors ());
- Printf.printf "Quick: %b\n" (Config.typecheck_only ());
- Printf.printf "Optimization: %d\n" Config.(opt_level () |> int_of_opt)
- let () =
- let go line_width colors typecheck_only opt_level =
- assert (Config.initialize {line_width; colors; typecheck_only; opt_level});
- main () in
- let t = Term.(const go $ line_width $ colors $ typecheck_only $ opt_level) in
- Term.exit @@ Term.(eval (t, xc_info))
Add Comment
Please, Sign In to add comment