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 1633 - (download) (annotate)
Tue Sep 28 03:08:33 2004 UTC (16 years, 1 month ago) by mblume
File size: 2103 byte(s)
improved Controls interface; minor changes and bug fixes in CM
(* controls.sml
 *
 * COPYRIGHT (c) 2002 Bell Labs, Lucent Technologies
 *)

structure Controls : CONTROLS =
  struct

    open ControlReps

    fun control {name, pri, obscurity, help, ctl} = Ctl{
	    name = Atom.atom name,
	    get = fn () => !ctl,
	    set = fn v => ctl := v,
	    set' = fn v => fn () => ctl := v,
	    save'restore = fn () => let val v = !ctl in fn () => ctl := v end,
	    priority = pri,
	    obscurity = obscurity,
	    help = help
	  }

    fun genControl {name, pri, obscurity, help, default} = control {
	    name = name, pri = pri, obscurity = obscurity, help = help,
	    ctl = ref default
	  }

  (* this exception is raised to communicate that there is a syntax error
   * in a string representation of a control value.
   *)
    exception ValueSyntax of {tyName : string, ctlName : string, value : string}

    fun stringControl {tyName, fromString, toString} = let
	  fun fromString' name s =
	      case fromString s of
		  NONE => raise ValueSyntax { tyName = tyName,
					      ctlName = Atom.toString name,
					      value = s }
		| SOME v => v

	  fun mk (Ctl{name, get, set, set', save'restore,
		      priority, obscurity, help}) =
	      Ctl { name = name,
		    get = toString o get,
		    set = set o fromString' name,
		    set' = set' o fromString' name,
		    save'restore = save'restore,
		    priority = priority,
		    obscurity = obscurity,
		    help = help }
    in
	mk
    end

    fun name (Ctl{name, ...}) = Atom.toString name
    fun get (Ctl{get, ...}) = get()
    fun set (Ctl{set, ...}, v) = set v
    fun set' (Ctl{set', ...}, v) = set' v
    fun info (Ctl{priority, obscurity, help, ...}) = {
	    priority = priority, obscurity = obscurity, help = help
	  }

    fun save'restore (Ctl{save'restore,...}) = save'restore ()

    fun compare (Ctl{priority=p1, ...}, Ctl{priority=p2, ...}) = let
	  fun collate ([], []) = EQUAL
	    | collate ([], _) = LESS
	    | collate (_, []) = GREATER
	    | collate (x::xs, y::ys) =
		if (x = y) then collate(xs, ys)
		else if (x < y) then LESS
		else GREATER
	  in
	    collate (p1, p2)
	  end

  end

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