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

Parent Directory | Revision Log

---

Revision 1145 - (view) (download)

1 :	blume	1145	(* controls.sml
2 :			*
3 :			* COPYRIGHT (c) 2002 Lucent Technologies, Bell Laboratories
4 :			*
5 :			* author: Matthias Blume
6 :			*)
7 :			structure Controls :> CONTROLS = struct
8 :
9 :			structure M = RedBlackMapFn (type ord_key = string
10 :			val compare = String.compare)
11 :
12 :			exception NoSuchControl
13 :			exception FormatError of { t: string, s: string }
14 :
15 :			type 'a var = { get : unit -> 'a, set : 'a -> unit }
16 :			type svar = string var
17 :			type control = { rname: string, priority: int list, obscurity: int,
18 :			name : string, descr : string, svar : svar }
19 :
20 :			type 'a tinfo = { tname : string,
21 :			fromString : string -> 'a option,
22 :			toString : 'a -> string }
23 :
24 :			datatype registry =
25 :			NOCONFIG
26 :			| REGISTRY of { name : string, priority : int list, obscurity : int,
27 :			prefix : string,
28 :			default_suffix : string option,
29 :			mk_ename : (string -> string) option }
30 :
31 :			type 'a group =
32 :			{ new : { stem : string, descr : string, fallback : 'a } -> 'a ref,
33 :			reg : { stem : string, descr : string, cell : 'a ref } -> unit,
34 :			acc : string -> 'a ref,
35 :			sacc : string -> svar }
36 :
37 :			val noconfig = NOCONFIG
38 :			val registry = REGISTRY
39 :
40 :			val configurers : (unit -> unit) list ref = ref []
41 :			val controls : control M.map ref = ref M.empty
42 :
43 :			fun ref2var r = { get = fn () => !r, set = fn x => r := x }
44 :
45 :			fun group NOCONFIG { tname, fromString, toString } =
46 :			let val m = ref M.empty
47 :			fun cvt s =
48 :			case fromString s of
49 :			SOME x => x
50 :			| NONE => raise FormatError { t = tname, s = s }
51 :			fun new { stem, descr, fallback } =
52 :			case M.find (!m, stem) of
53 :			SOME r => r
54 :			| NONE => let
55 :			val r = ref fallback
56 :			in
57 :			m := M.insert (!m, stem, r);
58 :			r
59 :			end
60 :			fun reg { stem, descr, cell } =
61 :			case M.find (!m, stem) of
62 :			SOME _ => raise Fail (concat ["Controls.register: ",
63 :			stem, " already registered\n"])
64 :			| NONE => m := M.insert (!m, stem, cell)
65 :			fun acc stem =
66 :			case M.find (!m, stem) of
67 :			SOME r => r
68 :			| NONE => raise NoSuchControl
69 :			fun sacc stem = let
70 :			val { get, set } = ref2var (acc stem)
71 :			in
72 :			{ get = toString o get, set = set o cvt }
73 :			end
74 :			in
75 :			{ new = new, reg = reg, acc = acc, sacc = sacc }
76 :			end
77 :			| group (REGISTRY r) { tname, fromString, toString } = let
78 :			val { name = rname, priority, obscurity,
79 :			prefix, default_suffix, mk_ename } = r
80 :			fun cvt s =
81 :			case fromString s of
82 :			SOME x => x
83 :			| NONE => raise FormatError { t = tname, s = s }
84 :			fun var2svar { get, set } =
85 :			{ get = toString o get, set = set o cvt }
86 :			fun upcase_underscore s =
87 :			String.map (fn #"-" => #"_" | c => Char.toUpper c) s
88 :			val mken = getOpt (mk_ename, upcase_underscore)
89 :			val m = ref M.empty
90 :			fun getUsing looker = Option.map cvt o looker
91 :			val getEnv = getUsing OS.Process.getEnv
92 :			fun mk (mkcell, stem, descr, fallback) =
93 :			case M.find (!m, stem) of
94 :			SOME r => r
95 :			| NONE => let
96 :			val name = prefix ^ stem
97 :			val default =
98 :			Option.map (fn s => mken (name ^ s)) default_suffix
99 :			val ename = mken name
100 :			val initial =
101 :			case Option.join (Option.map getEnv default) of
102 :			SOME v => v
103 :			| NONE => getOpt (getEnv ename, fallback)
104 :			val r = mkcell initial
105 :			val var as { get, set } = ref2var r
106 :			fun configure () = Option.app set (getEnv ename)
107 :			val control =
108 :			{ rname = rname,
109 :			priority = priority, obscurity = obscurity,
110 :			name = name, descr = descr, svar = var2svar var }
111 :			in
112 :			controls := M.insert (!controls, name, control);
113 :			configurers := configure :: !configurers;
114 :			m := M.insert (!m, stem, r);
115 :			r
116 :			end
117 :			fun new { stem, descr, fallback } = mk (ref, stem, descr, fallback)
118 :			fun reg { stem, descr, cell = cell as ref fallback } =
119 :			ignore (mk (fn v => (cell := v; cell), stem, descr, fallback))
120 :			fun acc stem =
121 :			case M.find (!m, stem) of
122 :			SOME r => r
123 :			| NONE => raise NoSuchControl
124 :			in
125 :			{ new = new, reg = reg, acc = acc, sacc = var2svar o ref2var o acc }
126 :			end
127 :
128 :			fun new (r : 'a group) = #new r
129 :			fun reg (r : 'a group) = #reg r
130 :			fun acc (r : 'a group) = #acc r
131 :			fun sacc (r : 'a group) = #sacc r
132 :
133 :			fun control name =
134 :			case M.find (!controls, name) of
135 :			NONE => raise NoSuchControl
136 :			| SOME c => c
137 :
138 :			val controls =
139 :			fn oopt =>
140 :			let val notobscure =
141 :			case oopt of
142 :			NONE => (fn _ => true)
143 :			| SOME x => (fn (c: control) => #obscurity c <= x)
144 :			val all = M.listItems (!controls)
145 :			val unobscure = List.filter notobscure all
146 :			fun clcmp (c: control, c': control) =
147 :			case List.collate Int.compare (#priority c, #priority c') of
148 :			EQUAL => String.compare (#name c, #name c')
149 :			| unequal => unequal
150 :			fun gt (c, c') = clcmp (c, c') = GREATER
151 :			in
152 :			ListMergeSort.sort gt unobscure
153 :			end
154 :
155 :			fun init () = app (fn cnf => cnf ()) (!configurers)
156 :
157 :			val bool = { tname = "bool",
158 :			fromString = Bool.fromString, toString = Bool.toString }
159 :			val int = { tname = "int",
160 :			fromString = Int.fromString, toString = Int.toString }
161 :			val real = { tname = "real",
162 :			fromString = Real.fromString, toString = Real.toString }
163 :			val string = { tname = "string",
164 :			fromString = SOME, toString = fn x => x }
165 :			val stringList =
166 :			{ tname = "string list",
167 :			fromString = SOME o String.tokens Char.isSpace,
168 :			toString = concat o foldr (fn (s, r) => " " :: s :: r) [] }
169 :			end

---

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