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 1193 - (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 :     priority : Controls.priority, (* control's priority *)
28 :     obscurity : int, (* registry's detail level; higher means *)
29 :     (* more obscure *)
30 :     reg : registry
31 :     }
32 :    
33 :     fun new {help} = Reg{
34 :     help = help,
35 :     ctls = CSet.new(),
36 :     qRegs = ATbl.mkTable (8, Fail "qualified registries"),
37 :     uRegs = ref[]
38 :     }
39 :    
40 :     (* register a control *)
41 :     fun register (Reg{ctls, ...}) {ctl, envName} =
42 :     CSet.insert (ctls, ctl, {envName=envName})
43 :    
44 :     (* register a set of controls *)
45 :     fun registerSet (Reg{ctls, ...}) {ctls=cs, mkEnvName} = let
46 :     fun insert {ctl, info} =
47 :     CSet.insert (ctls, ctl, {envName=mkEnvName(Controls.name ctl)})
48 :     in
49 :     CSet.app insert cs
50 :     end
51 :    
52 :     (* nest a registry inside another registry *)
53 :     fun nest (Reg{uRegs, qRegs, ...}) {prefix, pri, obscurity, reg} = let
54 :     val subReg = SubReg{
55 :     priority = pri,
56 :     obscurity = obscurity,
57 :     reg = reg
58 :     }
59 :     in
60 :     case prefix
61 :     of NONE => uRegs := subReg :: !uRegs
62 :     | SOME qual => ATbl.insert qRegs (Atom.atom qual, subReg)
63 :     (* end case *)
64 :     end
65 :    
66 :     fun control reg (path : string list) = let
67 :     fun find (_, []) = NONE
68 :     | find (Reg{ctls, uRegs, ...}, [name]) = (
69 :     case CSet.find(ctls, name)
70 :     of SOME{ctl, ...} => SOME ctl
71 :     | NONE => findInList (!uRegs, [name])
72 :     (* end case *))
73 :     | find (Reg{qRegs, uRegs,...}, prefix::r) = (
74 :     case ATbl.find qRegs prefix
75 :     of NONE => findInList(!uRegs, prefix::r)
76 :     | SOME(SubReg{reg, ...}) => (case find(reg, prefix::r)
77 :     of NONE => findInList(!uRegs, prefix::r)
78 :     | someCtl => someCtl
79 :     (* end case *))
80 :     (* end case *))
81 :     and findInList ([], _) = NONE
82 :     | findInList (SubReg{reg, ...}::r, path) = (case find (reg, path)
83 :     of NONE => findInList(r, path)
84 :     | someCtl => someCtl
85 :     (* end case *))
86 :     in
87 :     find (reg, List.map Atom.atom path)
88 :     end
89 :    
90 :     (* initialize the controls in the registry from the environment *)
91 :     fun init (Reg{ctls, qRegs, uRegs, ...}) = let
92 :     fun initCtl {ctl, info={envName=SOME var}} = (
93 :     case OS.Process.getEnv var
94 :     of SOME value => Controls.set(ctl, value)
95 :     | NONE => ()
96 :     (* end case *))
97 :     fun initSubreg (SubReg{reg, ...}) = init reg
98 :     in
99 :     CSet.app initCtl ctls;
100 :     ATbl.app initSubreg qRegs;
101 :     List.app initSubreg (!uRegs)
102 :     end
103 :    
104 :     datatype registry_tree = RTree of {
105 :     help : string,
106 :     ctls : string Controls.control list,
107 :     subregs : registry_tree list
108 :     }
109 :    
110 :     val sortSubregs =
111 :     ListMergeSort.sort
112 :     (fn (SubReg{priority=p1, ...}, SubReg{priority=p2, ...}) =>
113 :     Rep.priorityGT(p1, p2))
114 :    
115 :     fun controls (root, obs) = let
116 :     (* a function to build a list of subregistries, filtering by obscurity *)
117 :     val gather = (case obs
118 :     of NONE => op ::
119 :     | SOME obs => (fn (x as SubReg{obscurity, ...}, l) =>
120 :     if (obscurity < obs) then x::l else l)
121 :     (* end case *))
122 :     fun getTree (root as Reg{help, ctls, qRegs, uRegs, ...}) = let
123 :     val subregs =
124 :     List.foldl gather (ATbl.fold gather [] qRegs) (!uRegs)
125 :     val subregs = sortSubregs subregs
126 :     fun getReg (SubReg{reg, ...}) = getTree reg
127 :     in
128 :     RTree{
129 :     help = help,
130 :     ctls = List.map #ctl (case obs
131 :     of NONE => ControlSet.listControls ctls
132 :     | SOME obs => ControlSet.listControls' (ctls, obs)
133 :     (* end case *)),
134 :     subregs = List.map getReg subregs
135 :     }
136 :     end
137 :     in
138 :     getTree root
139 :     end
140 :    
141 :     end

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