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

SCM Repository

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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1192, Wed May 15 14:02:06 2002 UTC revision 1193, Thu May 16 18:44:04 2002 UTC
# Line 1  Line 1 
1  (* controls.sml  (* controls.sml
2   *   *
3   * COPYRIGHT (c) 2002 Lucent Technologies, Bell Laboratories   * COPYRIGHT (c) 2002 Bell Labs, Lucent Technologies
  *  
  * author: Matthias Blume  
4   *)   *)
 structure Controls :> CONTROLS = struct  
5    
6      structure M = RedBlackMapFn (type ord_key = string  structure Controls : CONTROLS =
7                                   val compare = String.compare)    struct
8    
9      exception NoSuchControl      open ControlReps
     exception FormatError of { t: string, s: string }  
10    
11      type 'a var = { get : unit -> 'a, set : 'a -> unit }      fun control {name, pri, obscurity, help, ctl} = Ctl{
12      type svar = string var              name = Atom.atom name,
13      type control = { rname: string, priority: int list, obscurity: int,              get = fn () => !ctl,
14                       name : string, descr : string, svar : svar }              set = fn v => ctl := v,
15                priority = pri,
16      type 'a tinfo = { tname : string,              obscurity = obscurity,
17                        fromString : string -> 'a option,              help = help
18                        toString : 'a -> string }            }
19    
20      datatype registry =      fun genControl {name, pri, obscurity, help, default} = control {
21          NOCONFIG              name = name, pri = pri, obscurity = obscurity, help = help,
22        | REGISTRY of { name : string, priority : int list, obscurity : int,              ctl = ref default
23                        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  
24    
25      fun new (r : 'a group) = #new r    (* this exception is raised to communicate that there is a syntax error
26      fun reg (r : 'a group) = #reg r     * in a string representation of a control value.
27      fun acc (r : 'a group) = #acc r     *)
28      fun sacc (r : 'a group) = #sacc r      exception ValueSyntax of {ctlName : string, value : string}
29    
30      fun control name =      fun stringControl {tyName, fromString, toString} = let
31          case M.find (!controls, name) of            fun mk (Ctl{name, get, set, priority, obscurity, help}) = Ctl{
32              NONE => raise NoSuchControl                    name = name,
33            | SOME c => c                    get = fn () => toString(get()),
34                      set = fn sval => (case fromString sval
35      val controls =                       of NONE => raise ValueSyntax{
36          fn oopt =>                              ctlName = Atom.toString name,
37             let val notobscure =                              value = sval
38                     case oopt of                            }
39                         NONE => (fn _ => true)                        | SOME v => set v
40                       | SOME x => (fn (c: control) => #obscurity c <= x)                      (* end case *)),
41                 val all = M.listItems (!controls)                    priority = priority,
42                 val unobscure = List.filter notobscure all                    obscurity = obscurity,
43                 fun clcmp (c: control, c': control) =                    help = help
44                     case List.collate Int.compare (#priority c, #priority c') of                  }
45                         EQUAL => String.compare (#name c, #name c')            in
46                       | unequal => unequal              mk
47                 fun gt (c, c') = clcmp (c, c') = GREATER            end
48    
49        fun name (Ctl{name, ...}) = Atom.toString name
50        fun get (Ctl{get, ...}) = get()
51        fun set (Ctl{set, ...}, v) = set v
52        fun info (Ctl{priority, obscurity, help, ...}) = {
53                priority = priority, obscurity = obscurity, help = help
54              }
55    
56        fun compare (Ctl{priority=p1, ...}, Ctl{priority=p2, ...}) = let
57              fun collate ([], []) = EQUAL
58                | collate ([], _) = LESS
59                | collate (_, []) = GREATER
60                | collate (x::xs, y::ys) =
61                    if (x = y) then collate(xs, ys)
62                    else if (x < y) then LESS
63                    else GREATER
64             in             in
65                 ListMergeSort.sort gt unobscure              collate (p1, p2)
66             end             end
67    
     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) [] }  
68  end  end

Legend:
Removed from v.1192  
changed lines
  Added in v.1193

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