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/releases/release-110.72/styles/styles-func.sml
ViewVC logotype

Annotation of /eXene/releases/release-110.72/styles/styles-func.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3483 - (view) (download)

1 : monnier 2 (* styles-func.sml
2 :     *
3 :     * COPYRIGHT (c) 1994 AT&T Bell Laboratories.
4 :     *)
5 :    
6 :     signature ATTRS =
7 :     sig
8 :     type attr_type
9 :     type attr_value
10 :     type attr_ctxt
11 :    
12 :     exception NoConversion
13 :     exception BadAttrValue
14 :    
15 :     val AV_NoValue : attr_value
16 :     val sameValue : attr_value * attr_value -> bool
17 :     val sameType : attr_value * attr_type -> bool
18 :     val cvtString : attr_ctxt -> (string * attr_type) -> attr_value
19 :     val cvtAttrValue : attr_ctxt -> (attr_value * attr_type) -> attr_value
20 :     end
21 :    
22 :     functor StylesFunc (AV : ATTRS) (* : STYLES *) =
23 :     struct
24 :    
25 :     structure Weak = SMLofNJ.Weak
26 :     structure Q = Quark
27 :     structure PRS = ParseResourceSpecs
28 :    
29 :     exception BadStyleName
30 :    
31 :     (* a style_name is a key for searching a style database *)
32 :     type style_name = {
33 : mblume 1911 name : Quark.quark list,
34 :     hash : word
35 : monnier 2 }
36 :    
37 :     fun extHash (hash, comp) =
38 : mblume 1911 Word.andb(Word.<<(hash, 0w1), 0wxffffff) + Q.hash comp
39 : monnier 2
40 :     fun styleName sl = let
41 : mblume 1911 fun chkName ([], comps, hash) = {name = rev comps, hash = hash}
42 :     | chkName (s::r, comps, hash) = let
43 :     val comp = PRS.checkCompName s
44 :     in
45 :     chkName (r, comp::comps, extHash(hash, comp))
46 :     end
47 :     in
48 :     (chkName (sl, [], 0w0)) handle _ => raise BadStyleName
49 :     end
50 : monnier 2
51 :     (* compare two style names for equality *)
52 :     fun sameStyleName ({name=n1, hash=h1} : style_name, {name=n2, hash=h2}) = let
53 : mblume 1911 fun cmp ([], []) = true
54 :     | cmp (q1::r1, q2::r2) = Quark.same(q1, q2) andalso cmp(r1, r2)
55 :     | cmp _ = false
56 :     in
57 :     (h1 = h2) andalso cmp(n1, n2)
58 :     end
59 : monnier 2
60 :     (* extend a style name with a component *)
61 :     fun extendStyleName ({name, hash} : style_name, comp) : style_name = let
62 : mblume 1911 val compQ = Quark.quark comp
63 :     in
64 :     { name = name @ [compQ],
65 :     hash = extHash(hash, compQ)
66 :     }
67 :     end
68 : monnier 2
69 :     (* a style_view is a search key for finding attributes in a style.
70 :     * It consists of a name and an ordered list of aliases.
71 :     *)
72 :     datatype style_view = SV of {
73 : mblume 1911 name : style_name,
74 :     aliases : style_name list
75 : monnier 2 }
76 :    
77 :    
78 :     (* make a style_view from a name and list of aliases; the order of the
79 :     * list defines the search order.
80 :     *)
81 :     val mkView = SV
82 :    
83 :     (* return the name part of the view *)
84 :     fun nameOfView (SV{name, ...}) = name
85 :    
86 :     (* return the list of aliases that defines the view. *)
87 :     fun aliasesOfView (SV{aliases, ...}) = aliases
88 :    
89 :     (* extend each of the names in the view by the component *)
90 :     fun extendView (SV{name, aliases}, comp) = let
91 : mblume 1911 val compQ = PRS.checkCompName comp
92 :     fun ext {name, hash} = {
93 :     name = name @ [compQ],
94 :     hash = extHash(hash, compQ)
95 :     }
96 :     in
97 :     SV{name = ext name, aliases = map ext aliases}
98 :     end
99 : monnier 2
100 :     (* concatenate two views; the first view has priority over the second. *)
101 :     fun concatViews (SV{name=n1, aliases=a1}, SV{name=n2, aliases=a2}) =
102 : mblume 1911 SV{name = n1, aliases = a1 @ (n2::a2)}
103 : monnier 2
104 :     (* add a alias to the back or front of a view *)
105 :     fun appendAlias (SV{name, aliases}, alias) =
106 : mblume 1911 SV{name=name, aliases = aliases@[alias]}
107 : monnier 2 fun prependAlias (SV{name, aliases}, alias) =
108 : mblume 1911 SV{name=name, aliases = alias::aliases}
109 : monnier 2
110 :    
111 :     (*** attributes in the database ***)
112 :     datatype attr = ATTR of {
113 : mblume 1911 rawValue : string,
114 :     cache : AV.attr_value ref
115 : monnier 2 }
116 :    
117 :     fun mkAttr rawValue = ATTR{
118 : mblume 1911 rawValue = rawValue,
119 :     cache = ref AV.AV_NoValue
120 :     }
121 : monnier 2
122 :     (* extract the value from an attribute object, performing
123 :     * the conversion, if necessary, and caching the result.
124 :     *)
125 :     fun getAttrValue ctxt = let
126 : mblume 1911 val cvtValue = AV.cvtString ctxt
127 :     fun get (ATTR{rawValue, cache}, attrTy) = let
128 :     val cacheVal = !cache
129 :     in
130 : monnier 2 if AV.sameType (cacheVal, attrTy) then cacheVal
131 :     else let
132 :     val cvtVal = cvtValue (rawValue, attrTy)
133 : mblume 1911 in cache := cvtVal; cvtVal end handle _ => AV.AV_NoValue
134 :     end
135 :     in
136 :     get
137 :     end
138 : monnier 2
139 :    
140 :     (*** The resource database tables ***)
141 :    
142 :     structure QuarkTbl = HashTableFn (struct
143 : mblume 1911 type hash_key = Q.quark
144 :     val hashVal = Q.hash
145 :     val sameKey = Q.same
146 : monnier 2 end)
147 :    
148 :     (* maps on quarks *)
149 :     type 'a qmap = 'a QuarkTbl.hash_table
150 :    
151 :     fun findQuark (tbl, q) = QuarkTbl.find tbl q
152 :     fun insQuark (tbl, q, v) = QuarkTbl.insert tbl (q, v)
153 :     fun empty tbl = (QuarkTbl.numItems tbl = 0)
154 :    
155 :    
156 :     type binding = PRS.binding
157 :    
158 :     datatype db_tbl = DBTBL of {
159 : mblume 1911 tight : db_tbl qmap,
160 :     loose : db_tbl qmap, (* entries of the form "*path.attr:" *)
161 :     attrs : (attr * binding) qmap (* entries of the form "[*]attr:" *)
162 : monnier 2 }
163 :    
164 :     fun newDBTbl () = DBTBL{
165 : mblume 1911 tight = QuarkTbl.mkTable (8, Fail "db_tbl.tight"),
166 :     loose = QuarkTbl.mkTable (8, Fail "db_tbl.loose"),
167 :     attrs = QuarkTbl.mkTable (8, Fail "db_tbl.attrs")
168 :     }
169 : monnier 2
170 :     (* given a database and a component name path, find the list of
171 :     * attribute binding tables keyed by the path.
172 :     *)
173 :     fun findAttrTbls (DBTBL{tight, loose, attrs}, path) = let
174 : mblume 1911 fun findLooseAttr attrTbl attrQ = (case findQuark(attrTbl, attrQ)
175 :     of (SOME(attr, LOOSE)) => (SOME attr)
176 :     | _ => NONE
177 :     (* end case *))
178 :     fun findAttr attrTbl attrQ = (case findQuark(attrTbl, attrQ)
179 :     of (SOME(attr, LOOSE)) => (SOME attr)
180 :     | _ => NONE
181 :     (* end case *))
182 :     fun find (tight, loose, attrs, [], tbls) =
183 :     if (empty attrs) then tbls else (findAttr attrs)::tbls
184 :     | find (tight, loose, attrs, comp::r, tbls) = let
185 :     val tbls' = (case (findQuark(tight, comp))
186 :     of NONE => tbls
187 :     | (SOME(DBTBL{tight, loose, attrs})) =>
188 :     find (tight, loose, attrs, r, tbls)
189 :     (* end case *))
190 :     fun findLoose ([], tbls) = tbls
191 :     | findLoose (comp::r, tbls) = (case findQuark(loose, comp)
192 :     of NONE => findLoose (r, tbls)
193 :     | (SOME(DBTBL{tight, loose, attrs})) =>
194 :     findLoose (r, find (tight, loose, attrs, r, tbls))
195 :     (* end case *))
196 :     val tbls'' = if (empty loose) then tbls' else findLoose(r, tbls')
197 :     in
198 :     if (empty attrs) then tbls'' else (findLooseAttr attrs)::tbls''
199 :     end
200 :     val tbls = rev (find (tight, loose, attrs, path, []))
201 : monnier 2 (** NOTE: we may want to just return a list of tables, instead of a composite
202 :     ** function, since views consist of a name plus aliases.
203 :     **)
204 : mblume 1911 fun search attr = let
205 :     fun search' [] = NONE
206 :     | search' (tbl::r) = (case (tbl attr)
207 :     of NONE => search' r
208 :     | someVal => someVal
209 :     (* end case *))
210 :     in
211 :     search' tbls
212 :     end
213 :     in
214 :     search
215 :     end (* findAttrTbls *)
216 : monnier 2
217 :     (* insert an attribute binding into the database *)
218 :     fun insertAttr (db, isLoose, path, name, attr) = let
219 : mblume 1911 fun find (tbl, comp) = (case findQuark(tbl, comp)
220 :     of (SOME db) => db
221 :     | NONE => let val db = newDBTbl()
222 :     in
223 :     insQuark (tbl, comp, db); db
224 :     end
225 :     (* end case *))
226 :     fun insert (DBTBL{tight, loose, attrs}, bind, path) = (
227 :     case (bind, path)
228 :     of (PRS.TIGHT, (PRS.Name comp, bind)::r) =>
229 :     insert (find (tight, comp), bind, r)
230 :     | (PRS.LOOSE, (PRS.Name comp, bind)::r) =>
231 :     insert (find (loose, comp), bind, r)
232 :     | (_, (PRS.Wild, _)::_) =>
233 :     raise Fail "wildcard components not implemented"
234 :     | (_, []) => insQuark (attrs, name, (attr, bind))
235 :     (* end case *))
236 :     in
237 :     insert (db, if isLoose then PRS.LOOSE else PRS.TIGHT, path)
238 :     end (* insertRsrcSpec *)
239 : monnier 2
240 :    
241 :     (*** The database with view cache ***)
242 :     datatype db = DB of {
243 : mblume 1911 db : db_tbl,
244 :     cache : (style_name * (PRS.attr_name -> attr option)) Weak.weak list ref
245 : monnier 2 }
246 :    
247 :     fun mkDB () = DB{
248 : mblume 1911 db = newDBTbl(),
249 :     cache = ref []
250 :     }
251 : monnier 2
252 :     (* this is a temporary function for building resource data bases by hand *)
253 :     fun insertRsrcSpec (DB{db, cache}, {loose, path, attr, value}) = (
254 : mblume 1911 insertAttr (db, loose, path, attr, mkAttr value);
255 :     cache := [])
256 : monnier 2
257 :     (* given a database and a style view (name + aliases) construct the lookup
258 :     * function for the view.
259 :     *)
260 :     fun constructView (DB{db, cache}, SV{name, aliases}) = let
261 : mblume 1911 (* probe the cache for a binding for name; remove any stale
262 :     * cache entries that are encountered.
263 :     *)
264 :     fun probeCache name = let
265 :     fun probe ([], l) = (rev l, NONE)
266 :     | probe (w::r, l) = (case (Weak.strong w)
267 :     of NONE => probe (r, l)
268 :     | (SOME(name', binding)) =>
269 :     if (sameStyleName(name, name'))
270 :     then (w :: ((rev l) @ r), SOME binding)
271 :     else probe (r, w::l)
272 :     (* end case *))
273 :     val (cache', result) = probe (!cache, [])
274 :     in
275 :     cache := cache'; result
276 :     end
277 :     (* add a binding to the cache *)
278 :     fun addToCache item = cache := (Weak.weak item) :: !cache
279 :     (* find the attribute tables for a name *)
280 :     fun findTbls (name : style_name) = (case (probeCache name)
281 :     of NONE => let
282 :     val tbls = findAttrTbls (db, #name name)
283 :     in
284 :     addToCache (name, tbls);
285 :     tbls
286 :     end
287 :     | (SOME tbls) => tbls
288 :     (* end case *))
289 :     (* search for an attribute in this view *)
290 :     fun findAttr attrName = let
291 :     fun search [] = NONE
292 :     | search (name::r) = (case (findTbls name attrName)
293 :     of NONE => search r
294 :     | attr => attr
295 :     (* end case *))
296 :     in
297 :     search (name::aliases)
298 :     end
299 :     in
300 :     findAttr
301 :     end
302 : monnier 2
303 :    
304 :     (*** Styles ***)
305 :    
306 :     datatype req_msg
307 :     = FindAttrs of {
308 : mblume 1911 key : style_view,
309 :     targets : (PRS.attr_name * AV.attr_type) list,
310 :     reply : (PRS.attr_name * AV.attr_value) list SyncVar.ivar
311 :     }
312 :     (* added ddeboer May 2004 *)
313 :     | GetDb of db SyncVar.ivar
314 :     (* end additions by ddeboer *)
315 : monnier 2
316 :     datatype style = STY of {
317 : mblume 1911 ctxt : AV.attr_ctxt,
318 :     reqCh : req_msg CML.chan
319 : monnier 2 }
320 :    
321 :     fun ctxtOf (STY{ctxt,...}) = ctxt
322 :    
323 :     (* spawn a style server for the given context and database *)
324 :     fun mkStyleServer (ctxt, db) = let
325 : mblume 1911 val ch = CML.channel()
326 :     val getAttrValue = getAttrValue ctxt
327 :     fun findAttr key = let
328 :     val find = constructView (db, key)
329 :     in
330 :     fn (attrName, attrTy) => (case (find attrName)
331 :     of NONE => (attrName, AV.AV_NoValue)
332 :     | (SOME attr) => (attrName, getAttrValue (attr, attrTy))
333 :     (* end case *))
334 :     end
335 :     fun server () = (
336 :     case (CML.recv ch)
337 :     of (FindAttrs{key, targets, reply}) => let
338 :     val results = map (findAttr key) targets
339 :     in
340 :     SyncVar.iPut (reply, results)
341 :     end
342 :     (* added ddeboer May 2004 *)
343 :     | (GetDb(reply)) => (SyncVar.iPut(reply,db))
344 :     (* end additions by ddeboer *)
345 :     (* end case *);
346 :     server ())
347 :     in
348 :     CML.spawn server;
349 :     STY{
350 :     reqCh = ch, ctxt = ctxt
351 :     }
352 :     end (* mkStyleServer *)
353 : monnier 2
354 :     (* create an empty style *)
355 :     fun emptyStyle ctxt = mkStyleServer (ctxt, mkDB ())
356 :    
357 :     (* create a style, initializing it from a list of strings. This
358 :     * is for testing purposes.
359 :     *)
360 :     fun styleFromStrings (ctxt, sl) = let
361 : mblume 1911 val db = mkDB()
362 :     fun parse str = let
363 :     val (PRS.RsrcSpec{loose, path, attr, value, ...}) =
364 :     PRS.parseRsrcSpec str
365 :     in
366 :     insertRsrcSpec (db, {
367 :     loose=loose, path=path, attr=attr, value=value
368 :     })
369 :     end
370 :     in
371 :     app parse sl;
372 :     mkStyleServer (ctxt, db)
373 :     end
374 : monnier 2
375 :     (* applicative maps from attribute names to attribute values *)
376 :     structure QuarkMap = BinaryMapFn (struct
377 : mblume 1911 type ord_key = Q.quark
378 :     val compare = Q.cmp
379 : monnier 2 end)
380 :    
381 :     (* *)
382 :     fun findAttrs (STY{reqCh, ctxt, ...}) (name, queries) = let
383 : mblume 1911 val cvtValue = AV.cvtAttrValue ctxt
384 :     fun unzip ([], attrReqs, defaults) = (attrReqs, defaults)
385 :     | unzip ((attrName, attrTy, default)::r, attrReqs, defaults) =
386 :     unzip(r, (attrName, attrTy)::attrReqs, (default, attrTy)::defaults)
387 :     fun zip ([], [], attrMap) = attrMap
388 :     | zip ((attrName, attrVal)::r1, (dflt, attrTy)::r2, attrMap) =
389 : monnier 2 if AV.sameValue(attrVal,AV.AV_NoValue) then
390 : mblume 1911 if AV.sameValue(dflt, AV.AV_NoValue)
391 : monnier 2 then zip (r1, r2, attrMap)
392 : mblume 1911 else zip (r1, r2,
393 :     QuarkMap.insert (attrMap, attrName, cvtValue(dflt, attrTy)))
394 :     else zip (r1, r2, QuarkMap.insert (attrMap, attrName, attrVal))
395 :     val (attrReqs, defaults) = unzip (queries, [], [])
396 :     val replyV = SyncVar.iVar()
397 :     val _ = CML.send (reqCh, FindAttrs{
398 :     key=name, targets=attrReqs, reply=replyV
399 :     })
400 :     val map = zip (SyncVar.iGet replyV, defaults, QuarkMap.empty)
401 :     fun find attr = (case (QuarkMap.find (map, attr))
402 :     of NONE => AV.AV_NoValue
403 :     | (SOME v) => v
404 :     (* end case *))
405 :     in
406 :     find
407 :     end (* findAttrs *)
408 : monnier 2
409 :     (*****************************************************
410 :     val style : style -> style
411 :     (* create a style that is the logical child of another style *)
412 :    
413 :     (* NOTE: we may want to distinguish between "dynamic" and "static" attributes *)
414 :    
415 :     type attr_spec = {attr : string, value : string}
416 :    
417 :     val addResourceSpecs : style -> (string * string) list -> unit
418 : mblume 1911 (* add a list of resource specifications to the style *)
419 : monnier 2
420 :     val addAttrs : style -> (style_name * attr_spec list) -> unit
421 : mblume 1911 (* add a list of (attribute, value) pairs to a style; this will propagate
422 :     * to any listeners.
423 :     *)
424 : monnier 2
425 :     val deleteAttr : style -> (style_name * string) -> unit
426 : mblume 1911 (* delete an attribute value from a style *)
427 : monnier 2
428 :     val mkStyle : style -> (style_name * attr_spec list) -> style
429 : mblume 1911 (* create a new style from an existing style and a list of attribute
430 :     * value definitions.
431 :     *)
432 : monnier 2
433 :     val findAttr : style -> style_view -> string option
434 : mblume 1911 (* lookup the given attribute in the given style *)
435 : monnier 2
436 :     datatype attr_change
437 :     = ADD_ATTR of string
438 :     | CHANGE_ATTR of string
439 :     | DELETE_ATTR
440 :    
441 :     val listen : style -> style_view -> attr_change CML.event
442 : mblume 1911 (* express an interest in changes to an attribute in a style. This
443 :     * event will be enabled once for each change to the style that occurs
444 :     * after the event is created.
445 :     *)
446 : monnier 2 *****************************************************)
447 :    
448 : mblume 1911 (* Additions by ddeboer, May 2004.
449 :     * Dusty deBoer, KSU CIS 705, Spring 2004. *)
450 :    
451 :     (* utility function: list the resource specs from a db.
452 :     * a resource spec is roughly:
453 :     * PRS.RsrcSpec{loose:bool,path:(PRS.component*PRS.binding)list,attr:PRS.attr_name,value:string,ext:(false)}
454 :     *)
455 :     fun listRsrcSpecs (DB{db,cache}) =
456 :     let
457 :     fun lstSpcs (DBTBL{tight,loose,attrs},pth) =
458 :     (* list specs from attrs; that is the easy part. *)
459 :     (let
460 :     val (qabLst: (Quark.quark * (attr * binding)) list) = QuarkTbl.listItemsi attrs
461 :     val (rscSpL: PRS.resource_spec list) =
462 :     List.map
463 :     (fn (qu,(ATTR{rawValue,...},bind)) =>
464 :     PRS.RsrcSpec{loose=(case bind of PRS.LOOSE=>true | PRS.TIGHT=>false),
465 :     path=pth,attr=qu,value=rawValue,ext=false})
466 :     qabLst
467 :     val (loosqtLst: (Quark.quark * db_tbl) list) =
468 :     QuarkTbl.listItemsi loose
469 :     val (loostpLst: (db_tbl * (PRS.component * PRS.binding) list) list) =
470 :     List.map (fn (q,t) => (t,pth@[(PRS.Name q,PRS.LOOSE)])) loosqtLst
471 :     val (loosRscSpL: PRS.resource_spec list) =
472 :     List.concat (List.map lstSpcs loostpLst)
473 :     val (tghtqtLst: (Quark.quark * db_tbl) list) =
474 :     QuarkTbl.listItemsi tight
475 :     val (tghttpLst: (db_tbl * (PRS.component * PRS.binding) list) list) =
476 :     List.map (fn (q,t) => (t,pth@[(PRS.Name q,PRS.TIGHT)])) tghtqtLst
477 :     val (tghtRscSpL: PRS.resource_spec list) =
478 :     List.concat (List.map lstSpcs tghttpLst)
479 :     in (rscSpL@loosRscSpL@tghtRscSpL) end)
480 :     in lstSpcs (db,[]) end
481 :    
482 :     (* another utility function - get the resource specs from a style, then convert them
483 :     * to strings. This could be used to write a style back to a database, as in
484 :     * XrmPutFileDatabase().
485 :     *)
486 :     fun stringsFromStyle (STY{reqCh,ctxt}) =
487 :     let
488 :     val replyV = SyncVar.iVar()
489 :     val _ = CML.send(reqCh,GetDb(replyV))
490 :     val db = SyncVar.iGet replyV
491 :     in
492 :     List.map
493 :     (fn PRS.RsrcSpec{loose,path,attr,value,...} =>
494 :     (String.concat
495 :     (List.map
496 :     (fn (PRS.Name cn,b) =>
497 :     (case b of PRS.LOOSE => "*" | PRS.TIGHT => ".")^(Quark.stringOf cn))
498 :     path))^
499 :     (if loose then "*" else ".")^(Quark.stringOf attr)^":"^value)
500 :     (listRsrcSpecs db)
501 :     end;
502 :    
503 :     (* mergeStyles(sourceStyle: style, targetStyle: style) -> mergedStyle: style
504 :     *
505 :     * mergedStyle should consist of the same resource specifications that would
506 :     * exist in targetStyle if all resource specifications of sourceStyle were
507 :     * inserted into targetStyle. That is, in particular, a tight binding of a
508 :     * particular resource specification in targetStyle would not be overwritten
509 :     * by a loose binding of the same specification in sourceStyle.
510 :     *
511 :     * The behavior of this should be similar to XrmMergeDatabases(db1,db2) of Xlib;
512 :     * in particular, resources specified in db1 should override those in db2.
513 :     *)
514 :     fun mergeStyles (STY{reqCh=rc1,ctxt=ctxt1},STY{reqCh=rc2,ctxt=ctxt2}) =
515 :     let
516 :     val repv1 = SyncVar.iVar()
517 :     val repv2 = SyncVar.iVar()
518 :     val _ = CML.send(rc1,GetDb(repv1))
519 :     val _ = CML.send(rc2,GetDb(repv2))
520 :     val (db1: db) = SyncVar.iGet repv1
521 :     val (db2: db) = SyncVar.iGet repv2
522 :     val rsrcsp1 = listRsrcSpecs db1
523 :     fun insRsrcSpcs ([]) = ()
524 :     | insRsrcSpcs (PRS.RsrcSpec{loose,path,attr,value,...}::rs) =
525 :     (insertRsrcSpec (db2,{loose=loose,path=path,attr=attr,value=value});
526 :     insRsrcSpcs rs)
527 :     in
528 :     (insRsrcSpcs rsrcsp1;
529 :     mkStyleServer(ctxt2,db2))
530 :     end
531 :    
532 :     (*
533 :     fun mergeStyles (STY{reqCh=rc1,ctxt=ctxt1},STY{reqCh=rc2,ctxt=ctxt2}) =
534 :     let
535 :     val repv1 = SyncVar.iVar()
536 :     val repv2 = SyncVar.iVar()
537 :     val _ = CML.send(rc1,GetDb(repv1))
538 :     val _ = CML.send(rc2,GetDb(repv2))
539 :     val (db1: db) = SyncVar.iGet repv1
540 :     val (db2: db) = SyncVar.iGet repv2
541 :     * insert every entry in quarktable1 into quarktable2 *
542 :     fun qtMerge (ht1,ht2) =
543 :     (List.app (fn (k,v) => (QuarkTbl.insert ht2 (k,v))) (QuarkTbl.listItemsi ht1))
544 :     * merge: insert all attribute values from db1 into db2 *
545 :     fun dbMerge (DBTBL{tight=tght1,loose=loos1,attrs=attr1},
546 :     DBTBL{tight=tght2,loose=loos2,attrs=attr2}) =
547 :     (qtMerge(attr1,attr2);dbMerge(tght1,tght2);dbMerge(loos1,loos2))
548 :     in (dbMerge(db1,db2); mkStyleServer(ctxt2,db2)) end
549 :     *)
550 :    
551 :     (**
552 :     * Parsing of command line arguments:
553 :     *----------------------------------
554 :     *)
555 :     (* options specified on the command line may be of two types:
556 :     * - a "named" option, such as "x" and "y" in "add -x 1 -y 3" where "x" and "y" are simple
557 :     * arguments to the "add" program that adds them together, and where the "add" program
558 :     * simply wishes to determine the value of "x" and "y", or
559 :     * - a "resource spec" option, such as "foreground" in "xapp -foreground black" where the
560 :     * "xapp" wishes to obtain a resource specification like "*foreground: black" from these
561 :     * command line arguments.
562 :     *)
563 :     (* Named options should be typically useful in obtaining input for
564 :     * processing by an application, as opposed to X resource specification
565 :     * values. For example, "-filename foo" will probably be used by an
566 :     * application in some process, while "-background bar" is an X resource
567 :     * to be used in some graphical display.
568 :     * For further details see eXene/styles/styles-func.sml.
569 :     *)
570 :     datatype optName
571 :     = OPT_NAMED of string (* custom options: retrieve by name *)
572 :     | OPT_RESSPEC of string (* resource options: convert to a style *)
573 :    
574 :     type argName = string (* option spec string in argv *)
575 :     datatype optKind
576 :     = OPT_NOARG of string (* as XrmoptionNoArg. optname will assume this value if argName is specified in argv *)
577 :     | OPT_ISARG (* as XrmoptionIsArg: value is option string itself *)
578 :     | OPT_STICKYARG (* as XrmoptionStickyArg: value is chars immediately following option *)
579 :     | OPT_SEPARG (* as XrmoptionSepArg: value is next argument in argv *)
580 :     | OPT_RESARG (* as XrmoptionResArg: resource and value in next argument in argv *)
581 :     | OPT_SKIPARG (* as XrmSkipArg: ignore this option and next argument in argv *)
582 :     | OPT_SKIPLINE (* as XrmSkipLine: ignore this option and the rest of argv *)
583 :     datatype optVal
584 :     = OPT_ATTRVAL of (string * AV.attr_type)
585 :     | OPT_STRING of string
586 :     (* option specification table: name for searching, name in argv, kind of option, and type of option *)
587 :     type optSpec = (optName * argName * optKind * AV.attr_type) list
588 :     (* command line argument strings, with optSpec, will be converted into a optDb *)
589 :     type optDb = (optName * optVal) list
590 :    
591 :     (* parseCommand: optSpec -> (string list) -> (optDb * string list)
592 :     * parseCommand proceeds through the string list of command line arguments,
593 :     * adding any recognizable options from optSpec to the optDb. Any unrecognized
594 :     * arguments (that is, arguments not recognized as unique prefixes of an option
595 :     * in optSpec) are returned as a string list, along with the optDb produced.
596 :     * Future improvement: figure out a way for these unrecognized arguments to be
597 :     * somehow marked as to their position in the original argument list, in case
598 :     * position is important.
599 :     *)
600 :    
601 :     fun parseCommand (os: optSpec) [] = ([],[])
602 :     | parseCommand (os: optSpec) (s::sl) =
603 :     (let
604 :     fun mkOptRec (optNam,optVal:string,attrType:AV.attr_type) =
605 :     (case optNam of
606 :     OPT_NAMED(n) =>
607 :     (optNam,OPT_ATTRVAL(optVal,attrType))
608 :     | OPT_RESSPEC(n) =>
609 :     (optNam,OPT_STRING(optVal)))
610 :     in
611 :     (case ((List.filter
612 :     (fn (_,an,_,_) => ((String.isPrefix s an) orelse (String.isPrefix an s)))
613 :     os): (optName * argName * optKind * AV.attr_type) list) of
614 :     ([]:optSpec) =>
615 :     (let
616 :     val (od,ua) = (parseCommand (os) sl)
617 :     in (od,s::ua) end)
618 :     | ([(on,an,OPT_NOARG(av),at)]:optSpec) =>
619 :     (let
620 :     val (od,ua) = (parseCommand (os) sl)
621 :     in ((mkOptRec(on,av,at))::od,ua) end)
622 :     | ([(on,an,OPT_ISARG,at)]:optSpec) =>
623 :     (let
624 :     val (od,ua) = (parseCommand (os) sl)
625 :     in ((mkOptRec(on,an,at))::od,ua) end)
626 :     | ([(on,an,OPT_STICKYARG,at)]:optSpec) =>
627 :     (let
628 :     val la = String.size(s)
629 :     val lo = String.size(an)
630 :     val sv = (if la>lo then String.substring(s,(lo),(la-lo)) else "")
631 :     val (od,ua) = (parseCommand (os) sl)
632 :     in ((mkOptRec(on,sv,at))::od,ua) end)
633 :     | ([(on,an,OPT_SEPARG,at)]:optSpec) =>
634 :     (case sl of
635 :     sv::svs =>
636 :     (let
637 :     val (od,ua) = (parseCommand (os) svs)
638 :     in ((mkOptRec(on,sv,at))::od,ua) end)
639 :     | [] =>
640 :     (let
641 :     val (od,ua) = (parseCommand (os) sl)
642 :     in (od,s::ua) end))
643 :     | ([(on,an,OPT_RESARG,at)]:optSpec) =>
644 :     (case sl of
645 :     sv::svs =>
646 :     (let
647 :     val (bcol::(acol::_)) = (String.tokens (fn c => (c=(#":"))) sv)
648 :     val (od,ua) = (parseCommand (os) svs)
649 :     in ((mkOptRec(on,sv,at))::
650 :     (OPT_RESSPEC(bcol),OPT_STRING(acol))::od,ua) end)
651 :     | [] =>
652 :     (let
653 :     val (od,ua) = (parseCommand (os) sl)
654 :     in (od,s::ua) end))
655 :     | ([(on,an,OPT_SKIPARG,at)]:optSpec) =>
656 :     (case sl of
657 :     sv::svs =>
658 :     (let
659 :     val (od,ua) = (parseCommand (os) svs)
660 :     in (od,ua) end)
661 :     | [] =>
662 :     (let
663 :     val (od,ua) = (parseCommand (os) sl)
664 :     in (od,s::ua) end))
665 :     | ([(on,an,OPT_SKIPLINE,at)]:optSpec) => ([],[])
666 :     (* ambiguous argument s *)
667 :     | (_:optSpec) => (let
668 :     val (od,ua) = (parseCommand (os) sl)
669 :     in (od,s::ua) end))
670 :     end)
671 :    
672 :     (* findNamedOpt: optDb -> optName -> AV.attr_value list
673 :     * find the attribute values of the "named" command line arguments.
674 :     * this will return a list of _all_ arguments with the given name, with
675 :     * the last argument value given on the command line as the head of the
676 :     * list.
677 :     * this allows an application to process named arguments in several ways -
678 :     * it may wish that later arguments take precedence over earlier arguments,
679 :     * in which case it may use only the head of the value list (if it exists).
680 :     * otherwise, if the application wishes to obtain all of the argument values,
681 :     * it may do this also (by working with the whole list).
682 :    
683 :     OPT_ATTRVAL(AV.cvtString ctxt (optVal,attrType))
684 :     *)
685 :     fun findNamedOpt od (OPT_NAMED(on)) ctxt =
686 :     let
687 :     fun filt (OPT_NAMED(n),v) = (n=on)
688 :     | filt (_,_) = false
689 :     in
690 :     (List.rev
691 :     (List.map (fn (n,v) =>
692 :     (case v of OPT_ATTRVAL(v,t) =>
693 :     (AV.cvtString ctxt (v,t)) | _ => AV.AV_NoValue))
694 :     (List.filter filt od)))
695 :     end
696 :     | findNamedOpt od (OPT_RESSPEC(on)) ctxt = []
697 :    
698 :     fun findNamedOptStrings od (OPT_NAMED(on)) =
699 :     let
700 :     fun filt (OPT_NAMED(n),v) = (n=on)
701 :     | filt (_,_) = false
702 :     in
703 :     (List.rev
704 :     (List.map (fn (n,v) =>
705 :     (case v of OPT_ATTRVAL(v,t) => v | _ => ""))
706 :     (List.filter filt od)))
707 :     end
708 :     | findNamedOptStrings od (OPT_RESSPEC(on)) = []
709 :    
710 :     (* styleFromOptDb: create a style from resource specifications in optDb.
711 :     *)
712 :     fun styleFromOptDb (ctxt,od) =
713 :     let
714 :     fun filt (OPT_RESSPEC(n),v) = true
715 :     | filt (_,_) = false
716 :     fun rovToStr(OPT_RESSPEC(n),OPT_STRING(v)) = (n^":"^v)
717 :     | rovToStr(_,_) = ""
718 :     val strLst = List.map (rovToStr) (List.filter filt od)
719 :     in
720 :     styleFromStrings(ctxt,strLst)
721 :     end
722 :    
723 :     (* a utility function that returns a string outlining the valid command
724 :     * line arguments in optSpec. *)
725 :     fun helpStrFromOptSpec (os:optSpec) =
726 :     let
727 :     val argLst = (List.map (fn (_,ar,_,_) => ar:string) os)
728 :     val hlpStr = ("["^(String.concatWith "|" argLst)^"]")
729 :     in ("Valid options:\n"^hlpStr^"\n") end
730 :    
731 :     (* end additions by ddeboer. *)
732 :    
733 : monnier 2 end; (* Styles *)

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