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 /eXene/trunk/styles/styles.sml
ViewVC logotype

Annotation of /eXene/trunk/styles/styles.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2098 - (view) (download)

1 : monnier 2 (* styles.sml
2 :     *
3 :     * COPYRIGHT (c) 1994 AT&T Bell Laboratories.
4 :     *)
5 :    
6 :     (*abstraction Styles : STYLES =*)
7 :     structure Styles =
8 :     struct
9 :    
10 :     structure Q = Quark
11 :     structure AV = AttrValue
12 :     structure PRS = ParseResourceSpecs
13 :    
14 :     exception BadStyleName
15 :    
16 :     exception BadStyleSpec of string * int
17 :    
18 :     (* a style_name is a key for searching a style database *)
19 :     type style_name = {
20 :     name : Quark.quark list,
21 :     hash : int
22 :     }
23 :    
24 :     fun extHash (hash, comp) =
25 :     Bits.andb(Bits.lshift(hash, 1), 0xffffff) + Q.hash comp
26 :    
27 :     fun styleName sl = let
28 :     fun chkName ([], comps, hash) = {name = rev comps, hash = hash}
29 :     | chkName (s::r, comps, hash) = let
30 :     val comp = PRS.checkCompName s
31 :     in
32 :     chkName (r, comp::comps, extHash(hash, comp))
33 :     end
34 :     in
35 :     (chkName (sl, [], 0)) handle _ => raise BadStyleName
36 :     end
37 :    
38 :     (* compare two style names for equality *)
39 :     fun sameStyleName ({name=n1, hash=h1} : style_name, {name=n2, hash=h2}) = let
40 :     fun cmp ([], []) = true
41 :     | cmp (q1::r1, q2::r2) = Quark.same(q1, q2) andalso cmp(r1, r2)
42 :     | cmp _ = false
43 :     in
44 :     (h1 = h2) andalso cmp(n1, n2)
45 :     end
46 :    
47 :     (* a style_view is a search key for finding attributes in a style.
48 :     * It consists of a name and an ordered list of aliases.
49 :     *)
50 :     datatype style_view = SV of {
51 :     name : style_name,
52 :     aliases : style_name list
53 :     }
54 :    
55 :    
56 :     (* make a style_view from a name and list of aliases; the order of the
57 :     * list defines the search order.
58 :     *)
59 :     val mkView = SV
60 :    
61 :     (* return the name part of the view *)
62 :     fun nameOfView (SV{name, ...}) = name
63 :    
64 :     (* return the list of aliases that defines the view. *)
65 :     fun aliasesOfView (SV{aliases, ...}) = aliases
66 :    
67 :     (* extend each of the names in the view by the component *)
68 :     fun extendView (SV{name, aliases}, comp) = let
69 :     val compQ = PRS.checkCompName comp
70 :     fun ext {name, hash} = {
71 :     name = name @ [compQ],
72 :     hash = extHash(hash, compQ)
73 :     }
74 :     in
75 :     SV{name = ext name, aliases = map ext aliases}
76 :     end
77 :    
78 :     (* concatenate two views; the first view has priority over the second. *)
79 :     fun concatViews (SV{name=n1, aliases=a1}, SV{name=n2, aliases=a2}) =
80 :     SV{name = n1, aliases = a1 @ (n2::a2)}
81 :    
82 :     (* add a alias to the back or front of a view *)
83 :     fun appendAlias (SV{name, aliases}, alias) =
84 :     SV{name=name, aliases = aliases@[alias]}
85 :     fun prependAlias (SV{name, aliases}, alias) =
86 :     SV{name=name, aliases = alias::aliases}
87 :    
88 :    
89 :     (*** attributes in the database ***)
90 :     datatype attr = ATTR of {
91 :     rawValue : string,
92 :     cache : AV.attr_value ref
93 :     }
94 :    
95 :     fun mkAttr rawValue = ATTR{
96 :     rawValue = rawValue,
97 :     cache = ref AV.AV_NoValue
98 :     }
99 :    
100 :     (* extract the value from an attribute object, performing
101 :     * the conversion, if necessary, and caching the result.
102 :     *)
103 :     fun getAttrValue scr = let
104 :     val cvtValue = AV.cvtAttrValue scr
105 :     fun get (ATTR{rawValue, cache}, attrTy) = let
106 :     val cacheVal = !cache
107 :     in
108 :     case (cacheVal, attrTy)
109 :     of (AV.AV_Str _, AV.AT_Str) => cacheVal
110 :     | (AV.AV_Int _, AV.AT_Int) => cacheVal
111 :     | (AV.AV_Real _, AV.AT_Real) => cacheVal
112 :     | (AV.AV_Bool _, AV.AT_Bool) => cacheVal
113 :     | (AV.AV_Font _, AV.AT_Font) => cacheVal
114 :     | (AV.AV_Color _, AV.AT_Color) => cacheVal
115 :     | _ => (let val cvtVal = cvtValue (rawValue, attrTy)
116 :     in
117 :     cache := cvtVal; cvtVal
118 :     end
119 :     handle _ => AV.AV_NoValue)
120 :     (* end case *)
121 :     end
122 :     in
123 :     get
124 :     end
125 :    
126 :    
127 :     (*** The resource database tables ***)
128 :    
129 :     structure QuarkTbl = HashTable (struct
130 :     type hash_key = Q.quark
131 :     val hashVal = Q.hash
132 :     val sameKey = Q.same
133 :     end)
134 :    
135 :     (* maps on quarks *)
136 :     type 'a qmap = 'a QuarkTbl.hash_table
137 :    
138 :     fun findQuark (tbl, q) = QuarkTbl.peek tbl q
139 :     fun insQuark (tbl, q, v) = QuarkTbl.insert tbl (q, v)
140 :     fun empty tbl = (QuarkTbl.numItems tbl = 0)
141 :    
142 :    
143 :     type binding = PRS.binding
144 :    
145 :     datatype db_tbl = DBTBL of {
146 :     tight : db_tbl qmap,
147 :     loose : db_tbl qmap, (* entries of the form "*path.attr:" *)
148 :     attrs : (attr * binding) qmap (* entries of the form "[*]attr:" *)
149 :     }
150 :    
151 :     fun newDBTbl () = DBTBL{
152 :     tight = QuarkTbl.mkTable (8, Fail "db_tbl.tight"),
153 :     loose = QuarkTbl.mkTable (8, Fail "db_tbl.loose"),
154 :     attrs = QuarkTbl.mkTable (8, Fail "db_tbl.attrs")
155 :     }
156 :    
157 :     (* given a database and a component name path, find the list of
158 :     * attribute binding tables keyed by the path.
159 :     *)
160 :     fun findAttrTbls (DBTBL{tight, loose, attrs}, path) = let
161 :     fun findLooseAttr attrTbl attrQ = (case findQuark(attrTbl, attrQ)
162 :     of (SOME(attr, LOOSE)) => (SOME attr)
163 :     | _ => NONE
164 :     (* end case *))
165 :     fun findAttr attrTbl attrQ = (case findQuark(attrTbl, attrQ)
166 :     of (SOME(attr, LOOSE)) => (SOME attr)
167 :     | _ => NONE
168 :     (* end case *))
169 :     fun find (tight, loose, attrs, [], tbls) =
170 :     if (empty attrs) then tbls else (findAttr attrs)::tbls
171 :     | find (tight, loose, attrs, comp::r, tbls) = let
172 :     val tbls' = (case (findQuark(tight, comp))
173 :     of NONE => tbls
174 :     | (SOME(DBTBL{tight, loose, attrs})) =>
175 :     find (tight, loose, attrs, r, tbls)
176 :     (* end case *))
177 :     fun findLoose ([], tbls) = tbls
178 :     | findLoose (comp::r, tbls) = (case findQuark(loose, comp)
179 :     of NONE => findLoose (r, tbls)
180 :     | (SOME(DBTBL{tight, loose, attrs})) =>
181 :     findLoose (r, find (tight, loose, attrs, r, tbls))
182 :     (* end case *))
183 :     val tbls'' = if (empty loose) then tbls' else findLoose(r, tbls')
184 :     in
185 :     if (empty attrs) then tbls'' else (findLooseAttr attrs)::tbls''
186 :     end
187 :     val tbls = rev (find (tight, loose, attrs, path, []))
188 :     (** NOTE: we may want to just return a list of tables, instead of a composite
189 :     ** function, since views consist of a name plus aliases.
190 :     **)
191 :     fun search attr = let
192 :     fun search' [] = NONE
193 :     | search' (tbl::r) = (case (tbl attr)
194 :     of NONE => search' r
195 :     | someVal => someVal
196 :     (* end case *))
197 :     in
198 :     search' tbls
199 :     end
200 :     in
201 :     search
202 :     end (* findAttrTbls *)
203 :    
204 :     (* insert an attribute binding into the database *)
205 :     fun insertAttr (db, isLoose, path, name, attr) = let
206 :     fun find (tbl, comp) = (case findQuark(tbl, comp)
207 :     of (SOME db) => db
208 :     | NONE => let val db = newDBTbl()
209 :     in
210 :     insQuark (tbl, comp, db); db
211 :     end
212 :     (* end case *))
213 :     fun insert (DBTBL{tight, loose, attrs}, bind, path) = (
214 :     case (bind, path)
215 :     of (PRS.TIGHT, (PRS.Name comp, bind)::r) =>
216 :     insert (find (tight, comp), bind, r)
217 :     | (PRS.LOOSE, (PRS.Name comp, bind)::r) =>
218 :     insert (find (loose, comp), bind, r)
219 :     | (_, (PRS.Wild, _)::_) =>
220 :     raise Fail "wildcard components not implemented"
221 :     | (_, []) => insQuark (attrs, name, (attr, bind))
222 :     (* end case *))
223 :     in
224 :     insert (db, if isLoose then PRS.LOOSE else PRS.TIGHT, path)
225 :     end (* insertRsrcSpec *)
226 :    
227 :    
228 :     (*** The database with view cache ***)
229 :     datatype db = DB of {
230 :     db : db_tbl,
231 :     cache : (style_name * (PRS.attr_name -> attr option)) Weak.weak list ref
232 :     }
233 :    
234 :     fun mkDB () = DB{
235 :     db = newDBTbl(),
236 :     cache = ref []
237 :     }
238 :    
239 :     (* this is a temporary function for building resource data bases by hand *)
240 :     fun insertRsrcSpec (DB{db, cache}, {loose, path, attr, value}) = (
241 :     insertAttr (db, loose, path, attr, mkAttr value);
242 :     cache := [])
243 :    
244 :     (* given a database and a style view (name + aliases) construct the lookup
245 :     * function for the view.
246 :     *)
247 :     fun constructView (DB{db, cache}, SV{name, aliases}) = let
248 :     (* probe the cache for a binding for name; remove any stale
249 :     * cache entries that are encountered.
250 :     *)
251 :     fun probeCache name = let
252 :     fun probe ([], l) = (rev l, NONE)
253 :     | probe (w::r, l) = (case (Weak.strong w)
254 :     of NONE => probe (r, l)
255 :     | (SOME(name', binding)) =>
256 :     if (sameStyleName(name, name'))
257 :     then (w :: ((rev l) @ r), SOME binding)
258 :     else probe (r, w::l)
259 :     (* end case *))
260 :     val (cache', result) = probe (!cache, [])
261 :     in
262 :     cache := cache'; result
263 :     end
264 :     (* add a binding to the cache *)
265 :     fun addToCache item = cache := (Weak.weak item) :: !cache
266 :     (* find the attribute tables for a name *)
267 :     fun findTbls (name : style_name) = (case (probeCache name)
268 :     of NONE => let
269 :     val tbls = findAttrTbls (db, #name name)
270 :     in
271 :     addToCache (name, tbls);
272 :     tbls
273 :     end
274 :     | (SOME tbls) => tbls
275 :     (* end case *))
276 :     (* search for an attribute in this view *)
277 :     fun findAttr attrName = let
278 :     fun search [] = NONE
279 :     | search (name::r) = (case (findTbls name attrName)
280 :     of NONE => search r
281 :     | attr => attr
282 :     (* end case *))
283 :     in
284 :     search (name::aliases)
285 :     end
286 :     in
287 :     findAttr
288 :     end
289 :    
290 :    
291 :     (*** Styles ***)
292 :    
293 :     datatype req_msg
294 :     = FindAttrs of {
295 :     key : style_view,
296 :     targets : (PRS.attr_name * AV.attr_type) list,
297 :     reply : (PRS.attr_name * AV.attr_value) list CML.cond_var
298 :     }
299 :    
300 :     datatype style = STY of {
301 :     scr : EXeneBase.screen,
302 :     reqCh : req_msg CML.chan
303 :     }
304 :    
305 :     (* spawn a style server for the given screen and database *)
306 :     fun mkStyleServer (scr, db) = let
307 :     val ch = CML.channel()
308 :     val getAttrValue = getAttrValue scr
309 :     fun findAttr key = let
310 :     val find = constructView (db, key)
311 :     in
312 :     fn (attrName, attrTy) => (case (find attrName)
313 :     of NONE => (attrName, AV.AV_NoValue)
314 :     | (SOME attr) => (attrName, getAttrValue (attr, attrTy))
315 :     (* end case *))
316 :     end
317 :     fun server () = (
318 :     case (CML.accept ch)
319 :     of (FindAttrs{key, targets, reply}) => let
320 :     val results = map (findAttr key) targets
321 :     in
322 :     CML.writeVar (reply, results)
323 :     end
324 :     (* end case *);
325 :     server ())
326 :     in
327 :     CML.spawn server;
328 :     STY{
329 :     reqCh = ch, scr = scr
330 :     }
331 :     end (* mkStyleServer *)
332 :    
333 :     (* create an empty style *)
334 :     fun emptyStyle scr = mkStyleServer (scr, mkDB ())
335 :    
336 :     (* create a style, initializing it from a list of strings. This
337 :     * is for testing purposes.
338 :     *)
339 :     fun styleFromStrings (scr, sl) = let
340 :     val db = mkDB()
341 :     fun parse str = let
342 :     val (PRS.RsrcSpec{loose, path, attr, value, ...}) =
343 :     PRS.parseRsrcSpec str
344 :     in
345 :     insertRsrcSpec (db, {
346 :     loose=loose, path=path, attr=attr, value=value
347 :     })
348 :     end handle PRS.BadSpec i => raise BadStyleSpec(str,i)
349 :     in
350 :     app parse sl;
351 :     mkStyleServer (scr, db)
352 :     end
353 :    
354 :     (* applicative maps from attribute names to attribute values *)
355 :     structure QuarkMap = BinaryDict (struct
356 :     type ord_key = Q.quark
357 :     val cmpKey = Q.cmp
358 :     end)
359 :    
360 :     (* *)
361 :     fun findAttrs (STY{reqCh, scr, ...}) (name, queries) = let
362 :     val cvtValue = AV.cvtAttrValue scr
363 :     fun unzip ([], attrReqs, defaults) = (attrReqs, defaults)
364 :     | unzip ((attrName, attrTy, default)::r, attrReqs, defaults) =
365 :     unzip(r, (attrName, attrTy)::attrReqs, (default, attrTy)::defaults)
366 :     fun zip ([], [], attrMap) = attrMap
367 :     | zip ((attrName, attrVal)::r1, (default, attrTy)::r2, attrMap) = (
368 :     case (attrVal, default)
369 :     of (AV.AV_NoValue, NONE) => zip (r1, r2, attrMap)
370 :     | (AV.AV_NoValue, SOME v) =>
371 :     zip (r1, r2,
372 :     QuarkMap.insert (attrMap, attrName, cvtValue(v, attrTy))
373 :     (* end case *))
374 :     | _ => zip (r1, r2, QuarkMap.insert (attrMap, attrName, attrVal))
375 :     (* end case *))
376 :     val (attrReqs, defaults) = unzip (queries, [], [])
377 :     val replyV = CML.condVar()
378 :     val _ = CML.send (reqCh, FindAttrs{
379 :     key=name, targets=attrReqs, reply=replyV
380 :     })
381 :     val map = zip (CML.readVar replyV, defaults, QuarkMap.mkDict())
382 :     fun find attr = (case (QuarkMap.peek (map, attr))
383 :     of NONE => AV.AV_NoValue
384 :     | (SOME v) => v
385 :     (* end case *))
386 :     in
387 :     find
388 :     end (* findAttrs *)
389 :    
390 :     (*****************************************************
391 :     val style : style -> style
392 :     (* create a style that is the logical child of another style *)
393 :    
394 :     (* NOTE: we may want to distinguish between "dynamic" and "static" attributes *)
395 :    
396 :     type attr_spec = {attr : string, value : string}
397 :    
398 :     val addResourceSpecs : style -> (string * string) list -> unit
399 :     (* add a list of resource specifications to the style *)
400 :    
401 :     val addAttrs : style -> (style_name * attr_spec list) -> unit
402 :     (* add a list of (attribute, value) pairs to a style; this will propagate
403 :     * to any listeners.
404 :     *)
405 :    
406 :     val deleteAttr : style -> (style_name * string) -> unit
407 :     (* delete an attribute value from a style *)
408 :    
409 :     val mkStyle : style -> (style_name * attr_spec list) -> style
410 :     (* create a new style from an existing style and a list of attribute
411 :     * value definitions.
412 :     *)
413 :    
414 :     val findAttr : style -> style_view -> string option
415 :     (* lookup the given attribute in the given style *)
416 :    
417 :     datatype attr_change
418 :     = ADD_ATTR of string
419 :     | CHANGE_ATTR of string
420 :     | DELETE_ATTR
421 :    
422 :     val listen : style -> style_view -> attr_change CML.event
423 :     (* express an interest in changes to an attribute in a style. This
424 :     * event will be enabled once for each change to the style that occurs
425 :     * after the event is created.
426 :     *)
427 :     *****************************************************)
428 :    
429 :     end; (* Styles *)

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