CVS: sml-dist/src/eXene/widgets/basics root.sml,1.2,1.3 router.sml,1.2,1.3 shell.sml,1.2,1.3
Matthias Blume <[email protected]>
| Newsgroups | gmane.comp.lang.sml.smlnj.commits |
|---|---|
| Message-ID | <[email protected]> |
Update of /cvsroot/smlnj/sml-dist/src/eXene/widgets/basics
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv32471/widgets/basics
Modified Files:
root.sml router.sml shell.sml
Log Message:
merge Kansas changes to eXene into repository
Index: root.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/eXene/widgets/basics/root.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** root.sml 1 Jun 2000 18:33:41 -0000 1.2
--- root.sml 3 Mar 2006 03:33:16 -0000 1.3
***************
*** 35,38 ****
--- 35,93 ----
val styleFromStrings : root * string list -> style
+ (* Additions by ddeboer (KSU CIS 705, Spring 2004) *)
+
+ (* was/is included for testing purposes: disabled because can be unreliable.
+ val stringsFromStyle : style -> string list
+ *)
+
+ (* mergeStyles(style1,style2): merge style1 with style2,
+ * giving precedence first to tight bindings, then to resources
+ * of style1.
+ *)
+ val mergeStyles : style * style -> style
+
+ (* styleFromXRDB: return a style created from the properties
+ * loaded by xrdb into the X-server
+ *)
+ val styleFromXRDB : root -> style
+
+ (* command line option specification and parsing:
+ * see eXene/styles/styles-func.sml for details. *)
+ type optName
+ type argName
+ type optKind
+ type optSpec
+ type optDb
+ type attr_value
+
+ (* parseCommand: given a root and an option spec, create an option db
+ * from command line arguments. *)
+ val parseCommand : optSpec -> string list -> optDb * string list
+
+ (* findNamedOpt: given an option db and a named option (an option to
+ * be used for purposes other than resource specification), return a
+ * list of Attrs.attr_values. This list is ordered such that the last
+ * value to appear on the command line appears first in this list, so
+ * that the application may choose to use the first value only, or it
+ * may choose to use all values given.
+ * Named options should be typically useful in obtaining input for
+ * processing by an application, as opposed to X resource specification
+ * values. For example, "-filename foo" will probably be used by an
+ * application in some process, while "-background bar" is an X resource
+ * to be used in some graphical display.
+ * For further details see eXene/styles/styles-func.sml.
+ *)
+ val findNamedOpt : optDb -> optName -> root -> attr_value list
+
+ val findNamedOptStrings : optDb -> optName -> string list
+
+ (* styleFromOptDb: create a style from resource specifications in optDb.
+ *)
+ val styleFromOptDb : root * optDb -> style
+
+ (* a utility function that returns a string outlining the valid command
+ * line arguments in optSpec. *)
+ val helpStrFromOptSpec : optSpec -> string
+ (* end additions; but see below *)
end (* ROOT *)
***************
*** 109,111 ****
--- 164,201 ----
Styles.styleFromStrings ({scr=scr,tilef=mktile},sl)
+ (* Additions by ddeboer: (KSU CIS 705, Spring 2004) *)
+
+ fun stringsFromStyle sty = Styles.stringsFromStyle sty
+ fun mergeStyles (sty1,sty2) = Styles.mergeStyles (sty1,sty2)
+ fun styleFromXRDB root =
+ (let
+ val dpy = displayOf(root)
+ val scr = EXB.defaultScreenOf dpy
+ val stl = ICCC.xrdbOfScr scr
+ in (
+ (*(TextIO.print ("XRDB strings:\n"^(String.concatWith "\n" stl)^"\n"));*)
+ styleFromStrings(root,stl)) end)
+
+ type optName = Styles.optName
+ type argName = Styles.argName
+ type optKind = Styles.optKind
+ type optSpec = Styles.optSpec
+ type optDb = Styles.optDb
+ type attr_value = Attrs.attr_value
+
+ fun parseCommand (oSpec) sl =
+ Styles.parseCommand (oSpec) sl
+
+ fun findNamedOpt (oDb:Styles.optDb) (oNam:Styles.optName) (Root{scr,mktile,...}) =
+ (Styles.findNamedOpt oDb oNam {scr=scr,tilef=mktile})
+
+ fun styleFromOptDb (Root{scr,mktile,...},oDb) =
+ (Styles.styleFromOptDb ({scr=scr,tilef=mktile},oDb))
+
+ fun findNamedOptStrings (oDb:Styles.optDb) (oNam:Styles.optName) =
+ (Styles.findNamedOptStrings oDb oNam)
+
+ fun helpStrFromOptSpec(oSpec) = Styles.helpStrFromOptSpec(oSpec)
+ (* end additions *)
+
end (* Root *)
Index: router.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/eXene/widgets/basics/router.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** router.sml 1 Jun 2000 18:33:41 -0000 1.2
--- router.sml 3 Mar 2006 03:33:16 -0000 1.3
***************
*** 27,31 ****
val routePair : Interact.in_env * Interact.out_env * Interact.out_env -> unit
!
end (* ROUTER *)
--- 27,33 ----
val routePair : Interact.in_env * Interact.out_env * Interact.out_env -> unit
! (* added by ddeboer: *)
! val bufferEvt : ('a Interact.addr_msg -> unit CML.event) -> ('a Interact.addr_msg -> unit CML.event)
! (* end added *)
end (* ROUTER *)
***************
*** 49,52 ****
--- 51,73 ----
}
+ (* make a buffer-handler; ddeboer, fall 2004.
+ * Try to synchronize on inev, queueing value v; or
+ * Try to synchronize on outev v if queue is nonempty, where v is head of queue.
+ * bufferEvt : ('a addr_msg -> unit event) -> ('a addr_msg -> unit event)
+ *)
+ (* note: should use wrapQueue where possible. *)
+ fun bufferEvt outStm : ('a addr_msg -> unit event) =
+ let val inCh = channel()
+ fun loop ([], []) = loop([(recv inCh)],[])
+ | loop ([], rear) = loop(rev rear,[])
+ | loop (front as (msgOut::r), rear) =
+ (select[
+ (wrap((outStm msgOut), fn () => loop(r,rear))),
+ (wrap(recvEvt inCh, fn msg => loop(front,msg::rear)))
+ ])
+ fun inEvt msg = (sendEvt (inCh,msg))
+ in spawn(fn () => loop ([],[])); inEvt end
+ (* end addition *)
+
(* The router is constructed with an in_env, out_env for a
* composite widget and an initial distribution
***************
*** 64,73 ****
val insert = insert winMap
val remove = remove winMap
!
fun mEvt (OutEnv {m,...}) = m
fun kEvt (OutEnv {k,...}) = k
fun ciEvt (OutEnv {ci,...}) = ci
! fun handleReq (AddChild item) = insert item
| handleReq (DelChild w) = ((remove w; ()) handle _ => ())
| handleReq (GetChild w) = send(routeReplyCh, (SOME(find w)) handle _ => NONE)
--- 85,100 ----
val insert = insert winMap
val remove = remove winMap
!
fun mEvt (OutEnv {m,...}) = m
fun kEvt (OutEnv {k,...}) = k
fun ciEvt (OutEnv {ci,...}) = ci
! (* modified by ddeboer; original:
! fun handleReq (AddChild item) = insert item*)
! val myOut = case myOut of OutEnv{m,k,ci,co} =>
! OutEnv{m=(bufferEvt m),k=(bufferEvt k),ci=(bufferEvt ci),co=co}
! fun handleReq (AddChild (w,OutEnv{m,k,ci,co})) =
! insert (w,OutEnv{m=(bufferEvt m),k=(bufferEvt k),ci=(bufferEvt ci),co=co})
! (* end modification *)
| handleReq (DelChild w) = ((remove w; ()) handle _ => ())
| handleReq (GetChild w) = send(routeReplyCh, (SOME(find w)) handle _ => NONE)
***************
*** 110,117 ****
fun routePair (InEnv{m, k, ci,...}, parentOut, childOut) = let
! fun mEvt (OutEnv {m,...}) = m
! fun kEvt (OutEnv {k,...}) = k
fun ciEvt (OutEnv {ci,...}) = ci
fun handleEvt proj msg =
case stripMsg msg of
--- 137,153 ----
fun routePair (InEnv{m, k, ci,...}, parentOut, childOut) = let
! fun mEvt (OutEnv {m,...}) = m (* mouse_msg addr_msg -> unit event *)
! fun kEvt (OutEnv {k,...}) = k
fun ciEvt (OutEnv {ci,...}) = ci
+ (* added by ddeboer: *)
+ val childOut =
+ case childOut of OutEnv{m,k,ci,co} =>
+ OutEnv{m= (bufferEvt m),
+ k= (bufferEvt k),
+ ci=(bufferEvt ci),
+ co=co}
+ (* end added. *)
+
fun handleEvt proj msg =
case stripMsg msg of
Index: shell.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/eXene/widgets/basics/shell.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** shell.sml 1 Jun 2000 18:33:41 -0000 1.2
--- shell.sml 3 Mar 2006 03:33:16 -0000 1.3
***************
*** 35,41 ****
val shell : (W.root * W.view * W.arg list) -> W.widget -> shell
!
val mkShell : W.widget * W.EXB.color option * wm_args -> shell
val mkShellAt : W.G.rect -> W.widget * W.EXB.color option * wm_args -> shell
val mkTransientShell : W.EXB.window ->
W.widget * W.EXB.color option * wm_args -> shell
--- 35,42 ----
val shell : (W.root * W.view * W.arg list) -> W.widget -> shell
!
val mkShell : W.widget * W.EXB.color option * wm_args -> shell
val mkShellAt : W.G.rect -> W.widget * W.EXB.color option * wm_args -> shell
+
val mkTransientShell : W.EXB.window ->
W.widget * W.EXB.color option * wm_args -> shell
***************
*** 48,52 ****
val unmap : shell -> unit
val destroy : shell -> unit
!
end (* SHELL *)
--- 49,57 ----
val unmap : shell -> unit
val destroy : shell -> unit
!
! (* added by ddeboer: *)
! val deleteEvent : shell -> unit CML.event
! (* end added *)
!
end (* SHELL *)
***************
*** 67,71 ****
datatype shell_msg = Init | Destroy | Map of bool | Hints of hints
! datatype shell = Shell of (shell_msg chan)
fun setSizeHints {x_dim=x_dim as DIM xdim,y_dim=y_dim as DIM ydim} = let
--- 72,79 ----
datatype shell_msg = Init | Destroy | Map of bool | Hints of hints
! (* modified by ddeboer; original:
! datatype shell = Shell of (shell_msg chan) *)
! datatype shell = Shell of (shell_msg chan * unit chan)
! (* end modified *)
fun setSizeHints {x_dim=x_dim as DIM xdim,y_dim=y_dim as DIM ydim} = let
***************
*** 135,141 ****
NONE => whiteOfScr scr
| SOME color => color
!
fun setProtocols win =
! setWMProtocols win [ICCC.internAtom (displayOf root) "WM_DELETE_WINDOW"]
fun init (hintlist,mapped) = let
--- 143,155 ----
NONE => whiteOfScr scr
| SOME color => color
!
! (* added by ddeboer: *)
! val delCh = CML.channel()
! (* end added *)
!
fun setProtocols win =
! (* modified, ddeboer, to include WM_TAKE_FOCUS. *)
! setWMProtocols win [(ICCC.internAtom (displayOf root) "WM_DELETE_WINDOW") (*,
! (ICCC.internAtom (displayOf root) "WM_TAKE_FOCUS") *)]
fun init (hintlist,mapped) = let
***************
*** 143,147 ****
val dfltsize = SIZE{wid=natDim x_dim,ht=natDim y_dim}
val (origin,size) = placement(rectopt,dfltsize)
! val (twin, inEnv) = crwin widget {
geom=WGEOM{pos=origin, sz=size, border=0},
backgrnd = color,
--- 157,163 ----
val dfltsize = SIZE{wid=natDim x_dim,ht=natDim y_dim}
val (origin,size) = placement(rectopt,dfltsize)
! (* modified by ddeboer; original:
! val (twin, inEnv) = crwin widget { ... *)
! val (twin, inEnv, inDelChOpt) = crwin widget {
geom=WGEOM{pos=origin, sz=size, border=0},
backgrnd = color,
***************
*** 187,199 ****
val (bnds as {x_dim, y_dim}) = boundsOf widget
in
! setWMProperties twin {
! argv = [],
! win_name = NONE,
! icon_name = NONE,
! size_hints = setSizeHints bnds,
! wm_hints = [],
! class_hints = NONE
! };
! resizeWin twin (SIZE{wid=natDim x_dim,ht=natDim y_dim})
end
| handleCO CO_KillReq = (destroyWin twin; zombie())
--- 203,215 ----
val (bnds as {x_dim, y_dim}) = boundsOf widget
in
! setWMProperties twin {
! argv = [],
! win_name = NONE,
! icon_name = NONE,
! size_hints = setSizeHints bnds,
! wm_hints = [],
! class_hints = NONE
! };
! resizeWin twin (SIZE{wid=natDim x_dim,ht=natDim y_dim})
end
| handleCO CO_KillReq = (destroyWin twin; zombie())
***************
*** 219,222 ****
--- 235,245 ----
(select [
wrap (myci, handleCI o msgBodyOf),
+ (* added by ddeboer: *)
+ (case inDelChOpt of
+ SOME inDelCh =>
+ wrap (recvEvt inDelCh,
+ fn () => (CML.send (delCh, ())))
+ | NONE => never),
+ (* end added *)
wrap (recvEvt reqChan, loop o (handleReq mapped)),
wrap (childco, handleCO)
***************
*** 243,252 ****
in
XDebug.xspawn ("shell", fn () => initLoop ([],true));
! Shell reqChan
end
local
! fun simple wdgt = createSimpleTopWin (screenOf(rootOf wdgt))
! fun trans w _ = createTransientWin w
in
fun mkShellAt r = mk_shell simple (SOME r)
--- 266,286 ----
in
XDebug.xspawn ("shell", fn () => initLoop ([],true));
! (* modified by ddeboer; original:
! Shell reqChan *)
! (Shell (reqChan, delCh))
end
local
! (* modified by ddeboer; original:
! fun simple wdgt = createSimpleTopWin (screenOf(rootOf wdgt))
! fun trans w _ = createTransientWin w*)
! fun simple wdgt g =
! let
! val (win,inEnv,delCh) = (createSimpleTopWin (screenOf(rootOf wdgt)) g)
! in (win,inEnv,SOME delCh) end
! fun trans w _ g =
! let
! val (win,inEnv) = createTransientWin w g
! in (win,inEnv,NONE) end (* end modified *)
in
fun mkShellAt r = mk_shell simple (SOME r)
***************
*** 254,258 ****
fun mkTransientShellAt r w = mk_shell (trans w) (SOME r)
fun mkTransientShell w = mk_shell (trans w) NONE
-
val attrs = [
(Attrs.attr_title, Attrs.AT_Str, Attrs.AV_NoValue),
--- 288,291 ----
***************
*** 268,281 ****
val color = Attrs.getColorOpt (attrs Attrs.attr_background)
val args = {win_name = win_name, icon_name = icon_name}
! in mk_shell simple pos (widget, color, args) end
end (* local *)
fun init (Shell ch) = send (ch, Init)
fun destroy (Shell ch) = send (ch, Destroy)
fun unmap (Shell ch) = send(ch, Map false)
fun map (Shell ch) = send(ch, Map true)
! fun setWMHints (Shell ch) arg = send (ch, Hints arg)
!
end (* local *)
end (* Shell *)
--- 301,322 ----
val color = Attrs.getColorOpt (attrs Attrs.attr_background)
val args = {win_name = win_name, icon_name = icon_name}
! in mk_shell simple pos (widget, color, args) end
end (* local *)
+ (* following modified by ddeboer; original:
fun init (Shell ch) = send (ch, Init)
fun destroy (Shell ch) = send (ch, Destroy)
fun unmap (Shell ch) = send(ch, Map false)
fun map (Shell ch) = send(ch, Map true)
! fun setWMHints (Shell ch) arg = send (ch, Hints arg) *)
! fun init (Shell (ch,dch)) = send (ch, Init)
! fun destroy (Shell (ch,dch)) = send (ch, Destroy)
! fun unmap (Shell (ch,dch)) = send(ch, Map false)
! fun map (Shell (ch,dch)) = send(ch, Map true)
! fun setWMHints (Shell (ch,dch)) arg = send (ch, Hints arg)
! fun deleteEvent (Shell (ch,dch)) = (recvEvt dch)
! (* end modified *)
!
end (* local *)
end (* Shell *)
-------------------------------------------------------
This SF.Net email is sponsored by xPML, a groundbreaking scripting language
that extends applications into web and mobile media. Attend the live webcast
and join the prime developer group breaking into this new coding territory!
http://sel.as-us.falkag.net/sel?cmd=lnk&kid=110944&bid=241720&dat=121642