open List Fnlib Config Mixture Location Units Smlperv Compiler;
open Types; (* cvr *)

(* Compile a file *)

fun compileFile (context,s,mode) =
  let (* val s = normalizedFileName s *) in
    if Filename.check_suffix s ".sig" then
      let val filename = Filename.chop_suffix s ".sig" in
        compileSignature context 
          (normalizedUnitName (Filename.basename filename))
	  mode
          filename
      end
    else if Filename.check_suffix s ".sml" then
      let val filename = Filename.chop_suffix s ".sml" in
        compileUnitBody context
          (normalizedUnitName (Filename.basename filename))
	  mode
          filename
      end
    else
      raise (Fail "unknown file name extension")
  end
;

val initialMode = ref (!currentMode);

val initialContext = ref ([] : string list);

val initialFiles = ref ([] : (string list * string * Mode) list);

fun anonymous s =
  let val s = normalizedFileName s in
    if Filename.check_suffix s ".sig" then
      let val filename = Filename.chop_suffix s ".sig" 
      in
	  (initialFiles := 
	         (!initialFiles) @ 
		 [(!initialContext,s,!initialMode)];
	   initialContext := (!initialContext) @ [filename])
      end
    else if Filename.check_suffix s ".sml" then
      let val filename = Filename.chop_suffix s ".sml" 
      in
	  (initialFiles := 
	       (!initialFiles) @ 
	       [(remove filename (!initialContext), 
		 (* we remove filename to avoid a circular dependency on
		    the .sig file, if any *)
		 s,
		 !initialMode)];
	   initialContext := (!initialContext) @ [filename])
      end
    else if Filename.check_suffix s ".ui" then
      let val filename = Filename.chop_suffix s ".ui" 
      in
	   initialContext := (!initialContext) @ [filename]
      end (* cvr: this implies that the .ui file must be on the load path *)
    else
      raise (Fail "unknown file name extension")
  end
;

fun set_stdlib p =
  path_library := p;
;

fun set_value_polymorphism b _ =
  value_polymorphism := b;
;

fun add_include d =
  load_path := (!load_path) @ [d]
;

fun perv_set set' =
    let val set = Fnlib.stringToLower set'
    in 
	if set = "none" then 
	    (preloadedUnits := []; preopenedPreloadedUnits := [])
	else
	    (preloadedUnits          := lookup set preloadedUnitSets;
	     preopenedPreloadedUnits := lookup set preopenedPreloadedUnitSets)
	    handle Subscript =>
		raise Arg.Bad ("Unknown preloaded unit set " ^ set)
    end

fun set_msgstyle p =
  if exists (fn x => x = p) ["default", "msdev"] then
    msgStyle := p
  else
    raise Arg.Bad ("Unknown message style " ^ p)
;

fun show_version() =
(
  msgIBlock 0;
  msgString ("Moscow ML compiler version "^Config.version);
  msgEOL();
  msgString "Based in part on Caml Light and the ML Kit";
  msgEOL();
  msgEBlock();
  msgFlush();
  BasicIO.exit 0
);

fun show_inferred_types() =
  verbose := true
;

fun enable_quotation() =
  Lexer.quotation := true
;

fun topdec_mode () =
  initialMode := TOPDECmode;

fun str_mode () =
  initialMode := STRmode;

fun orthodox () = currentCompliance := Orthodox;
fun conservative () = currentCompliance := Conservative;
fun liberal () = currentCompliance := Liberal;


fun main () =
(
  perv_set "default";
  load_path := [];
  toplevel := true;
  (* Choose the default (value polymorphism or imperative types) here: *)
  value_polymorphism := true;
  (* Choose the default SML compliance checks here *)
  currentCompliance := Liberal;
  Arg.parse [("-stdlib",    Arg.String set_stdlib),
             ("-I",         Arg.String add_include),
             ("-include",   Arg.String add_include),
             ("-P",         Arg.String perv_set),
             ("-perv",      Arg.String perv_set),
             ("-v",         Arg.Unit show_version),
             ("-version",   Arg.Unit show_version),
             ("-i",         Arg.Unit show_inferred_types),
             ("-quotation", Arg.Unit enable_quotation),
             ("-q",         Arg.Unit enable_quotation),
             ("-imptypes",  Arg.Unit (set_value_polymorphism false)),
             ("-valuepoly", Arg.Unit (set_value_polymorphism true)),
             ("-msgstyle",  Arg.String set_msgstyle), 
             ("-m",         Arg.String set_msgstyle),
             ("-structure",  Arg.Unit str_mode),
             ("-toplevel",  Arg.Unit topdec_mode),
             ("-orthodox",  Arg.Unit orthodox),
             ("-conservative",  Arg.Unit conservative),
             ("-liberal",  Arg.Unit liberal)
             ]
    anonymous;
  if !path_library <> "" then
    load_path := !load_path @ [!path_library]
  else ();
  initPervasiveEnvironments();
  resetTypePrinter(); (* cvr *)
  Miscsys.catch_interrupt true;
  if null (!initialFiles) then show_version() else ();
  app compileFile (!initialFiles);
  msgFlush()
)
handle
    Toplevel =>
      (msgFlush();
       BasicIO.exit 2)
  | Interrupt =>
      (msgIBlock 0;
       errPrompt "Interrupted."; msgEOL();
       msgEBlock();
       msgFlush();
       BasicIO.exit 3)
  | Impossible msg =>
      (msgIBlock 0;
       errPrompt "Internal error: "; msgString msg; msgEOL();
       msgEBlock();
       msgFlush();
       BasicIO.exit 4)
  | SysErr(msg, _) =>
      (msgIBlock 0;
       errPrompt "I/O operation failed: ";
       msgString msg; msgEOL();
       msgEBlock();
       msgFlush();
       BasicIO.exit 2)
  | Fail msg =>
      (msgIBlock 0;
       errPrompt "Compilation failed: "; msgEOL();
       errPrompt msg; msgEOL();
       msgEBlock();
       msgFlush();
       BasicIO.exit 2)
;

val () = Printexc.f main ();