(* smlcus.sml *)

(* A customization of SML/NJ

   Requires SML/NJ Version 110.40 or greater *)

(* setParams : unit -> unit

   set various system parameters in sensible ways *)

fun setParams() =
      ((* control abbreviation of lists *)

       Control.Print.printLength := 1000;

       (* control abbreviation of strings *)

       Control.Print.stringDepth := 3000;

       (* control abbreviation of data structures *)

       Control.Print.printDepth := 25;

       (* control abbreviation of infinite-precision integers *)

       Control.Print.intinfDepth := 3000;

       (* don't print garbage collection messages *)

       SMLofNJ.Internals.GC.messages false;

       (* line buffer stdOut even if it's not a terminal *)

       TextIO.StreamIO.setBufferMode(TextIO.getOutstream TextIO.stdOut,
                                     IO.LINE_BUF));

(* getDir : unit   -> string
   setDir : string -> unit

   functions to get and set the current directory *)

val getDir = OS.FileSys.getDir;

val setDir = OS.FileSys.chDir;

(* getSearchPath : unit        -> string list
   setSearchPath : string list -> unit

   the search path is a list of absolute directories used by the
   function use (see below)

   getSearchPath() return the current value of the search path

   setSearchPath ds checks that each of the elements of ds is
   absolute, and then sets the current search path to ds *)

local
  val path : string list ref = ref nil

  fun output s = TextIO.output(TextIO.stdOut, s)

  fun error s = (output(s ^ "\n"); raise ErrorMsg.Error)

  fun checkDirsAbsolute nil       = ()
    | checkDirsAbsolute (d :: ds) =
        if OS.Path.isAbsolute d
        then checkDirsAbsolute ds
        else error("[setSearchPath failed: directory \"" ^ d ^
                   "\" is not absolute]")
in
  fun getSearchPath() = !path

  fun setSearchPath xs = (checkDirsAbsolute xs; path := xs)
end;

(* use : string -> unit

   redefine the function use so that
   (a) if f does not exist in the current directory, then use f looks for
       f in the directories that appear in the current search path,
       in the order in which they appear in this path
   (b) use "" reloads the most recently loaded file *)

local
  val file : string option ref = ref NONE

  fun output s = TextIO.output(TextIO.stdOut, s)

  fun error s = (output(s ^ "\n"); raise ErrorMsg.Error)

  fun existsFile f = OS.FileSys.access(f, nil)

  fun find f =
        let val path = getSearchPath()

            fun err() = error("[use failed: file \"" ^ f ^ "\" not found]")

            fun fnd nil       = err()
              | fnd (d :: ds) =
                  let val f' = OS.Path.concat(d, f)
                  in if existsFile f' then f' else fnd ds end
        in if existsFile f
             then f
           else if OS.Path.isAbsolute f
             then err()
           else fnd path
        end

  fun findUse f = use(find f)
in
  fun use "" =
        (case !file of
              NONE   => error "[use failed: no previous file]"
            | SOME f => findUse f)
    | use f  = (file := SOME f; findUse f)
end;

(* debugInt    : string * int    -> int
   debugBool   : string * bool   -> bool
   debugChar   : string * char   -> char
   debugString : string * string -> string

   debug       : ('a -> string) -> string * 'a -> 'a

   debugInt(msg, n) prints the message msg and the integer n on the
   standard output, and then pauses, after printing the message

     (press RETURN to continue or CTRL-c to interrupt)

   If the user responds to this message by typing RETURN, then
   debugInt will return the integer n.  The functions debugBool,
   debugChar and debugString work similarly.

   debug h yields the function of type string * 'a -> 'a that, when
   called with (msg, x), prints msg and the string h x on the standard
   output, and then pauses, after printing the message

     (press RETURN to continue or CTRL-c to interrupt)

   If the user responds to this message by typing RETURN, then the
   function will return x. *) 

local
  fun output (s : string) = TextIO.output(TextIO.stdOut, s)

  fun flush() = TextIO.flushOut TextIO.stdOut

  fun input() = TextIO.inputLine TextIO.stdIn
in
  fun debug h (msg, x) =
        (output msg; output ": "; flush(); output(h x); output "\n";
         output "(press RETURN to continue or CTRL-c to interrupt) "; flush();
         input(); output "\n";
         x)

  val debugInt    = debug Int.toString
  val debugBool   = debug Bool.toString
  val debugChar   = debug str
  val debugString = debug (fn x => x)
end;

(* export : unit -> unit

   function to create a customized heap image that calls the function
   setParams, loads the file named by the user's SMLRC environment
   variable, if SMLRC is set to an absolute pathname), and loads each
   of its command line arguments (if any) *)

local
  fun output s = TextIO.output(TextIO.stdOut, s)

  fun existsFile f = OS.FileSys.access(f, nil)

  fun intsToStr nil       = ""
    | intsToStr [x]       = Int.toString x
    | intsToStr (x :: xs) = Int.toString x ^ "." ^ intsToStr xs

  val versionStr = intsToStr(#version_id(Compiler.version))

  val toLower = String.map Char.toLower

  fun arch() = toLower(SMLofNJ.SysInfo.getHostArch())

  fun opSys() = toLower(SMLofNJ.SysInfo.getOSName())

  fun useRCFile() =
        case OS.Process.getEnv "SMLRC" of
             NONE    => ()
           | SOME rc =>
               if OS.Path.isAbsolute rc
               then use rc
               else output("value \"" ^ rc ^ "\"" ^
                           " of SMLRC variable is not absolute\n")
in
  fun export() =
        if SMLofNJ.exportML "smlcus"
        then (setParams();
              output "Standard ML of New Jersey, Version ";
              output versionStr; output " -- Customized\n";
              output "(See http://alleystoughton.us/sml/smlcus.html for ";
              output "information)\n";
              useRCFile();
              app use (SMLofNJ.getArgs()))
        else (output "Heap image written to file: \"smlcus.";
              output(arch()); output "-"; output(opSys()); output "\"\n";
              OS.Process.exit OS.Process.success)
end;