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/registry.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1629 - (view) (download)

1 : jhr 1193 (* registry.sml
2 :     *
3 :     * COPYRIGHT (c) 2002 Bell Labs, Lucent Technologies
4 :     *)
5 :    
6 :     structure ControlRegistry : CONTROL_REGISTRY =
7 :     struct
8 :    
9 :     structure Rep = ControlReps
10 :     structure CSet = ControlSet
11 :     structure ATbl = AtomTable
12 :    
13 :     type control_info = {
14 :     envName : string option
15 :     }
16 :    
17 :     type ctl_set = (string, control_info) Rep.control_set
18 :    
19 :     datatype registry = Reg of {
20 :     help : string, (* registry's description *)
21 :     ctls : ctl_set, (* control's in this registry *)
22 :     qRegs : subregistry ATbl.hash_table, (* qualified sub-registries *)
23 :     uRegs : subregistry list ref (* unqualified sub-registries *)
24 :     }
25 :    
26 :     and subregistry = SubReg of {
27 : jhr 1200 prefix : string option, (* the key for qualified registries *)
28 : jhr 1193 priority : Controls.priority, (* control's priority *)
29 :     obscurity : int, (* registry's detail level; higher means *)
30 :     (* more obscure *)
31 :     reg : registry
32 :     }
33 :    
34 :     fun new {help} = Reg{
35 :     help = help,
36 :     ctls = CSet.new(),
37 :     qRegs = ATbl.mkTable (8, Fail "qualified registries"),
38 :     uRegs = ref[]
39 :     }
40 :    
41 :     (* register a control *)
42 :     fun register (Reg{ctls, ...}) {ctl, envName} =
43 :     CSet.insert (ctls, ctl, {envName=envName})
44 :    
45 :     (* register a set of controls *)
46 :     fun registerSet (Reg{ctls, ...}) {ctls=cs, mkEnvName} = let
47 :     fun insert {ctl, info} =
48 :     CSet.insert (ctls, ctl, {envName=mkEnvName(Controls.name ctl)})
49 :     in
50 :     CSet.app insert cs
51 :     end
52 :    
53 :     (* nest a registry inside another registry *)
54 :     fun nest (Reg{uRegs, qRegs, ...}) {prefix, pri, obscurity, reg} = let
55 :     val subReg = SubReg{
56 : jhr 1200 prefix = prefix,
57 : jhr 1193 priority = pri,
58 :     obscurity = obscurity,
59 :     reg = reg
60 :     }
61 :     in
62 :     case prefix
63 :     of NONE => uRegs := subReg :: !uRegs
64 :     | SOME qual => ATbl.insert qRegs (Atom.atom qual, subReg)
65 :     (* end case *)
66 :     end
67 :    
68 :     fun control reg (path : string list) = let
69 :     fun find (_, []) = NONE
70 :     | find (Reg{ctls, uRegs, ...}, [name]) = (
71 :     case CSet.find(ctls, name)
72 :     of SOME{ctl, ...} => SOME ctl
73 :     | NONE => findInList (!uRegs, [name])
74 :     (* end case *))
75 :     | find (Reg{qRegs, uRegs,...}, prefix::r) = (
76 :     case ATbl.find qRegs prefix
77 :     of NONE => findInList(!uRegs, prefix::r)
78 : jhr 1200 | SOME(SubReg{reg, ...}) => (case find(reg, r)
79 : jhr 1193 of NONE => findInList(!uRegs, prefix::r)
80 :     | someCtl => someCtl
81 :     (* end case *))
82 :     (* end case *))
83 :     and findInList ([], _) = NONE
84 :     | findInList (SubReg{reg, ...}::r, path) = (case find (reg, path)
85 :     of NONE => findInList(r, path)
86 :     | someCtl => someCtl
87 :     (* end case *))
88 :     in
89 :     find (reg, List.map Atom.atom path)
90 :     end
91 :    
92 :     (* initialize the controls in the registry from the environment *)
93 :     fun init (Reg{ctls, qRegs, uRegs, ...}) = let
94 :     fun initCtl {ctl, info={envName=SOME var}} = (
95 :     case OS.Process.getEnv var
96 :     of SOME value => Controls.set(ctl, value)
97 :     | NONE => ()
98 :     (* end case *))
99 : jhr 1197 | initCtl _ = ()
100 : jhr 1193 fun initSubreg (SubReg{reg, ...}) = init reg
101 :     in
102 :     CSet.app initCtl ctls;
103 :     ATbl.app initSubreg qRegs;
104 :     List.app initSubreg (!uRegs)
105 :     end
106 :    
107 :     datatype registry_tree = RTree of {
108 : jhr 1199 path : string list,
109 : jhr 1193 help : string,
110 : mblume 1629 ctls : { ctl: string Controls.control, info: control_info } list,
111 : jhr 1193 subregs : registry_tree list
112 :     }
113 :    
114 :     val sortSubregs =
115 :     ListMergeSort.sort
116 :     (fn (SubReg{priority=p1, ...}, SubReg{priority=p2, ...}) =>
117 :     Rep.priorityGT(p1, p2))
118 :    
119 :     fun controls (root, obs) = let
120 :     (* a function to build a list of subregistries, filtering by obscurity *)
121 :     val gather = (case obs
122 :     of NONE => op ::
123 :     | SOME obs => (fn (x as SubReg{obscurity, ...}, l) =>
124 :     if (obscurity < obs) then x::l else l)
125 :     (* end case *))
126 : jhr 1199 fun getTree (path, root as Reg{help, ctls, qRegs, uRegs, ...}) = let
127 : jhr 1193 val subregs =
128 :     List.foldl gather (ATbl.fold gather [] qRegs) (!uRegs)
129 :     val subregs = sortSubregs subregs
130 : jhr 1200 fun getReg (SubReg{prefix=SOME prefix, reg, ...}) =
131 : jhr 1199 getTree(prefix::path, reg)
132 : jhr 1200 | getReg (SubReg{reg, ...}) = getTree (path, reg)
133 : jhr 1193 in
134 :     RTree{
135 : jhr 1199 path = List.rev path,
136 : jhr 1193 help = help,
137 : mblume 1629 ctls = case obs
138 :     of NONE => ControlSet.listControls ctls
139 :     | SOME obs =>
140 :     ControlSet.listControls' (ctls, obs)
141 :     (* end case *),
142 : jhr 1193 subregs = List.map getReg subregs
143 :     }
144 :     end
145 :     in
146 : jhr 1199 getTree ([], root)
147 : jhr 1193 end
148 :    
149 :     end

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