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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log 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