Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] View of /sml/trunk/src/smlnj-lib/Controls/controls.sml
ViewVC logotype

View of /sml/trunk/src/smlnj-lib/Controls/controls.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1145 - (download) (annotate)
Fri Mar 15 02:30:53 2002 UTC (18 years, 11 months ago) by blume
File size: 5371 byte(s)
moved Controls module into its own library;
changed Controls interface to make it saner;
made MLRISC independent of Controls;
minor changes to CM
(* controls.sml
 *
 * COPYRIGHT (c) 2002 Lucent Technologies, Bell Laboratories
 *
 * author: Matthias Blume
 *)
structure Controls :> CONTROLS = struct

    structure M = RedBlackMapFn (type ord_key = string
				 val compare = String.compare)

    exception NoSuchControl
    exception FormatError of { t: string, s: string }

    type 'a var = { get : unit -> 'a, set : 'a -> unit }
    type svar = string var
    type control = { rname: string, priority: int list, obscurity: int,
		     name : string, descr : string, svar : svar }

    type 'a tinfo = { tname : string,
		      fromString : string -> 'a option,
		      toString : 'a -> string }

    datatype registry =
	NOCONFIG
      | REGISTRY of { name : string, priority : int list, obscurity : int,
		      prefix : string,
		      default_suffix : string option,
		      mk_ename : (string -> string) option }

    type 'a group =
	 { new : { stem : string, descr : string, fallback : 'a } -> 'a ref,
	   reg : { stem : string, descr : string, cell : 'a ref } -> unit,
	   acc : string -> 'a ref,
	   sacc : string -> svar }
	 
    val noconfig = NOCONFIG
    val registry = REGISTRY

    val configurers : (unit -> unit) list ref = ref []
    val controls : control M.map ref = ref M.empty

    fun ref2var r = { get = fn () => !r, set = fn x => r := x }

    fun group NOCONFIG { tname, fromString, toString } =
	let val m = ref M.empty
	    fun cvt s =
		case fromString s of
		    SOME x => x
		  | NONE => raise FormatError { t = tname, s = s }
	    fun new { stem, descr, fallback } =
		case M.find (!m, stem) of
		    SOME r => r
		  | NONE => let
			val r = ref fallback
		    in
			m := M.insert (!m, stem, r);
			r
		    end
	    fun reg { stem, descr, cell } =
		case M.find (!m, stem) of
		    SOME _ => raise Fail (concat ["Controls.register: ",
						  stem, " already registered\n"])
		  | NONE => m := M.insert (!m, stem, cell)
	    fun acc stem =
		case M.find (!m, stem) of
		    SOME r => r
		  | NONE => raise NoSuchControl
	    fun sacc stem = let
		val { get, set } = ref2var (acc stem)
	    in
		{ get = toString o get, set = set o cvt }
	    end
	in
	    { new = new, reg = reg, acc = acc, sacc = sacc }
	end
      | group (REGISTRY r) { tname, fromString, toString } = let
	    val { name = rname, priority, obscurity,
		  prefix, default_suffix, mk_ename } = r
	    fun cvt s =
		case fromString s of
		    SOME x => x
		  | NONE => raise FormatError { t = tname, s = s }
	    fun var2svar { get, set } =
		{ get = toString o get, set = set o cvt }
	    fun upcase_underscore s =
		String.map (fn #"-" => #"_" | c => Char.toUpper c) s
	    val mken = getOpt (mk_ename, upcase_underscore)
	    val m = ref M.empty
	    fun getUsing looker = Option.map cvt o looker
	    val getEnv = getUsing OS.Process.getEnv
	    fun mk (mkcell, stem, descr, fallback) =
		case M.find (!m, stem) of
		    SOME r => r
		  | NONE => let
			val name = prefix ^ stem
			val default =
			    Option.map (fn s => mken (name ^ s)) default_suffix
			val ename = mken name
			val initial =
			    case Option.join (Option.map getEnv default) of
				SOME v => v
			      | NONE => getOpt (getEnv ename, fallback)
			val r = mkcell initial
			val var as { get, set } = ref2var r
			fun configure () = Option.app set (getEnv ename)
			val control =
			    { rname = rname,
			      priority = priority, obscurity = obscurity,
			      name = name, descr = descr, svar = var2svar var }
		    in
			controls := M.insert (!controls, name, control);
			configurers := configure :: !configurers;
			m := M.insert (!m, stem, r);
			r
		    end
	    fun new { stem, descr, fallback } = mk (ref, stem, descr, fallback)
	    fun reg { stem, descr, cell = cell as ref fallback } =
		ignore (mk (fn v => (cell := v; cell), stem, descr, fallback))
	    fun acc stem =
		case M.find (!m, stem) of
		    SOME r => r
		  | NONE => raise NoSuchControl
	in
	    { new = new, reg = reg, acc = acc, sacc = var2svar o ref2var o acc }
	end

    fun new (r : 'a group) = #new r
    fun reg (r : 'a group) = #reg r
    fun acc (r : 'a group) = #acc r
    fun sacc (r : 'a group) = #sacc r

    fun control name =
	case M.find (!controls, name) of
	    NONE => raise NoSuchControl
	  | SOME c => c

    val controls =
	fn oopt =>
	   let val notobscure =
		   case oopt of
		       NONE => (fn _ => true)
		     | SOME x => (fn (c: control) => #obscurity c <= x)
	       val all = M.listItems (!controls)
	       val unobscure = List.filter notobscure all
	       fun clcmp (c: control, c': control) =
		   case List.collate Int.compare (#priority c, #priority c') of
		       EQUAL => String.compare (#name c, #name c')
		     | unequal => unequal
	       fun gt (c, c') = clcmp (c, c') = GREATER
	   in
	       ListMergeSort.sort gt unobscure
	   end

    fun init () = app (fn cnf => cnf ()) (!configurers)

    val bool = { tname = "bool",
		 fromString = Bool.fromString, toString = Bool.toString }
    val int = { tname = "int",
		fromString = Int.fromString, toString = Int.toString }
    val real = { tname = "real",
		 fromString = Real.fromString, toString = Real.toString }
    val string = { tname = "string",
		   fromString = SOME, toString = fn x => x }
    val stringList =
	{ tname = "string list",
	  fromString = SOME o String.tokens Char.isSpace,
	  toString = concat o foldr (fn (s, r) => " " :: s :: r) [] }
end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0