configuration.ml

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))