delta/src/main.ml

let version = "0.1.0"

let usage =
  String.concat "\n"
    [
      "usage: deltac <command> [options]";
      "";
      "commands:";
      "  check FILE                        report errors in FILE";
      "  dump --typed|--anf|--delta FILE   print a compiler stage dump";
      "  emit FILE -o OUTPUT.ml            write generated OCaml source";
      "  build FILE -o EXECUTABLE          compile FILE to a native executable";
      "";
      "options:";
      "  -o FILE     output path for emit and build";
      "  --version   print the compiler version";
      "  --help      print this message";
      "";
    ]

type command =
  | Check of string
  | Dump of string * string
  | Emit of string * string
  | Build of string * string
  | Version
  | Help

let usage_error message =
  prerr_endline ("deltac: " ^ message);
  prerr_string usage;
  exit 2

let parse_options args =
  let rec loop files stage output rest =
    match rest with
    | [] -> (List.rev files, stage, output)
    | "-o" :: value :: rest -> loop files stage (Some value) rest
    | [ "-o" ] -> usage_error "option -o requires an argument"
    | flag :: rest when flag = "--typed" || flag = "--anf" || flag = "--delta" ->
        if stage <> None then usage_error "only one dump stage may be given"
        else loop files (Some (String.sub flag 2 (String.length flag - 2))) output rest
    | arg :: _ when String.length arg > 0 && arg.[0] = '-' -> usage_error ("unknown option " ^ arg)
    | file :: rest -> loop (file :: files) stage output rest
  in
  loop [] None None args

let single_file command files =
  match files with
  | [ file ] -> file
  | [] -> usage_error (command ^ " requires a file")
  | _ -> usage_error (command ^ " accepts exactly one file")

let parse_command () =
  let argv = Array.to_list Sys.argv in
  match argv with
  | _ :: "check" :: rest ->
      let files, _, _ = parse_options rest in
      Check (single_file "check" files)
  | _ :: "dump" :: rest ->
      let files, stage, _ = parse_options rest in
      let stage =
        match stage with
        | Some stage -> stage
        | None -> usage_error "dump requires --typed, --anf or --delta"
      in
      Dump (stage, single_file "dump" files)
  | _ :: "emit" :: rest ->
      let files, _, output = parse_options rest in
      let file = single_file "emit" files in
      let output = match output with Some output -> output | None -> usage_error "emit requires -o OUTPUT.ml" in
      Emit (file, output)
  | _ :: "build" :: rest ->
      let files, _, output = parse_options rest in
      let file = single_file "build" files in
      let output = match output with Some output -> output | None -> usage_error "build requires -o EXECUTABLE" in
      Build (file, output)
  | _ :: ("--version" | "-version") :: _ -> Version
  | _ :: ("--help" | "-help" | "help") :: _ -> Help
  | [ _ ] -> usage_error "a command is required"
  | _ :: unknown :: _ -> usage_error ("unknown command " ^ unknown)
  | [] -> usage_error "a command is required"

let load_source path =
  Diagnostic.set_file path;
  Native.read_file path

let parse_source path = Parse.program (load_source path)

let resolve_source path = Resolve.program (parse_source path)

let infer_source path = Infer.program (resolve_source path)

let frontend_unavailable () =
  Diagnostic.error Location.none "the delta pipeline beyond parsing is not implemented in this revision"

let check path =
  ignore (infer_source path)

let dump stage path =
  let program = infer_source path in
  match stage with
  | "typed" -> print_string (Typed.program_to_string program)
  | _ -> frontend_unavailable ()

let emit path output =
  ignore (infer_source path);
  ignore output;
  frontend_unavailable ()

let build path output =
  ignore (infer_source path);
  ignore output;
  frontend_unavailable ()

let source_of file = try Some (Native.read_file file) with _ -> None

let report diagnostic =
  prerr_endline (Diagnostic.render (source_of diagnostic.Diagnostic.file) diagnostic)

let execute () =
  match parse_command () with
  | Help ->
      print_string usage;
      0
  | Version ->
      print_endline version;
      0
  | Check path ->
      check path;
      0
  | Dump (stage, path) ->
      dump stage path;
      0
  | Emit (path, output) ->
      emit path output;
      0
  | Build (path, output) ->
      build path output;
      0

let () =
  let status =
    try execute () with
    | Diagnostic.Error diagnostic ->
        report diagnostic;
        1
    | Sys_error message ->
        prerr_endline ("deltac: " ^ message);
        1
    | Unix.Unix_error (error, fn, arg) ->
        prerr_endline (Printf.sprintf "deltac: %s failed on %s: %s" fn arg (Unix.error_message error));
        1
  in
  exit status