CVS: sml-dist/src/eXene/lib/window color-server.sml,1.2,1.3 display.sml,1.2,1.3 toplevel-win.sml,1.2,1.3 window-env.sml,1.2,1.3 window-sig.sml,1.2,1.3 window.sml,1.2,1.3 winreg.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/lib/window
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv32471/lib/window
Modified Files:
color-server.sml display.sml toplevel-win.sml window-env.sml
window-sig.sml window.sml winreg.sml
Log Message:
merge Kansas changes to eXene into repository
Index: color-server.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/eXene/lib/window/color-server.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** color-server.sml 1 Jun 2000 18:33:40 -0000 1.2
--- color-server.sml 3 Mar 2006 03:33:15 -0000 1.3
***************
*** 155,159 ****
CML.send (req_ch, colorSpec);
case (CML.recv reply_ch)
! of ReplyError => raise NoColorCell
| (ReplyColor c) => c
(* end case *))
--- 155,160 ----
CML.send (req_ch, colorSpec);
case (CML.recv reply_ch)
! of ReplyError => raise NoColorCell
! (* ddeboer: NoColorCell raised here... So who wrote the comment at top?? <-- *)
| (ReplyColor c) => c
(* end case *))
Index: display.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/eXene/lib/window/display.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** display.sml 1 Jun 2000 18:33:40 -0000 1.2
--- display.sml 3 Mar 2006 03:33:15 -0000 1.3
***************
*** 13,126 ****
datatype display = DPY of {
! xdpy : xdisplay, (* *)
! screens : scr list,
! default_scr : scr,
! registry : registry, (* to register top-level windows *)
! font_server : font_server,
! atom_server : AtomServer.atom_server,
! property_server : PropertyServer.property_server,
! selection_server : SelectionServer.selection_server,
! keymap : keymap (* the keymap server *)
}
! and scr_depth = SCRDEPTH of { (* the GC-server and draw-master for a given *)
! (* depth of a screen *)
! depth : int,
! gc_server : gc_server, (* the GC server for this screen *)
! draw_cmd : draw_msg -> unit (* the draw-master connection for the root *)
! (* window of the screen *)
}
and scr = SCR of {
! xscr : xscreen,
! color_server : color_server, (* The color map server for this screen *)
! servers : scr_depth list, (* the GC-servers for the allowed depths *)
! (* of this screen *)
! root_servers : scr_depth
}
! and screen = SCREEN of { (* A screen handle for users *)
! dpy : display,
! scr : scr
! }
(* identity tests *)
fun sameDisplay (
! DPY{xdpy=XDPY{conn=c1, ...}, ...}, DPY{xdpy=XDPY{conn=c2, ...}, ...}
! ) =
! XIo.sameConn(c1, c2)
fun sameScreen (
! SCREEN{dpy=dpy1, scr=SCR{xscr=XSCR{id=id1, ...}, ...}},
! SCREEN{dpy=dpy2, scr=SCR{xscr=XSCR{id=id2, ...}, ...}}
! ) = ((id1 = id2) andalso sameDisplay(dpy1, dpy2))
fun openDisplay (dpyName, auth) = let
! val (xdpy as XDPY{default_scr, screens, conn, nextXId, ...}) =
! openXDisplay {dpyName=dpyName, auth=auth}
! val keymap = Keymap.createKeymap xdpy
! val atomServer = AtomServer.mkServer xdpy
! val (propCh, propServer) = PropertyServer.mkServer (xdpy, atomServer)
! val (selCh, selServer) = SelectionServer.mkServer xdpy
! val registry = createRegistry {
! dpy= xdpy, keymap= keymap, propEvtCh= propCh, selEvtCh= selCh
! }
! fun mkScrInfo (xscr as XSCR{root, root_visual, visualdepths, ...}) = let
! fun mkScrDepth (depth, gcServer) = let
! val configCh = CML.channel()
! val _ = CML.spawn(fn () => CML.send(configCh, DM_FirstExpose))
! in
! SCRDEPTH{
! depth = depth,
! gc_server = gcServer,
! draw_cmd =
! mkDM (CML.recvEvt configCh, gcServer, registry, conn)
! }
! end
! fun mkGCServers ([], l) = l
! | mkGCServers (vd :: r, l) = let
! val d = depthOfVisual vd
! fun mkServer () = let
! val xid = nextXId()
! in
! (* make a pixmap to serve as the witness drawable for
! * the GC server *)
! XIo.request conn (XRequest.encodeCreatePixmap{
! pixmap = xid, drawable = root,
! size = G.SIZE{wid=1, ht=1}, depth = d
! });
! mkScrDepth (d, mkGCServer (xdpy, xid))
! end
! fun look [] = mkServer() :: l
! | look (SCRDEPTH{depth, ...} :: r) =
! if (d = depth) then l else look r
! in
! mkGCServers (r, look l)
! end
! val rootServers = mkScrDepth(
! depthOfVisual root_visual, mkGCServer(xdpy, root))
! val servers = mkGCServers(visualdepths, [rootServers])
! val servers = mkGCServers([XProtTypes.Depth 1], servers)
! in
! SCR{
! xscr = xscr,
! color_server = ColorServer.mkColorServer (xdpy, xscr),
! servers = servers,
! root_servers = rootServers
! }
! end
! val scrInfoList = map mkScrInfo screens
! in
! DPY{
! xdpy = xdpy,
! screens = scrInfoList,
! default_scr = List.nth(scrInfoList, default_scr),
! registry = registry,
! atom_server = atomServer,
! font_server = mkFontServer xdpy,
! property_server = propServer,
! selection_server = selServer,
! keymap = keymap
! }
! end
(* X-server I/O *)
--- 13,126 ----
datatype display = DPY of {
! xdpy : xdisplay, (* *)
! screens : scr list,
! default_scr : scr,
! registry : registry, (* to register top-level windows *)
! font_server : font_server,
! atom_server : AtomServer.atom_server,
! property_server : PropertyServer.property_server,
! selection_server : SelectionServer.selection_server,
! keymap : keymap (* the keymap server *)
}
! and scr_depth = SCRDEPTH of { (* the GC-server and draw-master for a given *)
! (* depth of a screen *)
! depth : int,
! gc_server : gc_server, (* the GC server for this screen *)
! draw_cmd : draw_msg -> unit (* the draw-master connection for the root *)
! (* window of the screen *)
}
and scr = SCR of {
! xscr : xscreen,
! color_server : color_server, (* The color map server for this screen *)
! servers : scr_depth list, (* the GC-servers for the allowed depths *)
! (* of this screen *)
! root_servers : scr_depth
}
! and screen = SCREEN of { (* A screen handle for users *)
! dpy : display,
! scr : scr
! }
(* identity tests *)
fun sameDisplay (
! DPY{xdpy=XDPY{conn=c1, ...}, ...}, DPY{xdpy=XDPY{conn=c2, ...}, ...}
! ) =
! XIo.sameConn(c1, c2)
fun sameScreen (
! SCREEN{dpy=dpy1, scr=SCR{xscr=XSCR{id=id1, ...}, ...}},
! SCREEN{dpy=dpy2, scr=SCR{xscr=XSCR{id=id2, ...}, ...}}
! ) = ((id1 = id2) andalso sameDisplay(dpy1, dpy2))
fun openDisplay (dpyName, auth) = let
! val (xdpy as XDPY{default_scr, screens, conn, nextXId, ...}) =
! openXDisplay {dpyName=dpyName, auth=auth}
! val keymap = Keymap.createKeymap xdpy
! val atomServer = AtomServer.mkServer xdpy
! val (propCh, propServer) = PropertyServer.mkServer (xdpy, atomServer)
! val (selCh, selServer) = SelectionServer.mkServer xdpy
! val registry = createRegistry {
! dpy= xdpy, keymap= keymap, propEvtCh= propCh, selEvtCh= selCh
! }
! fun mkScrInfo (xscr as XSCR{root, root_visual, visualdepths, ...}) = let
! fun mkScrDepth (depth, gcServer) = let
! val configCh = CML.channel()
! val _ = CML.spawn(fn () => CML.send(configCh, DM_FirstExpose))
! in
! SCRDEPTH{
! depth = depth,
! gc_server = gcServer,
! draw_cmd =
! mkDM (CML.recvEvt configCh, gcServer, registry, conn)
! }
! end
! fun mkGCServers ([], l) = l
! | mkGCServers (vd :: r, l) = let
! val d = depthOfVisual vd
! fun mkServer () = let
! val xid = nextXId()
! in
! (* make a pixmap to serve as the witness drawable for
! * the GC server *)
! XIo.request conn (XRequest.encodeCreatePixmap{
! pixmap = xid, drawable = root,
! size = G.SIZE{wid=1, ht=1}, depth = d
! });
! mkScrDepth (d, mkGCServer (xdpy, xid))
! end
! fun look [] = mkServer() :: l
! | look (SCRDEPTH{depth, ...} :: r) =
! if (d = depth) then l else look r
! in
! mkGCServers (r, look l)
! end
! val rootServers = mkScrDepth(
! depthOfVisual root_visual, mkGCServer(xdpy, root))
! val servers = mkGCServers(visualdepths, [rootServers])
! val servers = mkGCServers([XProtTypes.Depth 1], servers)
! in
! SCR{
! xscr = xscr,
! color_server = ColorServer.mkColorServer (xdpy, xscr),
! servers = servers,
! root_servers = rootServers
! }
! end
! val scrInfoList = map mkScrInfo screens
! in
! DPY{
! xdpy = xdpy,
! screens = scrInfoList,
! default_scr = List.nth(scrInfoList, default_scr),
! registry = registry,
! atom_server = atomServer,
! font_server = mkFontServer xdpy,
! property_server = propServer,
! selection_server = selServer,
! keymap = keymap
! }
! end
(* X-server I/O *)
***************
*** 157,169 ****
fun defaultScreenOf (dpy as DPY{default_scr, ...}) =
! SCREEN{dpy = dpy, scr = default_scr}
fun screensOf (dpy as DPY{screens, ...}) =
! map (fn s => SCREEN{dpy = dpy, scr = s}) screens
fun ringBell dpy percent =
! dpyRequest dpy (XRequest.encodeBell{
! percent = Int.min(100, Int.max(~100, percent))
! })
--- 157,169 ----
fun defaultScreenOf (dpy as DPY{default_scr, ...}) =
! SCREEN{dpy = dpy, scr = default_scr}
fun screensOf (dpy as DPY{screens, ...}) =
! map (fn s => SCREEN{dpy = dpy, scr = s}) screens
fun ringBell dpy percent =
! dpyRequest dpy (XRequest.encodeBell{
! percent = Int.min(100, Int.max(~100, percent))
! })
***************
*** 171,201 ****
fun colorOfScr (SCREEN{scr=SCR{color_server, ...}, ...}) =
! ColorServer.getColor color_server
fun blackOfScr (SCREEN{scr=SCR{color_server, ...}, ...}) =
! ColorServer.blackOf color_server
fun whiteOfScr (SCREEN{scr=SCR{color_server, ...}, ...}) =
! ColorServer.whiteOf color_server
fun displayOfScr (SCREEN{dpy, ...}) = dpy
fun sizeOfScr (SCREEN{scr=SCR{xscr=XSCR{sz_in_pixels, ...}, ...}, ...}) =
! sz_in_pixels
fun sizeMMOfScr (SCREEN{scr=SCR{xscr=XSCR{sz_in_mm, ...}, ...}, ...}) = sz_in_mm
fun depthOfScr (SCREEN{scr=SCR{xscr=XSCR{root_visual, ...}, ...}, ...}) =
! depthOfVisual root_visual
fun displayClassOfScr (SCREEN{scr=SCR{xscr=XSCR{root_visual, ...}, ...}, ...}) = (
! case (displayClassOfVisual root_visual)
! of (SOME c) => c
! | _ => MLXError.impossible "[Display.displayClassOfScr: bogus root visual]")
(* extract the GC server for the given depth *)
fun serversOfScrDepth (SCREEN{scr=SCR{servers, ...}, ...}, d) = let
! fun f [] = MLXError.xerror "invalid depth for screen"
! | f ((sd as SCRDEPTH{depth, ...}) :: r) =
! if (depth = d) then sd else (f r)
! in
! f servers
! end
end (* local open ... *)
--- 171,212 ----
fun colorOfScr (SCREEN{scr=SCR{color_server, ...}, ...}) =
! ColorServer.getColor color_server
fun blackOfScr (SCREEN{scr=SCR{color_server, ...}, ...}) =
! ColorServer.blackOf color_server
fun whiteOfScr (SCREEN{scr=SCR{color_server, ...}, ...}) =
! ColorServer.whiteOf color_server
fun displayOfScr (SCREEN{dpy, ...}) = dpy
+ (* Additions by ddeboer, May 2004.
+ * Dusty deBoer, KSU CIS 705, Spring 2004. *)
+
+ (* return the root window of a screen.
+ * needed in obtaining strings from xrdb, as they are stored in a
+ * property of the root window.
+ *)
+ fun rootWinOfScr (SCREEN{scr=SCR{xscr=XSCR{root, ... } , ...}, ...}) = root
+
+ (* end additions by ddeboer *)
+
fun sizeOfScr (SCREEN{scr=SCR{xscr=XSCR{sz_in_pixels, ...}, ...}, ...}) =
! sz_in_pixels
fun sizeMMOfScr (SCREEN{scr=SCR{xscr=XSCR{sz_in_mm, ...}, ...}, ...}) = sz_in_mm
fun depthOfScr (SCREEN{scr=SCR{xscr=XSCR{root_visual, ...}, ...}, ...}) =
! depthOfVisual root_visual
fun displayClassOfScr (SCREEN{scr=SCR{xscr=XSCR{root_visual, ...}, ...}, ...}) = (
! case (displayClassOfVisual root_visual)
! of (SOME c) => c
! | _ => MLXError.impossible "[Display.displayClassOfScr: bogus root visual]")
(* extract the GC server for the given depth *)
fun serversOfScrDepth (SCREEN{scr=SCR{servers, ...}, ...}, d) = let
! fun f [] = MLXError.xerror "invalid depth for screen"
! | f ((sd as SCRDEPTH{depth, ...}) :: r) =
! if (depth = d) then sd else (f r)
! in
! f servers
! end
end (* local open ... *)
Index: toplevel-win.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/eXene/lib/window/toplevel-win.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** toplevel-win.sml 1 Jun 2000 18:33:40 -0000 1.2
--- toplevel-win.sml 3 Mar 2006 03:33:15 -0000 1.3
***************
*** 10,15 ****
val mkTopLevelWinEnv :
! (Display.screen * Display.scr_depth * XProtTypes.win_id)
! -> (WindowEnv.in_env * DrawTypes.window)
end = struct
--- 10,17 ----
val mkTopLevelWinEnv :
! (Display.screen * Display.scr_depth * XProtTypes.win_id)
! (* modified ddeboer, Jul 2004; original:
! -> (WindowEnv.in_env * DrawTypes.window) *)
! -> (WindowEnv.in_env * DrawTypes.window * unit CML.chan)
end = struct
***************
*** 19,170 ****
(* The top-level window (usually a shell widget) should never pass on CO message *)
fun mkCOThread coEvt = (
! spawn (fn () => (
! sync coEvt; MLXError.impossible("[TopLevelWin: unexpected CO message]"))))
fun mkRouter (DPY{keymap, ...}, xevtEvt, dmConfigCh, topWin) = let
! val mkDescendantWin = let
! val WIN{scr, scr_depth, draw_cmd, ...} = topWin
! in
! fn id => WIN{id=id, scr=scr, scr_depth=scr_depth, draw_cmd=draw_cmd}
! end
! val (inEnv, outEnv) = WindowEnv.createWinEnv()
! val (routeCI, routeK, routeM) = let
! val OutEnv{ci, k, m, co} = outEnv
! in
! mkCOThread co;
! (ci, k, m)
! end
! val lookupKey = Keymap.lookupKeysym keymap
! local val seqn = ref 0 in
! fun wrapMsg (path, msg) = let val n = !seqn
! in
! seqn := n+1;
! AMSG{path=path, seqn=n, msg=msg}
! end
! end
! fun doKey (mkMsg, keyEvt) = routeK (mkMsg (lookupKey keyEvt))
! fun doDownBut (path, info : button_xevtinfo) = let
! val {button, event_pt, root_pt, time, mbut_state, ...} = info
! val msg = if (KeyBut.mbutAllClr mbut_state)
! then MOUSE_FirstDown{
! but = button,
! pt = event_pt,
! scr_pt = root_pt,
! time = time
! }
! else MOUSE_Down{
! but = button,
! pt = event_pt,
! scr_pt = root_pt,
! (* invert button so that the state is post-transition *)
! state = KeyBut.invertMBut(mbut_state, button),
! time = time
! }
! in
! routeM (wrapMsg (path, msg))
! end
! fun doUpBut (path, info : button_xevtinfo) = let
! val {button, event_pt, root_pt, time, mbut_state, ...} = info
! val state = KeyBut.invertMBut(mbut_state, button)
! val msg = if (KeyBut.mbutAllClr state)
! then MOUSE_LastUp{
! but = button,
! pt = event_pt,
! scr_pt = root_pt,
! time = time
! }
! else MOUSE_Up{
! but = button,
! pt = event_pt,
! scr_pt = root_pt,
! state = state,
! time = time
! }
! in
! routeM (wrapMsg (path, msg))
! end
! val alwaysUnit = alwaysEvt()
! fun doConfigSync (path, configMsg) = wrap (alwaysUnit, fn () => (
! sync (routeM (wrapMsg (path, MOUSE_ConfigSync)));
! sync (routeK (wrapMsg (path, KEY_ConfigSync)));
! sync (routeCI (wrapMsg (path, configMsg)))))
! fun routeXEvt (path, KeyPressXEvt arg) =
! doKey (fn x => wrapMsg (path, KEY_Press x), arg)
! | routeXEvt (path, KeyReleaseXEvt arg) =
! doKey (fn x => wrapMsg (path, KEY_Release x), arg)
! | routeXEvt (path, ButtonPressXEvt arg) = doDownBut (path, arg)
! | routeXEvt (path, ButtonReleaseXEvt arg) = doUpBut (path, arg)
! | routeXEvt (path, MotionNotifyXEvt{event_pt, root_pt, time, ...}) =
! routeM (wrapMsg (path,
! MOUSE_Motion{pt=event_pt, scr_pt=root_pt, time=time}))
! | routeXEvt (path, EnterNotifyXEvt{event_pt, root_pt, time, ...}) =
! routeM (wrapMsg (path,
! MOUSE_Enter{pt=event_pt, scr_pt=root_pt, time=time}))
! | routeXEvt (path, LeaveNotifyXEvt{event_pt, root_pt, time, ...}) =
! routeM (wrapMsg (path,
! MOUSE_Leave{pt=event_pt, scr_pt=root_pt, time=time}))
(*******
! | routeXEvt (_, FocusInXEvt{...}) = ()
! | routeXEvt (_, FocusOutXEvt{...}) = ()
! | routeXEvt (_, KeymapNotifyXEvt{...}) = ()
******)
! | routeXEvt (path, ExposeXEvt{rects, ...}) =
! routeCI(wrapMsg (path, CI_Redraw rects))
(*******
! | routeXEvt (_, GraphicsExposeXEvt{...}) = ()
! | routeXEvt (_, NoExposeXEvt{...}) = ()
! | routeXEvt (_, VisibilityNotifyXEvt _) = ()
******)
! | routeXEvt (path, CreateNotifyXEvt{parent, window, ...}) =
! doConfigSync (path, CI_ChildBirth(mkDescendantWin window))
! | routeXEvt (path, DestroyNotifyXEvt{window, event, ...}) =
! if (window = event)
! then routeCI (wrapMsg (path, CI_OwnDeath))
! else doConfigSync (path, CI_ChildDeath(mkDescendantWin window))
! | routeXEvt (WinRegistry.PathDst _, UnmapNotifyXEvt _) =
! wrap (alwaysUnit, fn () => send (dmConfigCh, DrawMaster.DM_Unmap))
! | routeXEvt (_, UnmapNotifyXEvt _) = alwaysUnit
! | routeXEvt (WinRegistry.PathDst _, MapNotifyXEvt _) =
! wrap (alwaysUnit, fn () => send (dmConfigCh, DrawMaster.DM_Map))
! | routeXEvt (_, MapNotifyXEvt _) = alwaysUnit
(*******
! | routeXEvt (_, MapRequestXEvt{...}) = ()
! | routeXEvt (_, ReparentNotifyXEvt{...}) = ()
******)
! | routeXEvt (path, ConfigureNotifyXEvt{rect, ...}) =
! routeCI (wrapMsg (path, CI_Resize rect))
(*******
! | routeXEvt (_, ConfigureRequestXEvt{...}) = ()
! | routeXEvt (_, GravityNotifyXEvt{...}) = ()
! | routeXEvt (_, ResizeRequestXEvt{...}) = ()
! | routeXEvt (_, CirculateNotifyXEvt{...}) = ()
! | routeXEvt (_, CirculateRequestXEvt{...}) = ()
! | routeXEvt (_, PropertyNotifyXEvt{...}) = ()
! | routeXEvt (_, SelectionClearXEvt{...}) = ()
! | routeXEvt (_, SelectionRequestXEvt{...}) = ()
! | routeXEvt (_, SelectionNotifyXEvt{...}) = ()
! | routeXEvt (_, ColormapNotifyXEvt{...}) = ()
! | routeXEvt (_, ClientMessageXEvt{...}) = ()
******)
! | routeXEvt (_, evt) = wrap (alwaysUnit, fn () => (
! XDebug.trace(XDebug.topTM, fn () => [
! "[TopLvl.routeXEvt: unexpected event ", (XPrint.xevtName evt), "]\n"
! ])))
(* +DEBUG *)
! fun debugRouter (res as (_, xevt)) = (
! XDebug.trace(XDebug.topTM, fn () => [
! "TopLevelWin.router: get ", XPrint.xevtName xevt, "\n"
! ]);
! res)
(* -DEBUG *)
! fun router ([], []) = router ([debugRouter(sync xevtEvt)], [])
! | router ([], l) = router (rev l, [])
! | router (front as (msgOut::r), rear) = select [
! wrap (xevtEvt, fn res => router(front, (debugRouter res)::rear)),
! wrap (routeXEvt msgOut, fn () => router(r, rear))
! ]
! in
! (inEnv, fn pending => router (pending, []))
! end (* mkRouter *)
--- 21,190 ----
(* The top-level window (usually a shell widget) should never pass on CO message *)
fun mkCOThread coEvt = (
! spawn (fn () => (
! sync coEvt; MLXError.impossible("[TopLevelWin: unexpected CO message]"))))
fun mkRouter (DPY{keymap, ...}, xevtEvt, dmConfigCh, topWin) = let
! val mkDescendantWin = let
! val WIN{scr, scr_depth, draw_cmd, ...} = topWin
! in
! fn id => WIN{id=id, scr=scr, scr_depth=scr_depth, draw_cmd=draw_cmd}
! end
! val (inEnv, outEnv) = WindowEnv.createWinEnv()
! val (routeCI, routeK, routeM) = let
! val OutEnv{ci, k, m, co} = outEnv
! in
! mkCOThread co;
! (ci, k, m)
! end
! val lookupKey = Keymap.lookupKeysym keymap
! local val seqn = ref 0 in
! fun wrapMsg (path, msg) = let val n = !seqn
! in
! seqn := n+1;
! AMSG{path=path, seqn=n, msg=msg}
! end
! end
! (* added ddeboer: add a channel by which client message events may be communicated
! * to the application. *)
! val delCh = CML.channel()
! (* end added ddeboer *)
! fun doKey (mkMsg, keyEvt) = routeK (mkMsg (lookupKey keyEvt))
! fun doDownBut (path, info : button_xevtinfo) = let
! val {button, event_pt, root_pt, time, mbut_state, ...} = info
! val msg = if (KeyBut.mbutAllClr mbut_state)
! then MOUSE_FirstDown{
! but = button,
! pt = event_pt,
! scr_pt = root_pt,
! time = time
! }
! else MOUSE_Down{
! but = button,
! pt = event_pt,
! scr_pt = root_pt,
! (* invert button so that the state is post-transition *)
! state = KeyBut.invertMBut(mbut_state, button),
! time = time
! }
! in
! routeM (wrapMsg (path, msg))
! end
! fun doUpBut (path, info : button_xevtinfo) = let
! val {button, event_pt, root_pt, time, mbut_state, ...} = info
! val state = KeyBut.invertMBut(mbut_state, button)
! val msg = if (KeyBut.mbutAllClr state)
! then MOUSE_LastUp{
! but = button,
! pt = event_pt,
! scr_pt = root_pt,
! time = time
! }
! else MOUSE_Up{
! but = button,
! pt = event_pt,
! scr_pt = root_pt,
! state = state,
! time = time
! }
! in
! routeM (wrapMsg (path, msg))
! end
! val alwaysUnit = alwaysEvt()
! fun doConfigSync (path, configMsg) = wrap (alwaysUnit, fn () => (
! sync (routeM (wrapMsg (path, MOUSE_ConfigSync)));
! sync (routeK (wrapMsg (path, KEY_ConfigSync)));
! sync (routeCI (wrapMsg (path, configMsg)))))
! fun routeXEvt (path, KeyPressXEvt arg) =
! doKey (fn x => wrapMsg (path, KEY_Press x), arg)
! | routeXEvt (path, KeyReleaseXEvt arg) =
! doKey (fn x => wrapMsg (path, KEY_Release x), arg)
! | routeXEvt (path, ButtonPressXEvt arg) = doDownBut (path, arg)
! | routeXEvt (path, ButtonReleaseXEvt arg) = doUpBut (path, arg)
! | routeXEvt (path, MotionNotifyXEvt{event_pt, root_pt, time, ...}) =
! routeM (wrapMsg (path,
! MOUSE_Motion{pt=event_pt, scr_pt=root_pt, time=time}))
! | routeXEvt (path, EnterNotifyXEvt{event_pt, root_pt, time, ...}) =
! routeM (wrapMsg (path,
! MOUSE_Enter{pt=event_pt, scr_pt=root_pt, time=time}))
! | routeXEvt (path, LeaveNotifyXEvt{event_pt, root_pt, time, ...}) =
! routeM (wrapMsg (path,
! MOUSE_Leave{pt=event_pt, scr_pt=root_pt, time=time}))
(*******
! | routeXEvt (_, FocusInXEvt{...}) = ()
! | routeXEvt (_, FocusOutXEvt{...}) = ()
! | routeXEvt (_, KeymapNotifyXEvt{...}) = ()
******)
! | routeXEvt (path, ExposeXEvt{rects, ...}) =
! routeCI(wrapMsg (path, CI_Redraw rects))
(*******
! | routeXEvt (_, GraphicsExposeXEvt{...}) = ()
! | routeXEvt (_, NoExposeXEvt{...}) = ()
! | routeXEvt (_, VisibilityNotifyXEvt _) = ()
******)
! | routeXEvt (path, CreateNotifyXEvt{parent, window, ...}) =
! doConfigSync (path, CI_ChildBirth(mkDescendantWin window))
! | routeXEvt (path, DestroyNotifyXEvt{window, event, ...}) =
! if (window = event)
! then routeCI (wrapMsg (path, CI_OwnDeath))
! else doConfigSync (path, CI_ChildDeath(mkDescendantWin window))
! | routeXEvt (WinRegistry.PathDst _, UnmapNotifyXEvt _) =
! wrap (alwaysUnit, fn () => send (dmConfigCh, DrawMaster.DM_Unmap))
! | routeXEvt (_, UnmapNotifyXEvt _) = alwaysUnit
! | routeXEvt (WinRegistry.PathDst _, MapNotifyXEvt _) =
! wrap (alwaysUnit, fn () => send (dmConfigCh, DrawMaster.DM_Map))
! | routeXEvt (_, MapNotifyXEvt _) = alwaysUnit
(*******
! | routeXEvt (_, MapRequestXEvt{...}) = ()
! | routeXEvt (_, ReparentNotifyXEvt{...}) = ()
******)
! | routeXEvt (path, ConfigureNotifyXEvt{rect, ...}) =
! routeCI (wrapMsg (path, CI_Resize rect))
(*******
! | routeXEvt (_, ConfigureRequestXEvt{...}) = ()
! | routeXEvt (_, GravityNotifyXEvt{...}) = ()
! | routeXEvt (_, ResizeRequestXEvt{...}) = ()
! | routeXEvt (_, CirculateNotifyXEvt{...}) = ()
! | routeXEvt (_, CirculateRequestXEvt{...}) = ()
! | routeXEvt (_, PropertyNotifyXEvt{...}) = ()
! | routeXEvt (_, SelectionClearXEvt{...}) = ()
! | routeXEvt (_, SelectionRequestXEvt{...}) = ()
! | routeXEvt (_, SelectionNotifyXEvt{...}) = ()
! | routeXEvt (_, ColormapNotifyXEvt{...}) = ()
******)
! (****** modification, ddeboer, Jul 2004: route this event when delete.
! from ..protocol/xevttypes.sml:
! ... ClientMessageXEvt of {
! window : win_id,
! typ : atom, the type of the message
! value : raw_data the message value
! }
! *)
! | routeXEvt (_, ClientMessageXEvt{window,typ,...}) =
! wrap (alwaysUnit, fn () =>
! (* (if typ=(ICCC.internAtom dpy "WM_DELETE_WINDOW")
! then *) (CML.send (delCh, ())) (* else () )*) )
! (** end mod ****)
! | routeXEvt (_, evt) = wrap (alwaysUnit, fn () => (
! XDebug.trace(XDebug.topTM, fn () => [
! "[TopLvl.routeXEvt: unexpected event ", (XPrint.xevtName evt), "]\n"
! ])))
(* +DEBUG *)
! fun debugRouter (res as (_, xevt)) = (
! XDebug.trace(XDebug.topTM, fn () => [
! "TopLevelWin.router: get ", XPrint.xevtName xevt, "\n"
! ]);
! res)
(* -DEBUG *)
! fun router ([], []) = router ([debugRouter(sync xevtEvt)], [])
! | router ([], l) = router (rev l, [])
! | router (front as (msgOut::r), rear) = select [
! wrap (xevtEvt, fn res => router(front, (debugRouter res)::rear)),
! wrap (routeXEvt msgOut, fn () => router(r, rear))
! ]
! in
! (* modified ddeboer; Jul 2004: original: *
! (inEnv, fn pending => router (pending, [])) *)
! (inEnv, (fn pending => router (pending, [])), delCh)
! end (* mkRouter *)
***************
*** 174,201 ****
fun mkTopLevelWinEnv (
scr as SCREEN{dpy, ...}, scr_depth as SCRDEPTH{gc_server, ...}, winId
! ) = let
! val DPY{xdpy as XDPY{conn, ...}, registry, ...} = dpy
! val dmConfigCh = channel()
! val dm = DrawMaster.mkDM (recvEvt dmConfigCh, gc_server, registry, conn)
! val xevtEvt = WinRegistry.logTopWin(registry, winId)
! val topWin = WIN{id=winId, scr=scr, scr_depth=scr_depth, draw_cmd=dm}
! val (inEnv, router) = mkRouter (dpy, xevtEvt, dmConfigCh, topWin)
! fun initRouter () = let
! fun loop buf = (case sync xevtEvt
! of (arg as (_, ExposeXEvt _)) => (
(* DEBUG *) XDebug.trace(XDebug.topTM, fn () => ["initRouter: ExposeEvt\n"]);
! send(dmConfigCh, DrawMaster.DM_FirstExpose);
(* DEBUG *) XDebug.trace(XDebug.topTM, fn () => ["initRouter: DM_FirstExpose sent\n"]);
! (arg :: buf))
! | arg => loop(arg :: buf))
! in
(* DEBUG *) XDebug.trace(XDebug.topTM, fn () => ["initRouter: winId = ", XPrint.xidToString winId, "\n"]);
! router (rev (loop []))
! ;(* DEBUG *) XDebug.trace(XDebug.topTM, fn () => ["initRouter: go\n"])
! end
! in
! XDebug.xspawn("TopLevelWin.router", initRouter);
! (inEnv, topWin)
! end (* mkTopLevelWinEnv *)
end (* TopLevelWin *)
--- 194,225 ----
fun mkTopLevelWinEnv (
scr as SCREEN{dpy, ...}, scr_depth as SCRDEPTH{gc_server, ...}, winId
! ) = let
! val DPY{xdpy as XDPY{conn, ...}, registry, ...} = dpy
! val dmConfigCh = channel()
! val dm = DrawMaster.mkDM (recvEvt dmConfigCh, gc_server, registry, conn)
! val xevtEvt = WinRegistry.logTopWin(registry, winId)
! val topWin = WIN{id=winId, scr=scr, scr_depth=scr_depth, draw_cmd=dm}
! (* modified ddeboer, Jul 2004; original: *
! val (inEnv, router) = mkRouter (dpy, xevtEvt, dmConfigCh, topWin) *)
! val (inEnv, router, delCh) = mkRouter (dpy, xevtEvt, dmConfigCh, topWin)
! fun initRouter () = let
! fun loop buf = (case sync xevtEvt
! of (arg as (_, ExposeXEvt _)) => (
(* DEBUG *) XDebug.trace(XDebug.topTM, fn () => ["initRouter: ExposeEvt\n"]);
! send(dmConfigCh, DrawMaster.DM_FirstExpose);
(* DEBUG *) XDebug.trace(XDebug.topTM, fn () => ["initRouter: DM_FirstExpose sent\n"]);
! (arg :: buf))
! | arg => loop(arg::buf))
! in
(* DEBUG *) XDebug.trace(XDebug.topTM, fn () => ["initRouter: winId = ", XPrint.xidToString winId, "\n"]);
! router (rev (loop []));
! (* DEBUG *) XDebug.trace(XDebug.topTM, fn () => ["initRouter: go\n"])
! end
! in
! XDebug.xspawn("TopLevelWin.router", initRouter);
! (* modified ddeboer; Jul 2004: original: *
! (inEnv, topWin) *)
! (inEnv, topWin, delCh)
! end (* mkTopLevelWinEnv *)
end (* TopLevelWin *)
Index: window-env.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/eXene/lib/window/window-env.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** window-env.sml 1 Jun 2000 18:33:40 -0000 1.2
--- window-env.sml 3 Mar 2006 03:33:15 -0000 1.3
***************
*** 16,38 ****
local
type motion_trans = {
! pt : point, (* the mouse position in window coords *)
! scr_pt : point, (* the mouse position in screen coords *)
! time : XTime.time
! }
type button_up_down = {
! but : mbutton, (* the button that is in transition *)
! pt : point, (* the mouse position in window coords *)
! scr_pt : point, (* the mouse position in screen coords *)
(** NOTE: we may also want the modifier-key state **)
! time : XTime.time
! }
type button_trans = {
! but : mbutton, (* the button that is in transition *)
! pt : point, (* the mouse position in window coords *)
! scr_pt : point, (* the mouse position in screen coords *)
! state : mbutton_state, (* list of buttons that are pressed *)
(** NOTE: we may also want the modifier-key state **)
! time : XTime.time
! }
in
datatype mouse_msg
--- 16,38 ----
local
type motion_trans = {
! pt : point, (* the mouse position in window coords *)
! scr_pt : point, (* the mouse position in screen coords *)
! time : XTime.time
! }
type button_up_down = {
! but : mbutton, (* the button that is in transition *)
! pt : point, (* the mouse position in window coords *)
! scr_pt : point, (* the mouse position in screen coords *)
(** NOTE: we may also want the modifier-key state **)
! time : XTime.time
! }
type button_trans = {
! but : mbutton, (* the button that is in transition *)
! pt : point, (* the mouse position in window coords *)
! scr_pt : point, (* the mouse position in screen coords *)
! state : mbutton_state, (* list of buttons that are pressed *)
(** NOTE: we may also want the modifier-key state **)
! time : XTime.time
! }
in
datatype mouse_msg
***************
*** 65,127 ****
(* An addressed message (with sequence number) *)
datatype 'a addr_msg = AMSG of {
! path : path,
! seqn : int,
! msg : 'a
}
! datatype in_env = InEnv of { (* this is the window's view of its *)
! (* environment *)
! m : mouse_msg addr_msg event,
! k : kbd_msg addr_msg event,
! ci : cmd_in addr_msg event,
! co : cmd_out -> unit event
}
! datatype out_env = OutEnv of { (* this is the paren't view of one of its *)
! (* children's environment. *)
! m : mouse_msg addr_msg -> unit event,
! k : kbd_msg addr_msg -> unit event,
! ci : cmd_in addr_msg -> unit event,
! co : cmd_out event
}
(* createWinEnv : unit -> (in_env * out_env) *)
fun createWinEnv () = let
! val mCh = channel() and kCh = channel()
! val ciCh = channel() and coCh = channel()
! fun outEvt ch x = sendEvt(ch, x)
! in
! (InEnv{
! m = recvEvt mCh, k = recvEvt kCh, ci = recvEvt ciCh, co = outEvt coCh
! },
! OutEnv{
! m = outEvt mCh, k = outEvt kCh, ci = outEvt ciCh, co = recvEvt coCh
! })
! end
datatype 'a next_win = Here of 'a | ToChild of 'a addr_msg
fun stripMsg (AMSG{path=PathDst _, msg, ...}) = Here msg
| stripMsg (AMSG{path=Path(_, p), seqn, msg}) =
! ToChild(AMSG{path=p, seqn=seqn, msg=msg})
local
fun nextWin (AMSG{path=PathDst dst, ...}) = dst
! | nextWin (AMSG{path=Path(w, _), ...}) = w
in
fun toWindow (amsg, WIN{id, ...}) = ((nextWin amsg) = id)
fun addrLookup map = let
! val lookup = HashWindow.lookupWinId map
! in
! fn amsg => lookup (nextWin amsg)
! end
exception NoMatchWin
fun whichWindow wins amsg = let
! val w = nextWin amsg
! fun find [] = raise NoMatchWin
! | find ((WIN{id, ...}, x) :: r) = if (id = w) then x else (find r)
! in
! find wins
! end
fun beforeMsg (AMSG{seqn=a, ...}, AMSG{seqn=b, ...}) = (a < b)
--- 65,127 ----
(* An addressed message (with sequence number) *)
datatype 'a addr_msg = AMSG of {
! path : path,
! seqn : int,
! msg : 'a
}
! datatype in_env = InEnv of { (* this is the window's view of its *)
! (* environment *)
! m : mouse_msg addr_msg event,
! k : kbd_msg addr_msg event,
! ci : cmd_in addr_msg event,
! co : cmd_out -> unit event
}
! datatype out_env = OutEnv of { (* this is the paren't view of one of its *)
! (* children's environment. *)
! m : mouse_msg addr_msg -> unit event,
! k : kbd_msg addr_msg -> unit event,
! ci : cmd_in addr_msg -> unit event,
! co : cmd_out event
}
(* createWinEnv : unit -> (in_env * out_env) *)
fun createWinEnv () = let
! val mCh = channel() and kCh = channel()
! val ciCh = channel() and coCh = channel()
! fun outEvt ch x = sendEvt(ch, x)
! in
! (InEnv{
! m = recvEvt mCh, k = recvEvt kCh, ci = recvEvt ciCh, co = outEvt coCh
! },
! OutEnv{
! m = outEvt mCh, k = outEvt kCh, ci = outEvt ciCh, co = recvEvt coCh
! })
! end
datatype 'a next_win = Here of 'a | ToChild of 'a addr_msg
fun stripMsg (AMSG{path=PathDst _, msg, ...}) = Here msg
| stripMsg (AMSG{path=Path(_, p), seqn, msg}) =
! ToChild(AMSG{path=p, seqn=seqn, msg=msg})
local
fun nextWin (AMSG{path=PathDst dst, ...}) = dst
! | nextWin (AMSG{path=Path(w, _), ...}) = w
in
fun toWindow (amsg, WIN{id, ...}) = ((nextWin amsg) = id)
fun addrLookup map = let
! val lookup = HashWindow.lookupWinId map
! in
! fn amsg => lookup (nextWin amsg)
! end
exception NoMatchWin
fun whichWindow wins amsg = let
! val w = nextWin amsg
! fun find [] = raise NoMatchWin
! | find ((WIN{id, ...}, x) :: r) = if (id = w) then x else (find r)
! in
! find wins
! end
fun beforeMsg (AMSG{seqn=a, ...}, AMSG{seqn=b, ...}) = (a < b)
***************
*** 143,152 ****
local
fun ignore evt = let
! val ignoreEvt = wrap (alwaysEvt (), fn () => raise SyncOnIgnoredStream)
! fun loop () = (sync evt; loop())
! in
! spawn (fn () => ((loop ()) handle _ => ()));
! ignoreEvt
! end
in
fun ignoreMouse (InEnv{m, k, ci, co}) = InEnv{m=ignore m, k=k, ci=ci, co=co}
--- 143,152 ----
local
fun ignore evt = let
! val ignoreEvt = wrap (alwaysEvt (), fn () => raise SyncOnIgnoredStream)
! fun loop () = (sync evt; loop())
! in
! spawn (fn () => ((loop ()) handle _ => ()));
! ignoreEvt
! end
in
fun ignoreMouse (InEnv{m, k, ci, co}) = InEnv{m=ignore m, k=k, ci=ci, co=co}
***************
*** 154,158 ****
fun ignoreInput (InEnv{m, k, ci, co}) = InEnv{m=ignore m, k=ignore k, ci=ci, co=co}
fun ignoreAll (InEnv{m, k, ci, co}) =
! InEnv{m=ignore m, k=ignore k, ci=ignore ci, co=co}
end (* local *)
--- 154,158 ----
fun ignoreInput (InEnv{m, k, ci, co}) = InEnv{m=ignore m, k=ignore k, ci=ci, co=co}
fun ignoreAll (InEnv{m, k, ci, co}) =
! InEnv{m=ignore m, k=ignore k, ci=ignore ci, co=co}
end (* local *)
***************
*** 164,179 ****
*)
fun whileMouseState pred (initState, m) = let
! fun loop state = (
! if (pred state)
! then (case (sync m)
! of (MOUSE_FirstDown{but, ...}) => loop (KeyBut.mkButState [but])
! | (MOUSE_LastUp _) => loop (MBState 0w0)
! | (MOUSE_Down{state, ...}) => loop state
! | (MOUSE_Up{state, ...}) => loop state
! | _ => loop state)
! else ())
! in
! loop initState
! end
end (* local *)
--- 164,179 ----
*)
fun whileMouseState pred (initState, m) = let
! fun loop state = (
! if (pred state)
! then (case (sync m)
! of (MOUSE_FirstDown{but, ...}) => loop (KeyBut.mkButState [but])
! | (MOUSE_LastUp _) => loop (MBState 0w0)
! | (MOUSE_Down{state, ...}) => loop state
! | (MOUSE_Up{state, ...}) => loop state
! | _ => loop state)
! else ())
! in
! loop initState
! end
end (* local *)
Index: window-sig.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/eXene/lib/window/window-sig.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** window-sig.sml 1 Jun 2000 18:33:40 -0000 1.2
--- window-sig.sml 3 Mar 2006 03:33:15 -0000 1.3
***************
*** 38,74 ****
(**** OBSOLETE ****
val allocSimpleTopWin : Display.screen
! -> (window * WindowEnv.in_env * ({
! geom : Geometry.win_geom,
! border : ColorServer.color,
! backgrnd : ColorServer.color
! } -> window))
val allocSimpleSubwin : window
! -> (window * ({
! geom : Geometry.win_geom,
! border : ColorServer.color option,
! backgrnd : ColorServer.color option
! } -> window))
**** OBSOLETE ****)
val createSimpleTopWin : Display.screen -> {
! geom : Geometry.win_geom,
! border : ColorServer.color,
! backgrnd : ColorServer.color
! } -> (window * WindowEnv.in_env)
val createSimpleSubwin : window -> {
! geom : Geometry.win_geom,
! border : ColorServer.color option,
! backgrnd : ColorServer.color option
! } -> window
val createTransientWin : window -> {
! geom : Geometry.win_geom,
! border : ColorServer.color,
! backgrnd : ColorServer.color
! } -> (window * WindowEnv.in_env)
val createSimplePopupWin : Display.screen -> {
! geom : Geometry.win_geom,
! border : ColorServer.color,
! backgrnd : ColorServer.color
! } -> (window * WindowEnv.in_env)
val createInputOnlyWin : window -> Geometry.rect -> window
--- 38,76 ----
(**** OBSOLETE ****
val allocSimpleTopWin : Display.screen
! -> (window * WindowEnv.in_env * ({
! geom : Geometry.win_geom,
! border : ColorServer.color,
! backgrnd : ColorServer.color
! } -> window))
val allocSimpleSubwin : window
! -> (window * ({
! geom : Geometry.win_geom,
! border : ColorServer.color option,
! backgrnd : ColorServer.color option
! } -> window))
**** OBSOLETE ****)
val createSimpleTopWin : Display.screen -> {
! geom : Geometry.win_geom,
! border : ColorServer.color,
! backgrnd : ColorServer.color
! (* modified ddeboer Jul 2004; orginal: *
! } -> (window * WindowEnv.in_env) *)
! } -> (window * WindowEnv.in_env * unit CML.chan)
val createSimpleSubwin : window -> {
! geom : Geometry.win_geom,
! border : ColorServer.color option,
! backgrnd : ColorServer.color option
! } -> window
val createTransientWin : window -> {
! geom : Geometry.win_geom,
! border : ColorServer.color,
! backgrnd : ColorServer.color
! } -> (window * WindowEnv.in_env)
val createSimplePopupWin : Display.screen -> {
! geom : Geometry.win_geom,
! border : ColorServer.color,
! backgrnd : ColorServer.color
! } -> (window * WindowEnv.in_env)
val createInputOnlyWin : window -> Geometry.rect -> window
***************
*** 79,89 ****
(* set the properties of a top-level window *)
val setWMProperties : window -> {
! win_name : string option,
! icon_name : string option,
! argv : string list,
! size_hints : XProps.size_hints list,
! wm_hints : XProps.wm_hints list,
! class_hints : {res_class : string, res_name : string} option
! } -> unit
(* set the window-manager protocols for a window *)
--- 81,91 ----
(* set the properties of a top-level window *)
val setWMProperties : window -> {
! win_name : string option,
! icon_name : string option,
! argv : string list,
! size_hints : XProps.size_hints list,
! wm_hints : XProps.wm_hints list,
! class_hints : {res_class : string, res_name : string} option
! } -> unit
(* set the window-manager protocols for a window *)
***************
*** 103,113 ****
val setBackground : window -> ColorServer.color option -> unit
! (* set the background color attribute of the window. Note that this does
! * not have an immediate affect on the window's contents, but if it is done
! * before the window is mapped, the window will come up with the right color.
! *)
val changeWinAttrs : window -> window_attr list -> unit
! (* Set various window attributes *)
val mapWin : window -> unit
--- 105,115 ----
val setBackground : window -> ColorServer.color option -> unit
! (* set the background color attribute of the window. Note that this does
! * not have an immediate affect on the window's contents, but if it is done
! * before the window is mapped, the window will come up with the right color.
! *)
val changeWinAttrs : window -> window_attr list -> unit
! (* Set various window attributes *)
val mapWin : window -> unit
***************
*** 119,121 ****
--- 121,126 ----
val displayOfWin : window -> Display.display
+ (* added ddeboer, Jan 2005 *)
+ val grabKeyboard : window -> int
+ val ungrabKeyboard : window -> int
end (* WINDOW *)
Index: window.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/eXene/lib/window/window.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** window.sml 1 Jun 2000 18:33:40 -0000 1.2
--- window.sml 3 Mar 2006 03:33:15 -0000 1.3
***************
*** 13,17 ****
(* set the value of a property *)
fun setProperty (dpy, winId, name, value) =
! dpyRequest dpy (XRequest.encodeChangeProperty {
win = winId, name = name, prop = value, mode = ReplaceProp
});
--- 13,17 ----
(* set the value of a property *)
fun setProperty (dpy, winId, name, value) =
! dpyRequest dpy (XRequest.encodeChangeProperty {
win = winId, name = name, prop = value, mode = ReplaceProp
});
***************
*** 46,95 ****
(* map user-level window attributes to internal x-window attributes *)
fun winAttrToXWinAttr (WA_Background_None) =
! XWV_BackgroundPixmap_None
| winAttrToXWinAttr (WA_Background_ParentRelative) =
! XWV_BackgroundPixmap_ParentRelative
| winAttrToXWinAttr (WA_Background_Pixmap(PM{id, ...})) =
! XWV_BackgroundPixmap id
| winAttrToXWinAttr (WA_Background_Tile(TILE(PM{id, ...}))) =
! XWV_BackgroundPixmap id
| winAttrToXWinAttr (WA_Background_Color color) =
! XWV_BackgroundPixel(pixelOf color)
| winAttrToXWinAttr (WA_Border_CopyFromParent) =
! XWV_BorderPixmap_CopyFromParent
| winAttrToXWinAttr (WA_Border_Pixmap(PM{id, ...})) =
! XWV_BorderPixmap id
| winAttrToXWinAttr (WA_Border_Tile(TILE(PM{id, ...}))) =
! XWV_BorderPixmap id
| winAttrToXWinAttr (WA_Border_Color color) =
! XWV_BorderPixel(pixelOf color)
| winAttrToXWinAttr (WA_BitGravity g) =
! XWV_BitGravity g
| winAttrToXWinAttr (WA_WinGravity g) =
! XWV_WinGravity g
| winAttrToXWinAttr (WA_Cursor_None) =
! XWV_Cursor_None
| winAttrToXWinAttr (WA_Cursor(Cursor.CURSOR{id, ...})) =
! XWV_Cursor id
val mapAttrs = List.map winAttrToXWinAttr
val stdXEventMask = XEventTypes.maskOfXEvtList [
! XEventTypes.XEVT_KeyPress,
! XEventTypes.XEVT_KeyRelease,
! XEventTypes.XEVT_ButtonPress,
! XEventTypes.XEVT_ButtonRelease,
! XEventTypes.XEVT_PointerMotion,
XEventTypes.XEVT_EnterWindow,
XEventTypes.XEVT_LeaveWindow,
! XEventTypes.XEVT_Exposure,
! XEventTypes.XEVT_StructureNotify,
! XEventTypes.XEVT_SubstructureNotify
! ]
val popupXEventMask = XEventTypes.maskOfXEvtList [
! XEventTypes.XEVT_Exposure,
! XEventTypes.XEVT_StructureNotify,
! XEventTypes.XEVT_SubstructureNotify
! ]
exception BadWindowGeometry
--- 46,95 ----
(* map user-level window attributes to internal x-window attributes *)
fun winAttrToXWinAttr (WA_Background_None) =
! XWV_BackgroundPixmap_None
| winAttrToXWinAttr (WA_Background_ParentRelative) =
! XWV_BackgroundPixmap_ParentRelative
| winAttrToXWinAttr (WA_Background_Pixmap(PM{id, ...})) =
! XWV_BackgroundPixmap id
| winAttrToXWinAttr (WA_Background_Tile(TILE(PM{id, ...}))) =
! XWV_BackgroundPixmap id
| winAttrToXWinAttr (WA_Background_Color color) =
! XWV_BackgroundPixel(pixelOf color)
| winAttrToXWinAttr (WA_Border_CopyFromParent) =
! XWV_BorderPixmap_CopyFromParent
| winAttrToXWinAttr (WA_Border_Pixmap(PM{id, ...})) =
! XWV_BorderPixmap id
| winAttrToXWinAttr (WA_Border_Tile(TILE(PM{id, ...}))) =
! XWV_BorderPixmap id
| winAttrToXWinAttr (WA_Border_Color color) =
! XWV_BorderPixel(pixelOf color)
| winAttrToXWinAttr (WA_BitGravity g) =
! XWV_BitGravity g
| winAttrToXWinAttr (WA_WinGravity g) =
! XWV_WinGravity g
| winAttrToXWinAttr (WA_Cursor_None) =
! XWV_Cursor_None
| winAttrToXWinAttr (WA_Cursor(Cursor.CURSOR{id, ...})) =
! XWV_Cursor id
val mapAttrs = List.map winAttrToXWinAttr
val stdXEventMask = XEventTypes.maskOfXEvtList [
! XEventTypes.XEVT_KeyPress,
! XEventTypes.XEVT_KeyRelease,
! XEventTypes.XEVT_ButtonPress,
! XEventTypes.XEVT_ButtonRelease,
! XEventTypes.XEVT_PointerMotion,
XEventTypes.XEVT_EnterWindow,
XEventTypes.XEVT_LeaveWindow,
! XEventTypes.XEVT_Exposure,
! XEventTypes.XEVT_StructureNotify,
! XEventTypes.XEVT_SubstructureNotify
! ]
val popupXEventMask = XEventTypes.maskOfXEvtList [
! XEventTypes.XEVT_Exposure,
! XEventTypes.XEVT_StructureNotify,
! XEventTypes.XEVT_SubstructureNotify
! ]
exception BadWindowGeometry
***************
*** 98,305 ****
fun createSimpleTopWin (scr as SCREEN{scr=scrinfo, dpy}) = let
! val SCR{xscr=XDisplay.XSCR{root, ...}, root_servers, ...} = scrinfo
! val SCRDEPTH{depth, ...} = root_servers
! val DPY{xdpy = XDisplay.XDPY{conn, nextXId, ...}, ...} = dpy
! val winId = nextXId()
! val (inEnv, win) = TopLevelWin.mkTopLevelWinEnv (scr, root_servers, winId)
! fun createFn {geom, border, backgrnd} = (
! XWin.newXWin conn {
! id = winId,
! parent = root,
! in_only = SOME false,
! depth = depth,
! visual = NONE,
! geom = chkGeom geom,
! attrs = [
! XWin.XWV_BorderPixel(pixelOf border),
! XWin.XWV_BackgroundPixel(pixelOf backgrnd),
! XWin.XWV_EventMask stdXEventMask
! ]
! };
! (win, inEnv))
! in
! createFn
! end (* createSimpleTopWin *)
fun createSimpleSubwin (WIN{id=parentId, scr, draw_cmd, scr_depth, ...}) = let
! val SCREEN{dpy=DPY{xdpy=XDisplay.XDPY{conn, nextXId, ...}, ...}, ...} = scr
! val winId = nextXId()
! val win = WIN{
! id = winId,
! scr = scr,
! draw_cmd = draw_cmd,
! scr_depth = scr_depth
! }
! val SCRDEPTH{depth, ...} = scr_depth
! fun createFn {geom, border, backgrnd} = let
! val borderPixel = (case border
! of NONE => XWin.XWV_BorderPixmap_CopyFromParent
! | (SOME c) => XWin.XWV_BorderPixel(pixelOf c)
! (* end case *))
! val backgroundPixel = (case backgrnd
! of NONE => XWin.XWV_BackgroundPixmap_ParentRelative
! | (SOME c) => XWin.XWV_BackgroundPixel(pixelOf c)
! (* end case *))
! in
! XWin.newXWin conn {
! id = winId,
! parent = parentId,
! in_only = SOME false,
! depth = depth,
! visual = NONE,
! geom = chkGeom geom,
! attrs = [
! borderPixel,
! backgroundPixel,
! XWin.XWV_EventMask stdXEventMask
! ]
! };
! win
! end
! in
! createFn
! end
(* create a simple popup window *)
fun createSimplePopupWin (scrn as SCREEN{scr, dpy}) {geom, border, backgrnd} = let
! val SCR{xscr=XDisplay.XSCR{root, ...}, root_servers, ...} = scr
! val SCRDEPTH{depth, ...} = root_servers
! val DPY{xdpy = XDisplay.XDPY{conn, nextXId, ...}, ...} = dpy
! val winId = nextXId()
! val (inEnv, win) = TopLevelWin.mkTopLevelWinEnv(scrn, root_servers, winId)
! in
! XWin.newXWin conn {
! id = winId,
! parent = root,
! in_only = SOME false,
! depth = depth,
! visual = NONE,
! geom = chkGeom geom,
! attrs = [
! XWin.XWV_OverrideRedirect true,
! XWin.XWV_SaveUnder true,
! XWin.XWV_BorderPixel(pixelOf border),
! XWin.XWV_BackgroundPixel(pixelOf backgrnd),
! XWin.XWV_EventMask popupXEventMask
! ]
! };
! (win, inEnv)
! end
(* create a simple transient window *)
fun createTransientWin propWin {geom, border, backgrnd} = let
! open XProps
val WIN{id, scr=scrn as SCREEN{scr, dpy},...} = propWin
! val SCR{xscr=XDisplay.XSCR{root, ...}, root_servers, ...} = scr
! val SCRDEPTH{depth, ...} = root_servers
! val DPY{xdpy = XDisplay.XDPY{conn, nextXId, ...}, ...} = dpy
! val winId = nextXId()
! val (inEnv, win) = TopLevelWin.mkTopLevelWinEnv(scrn, root_servers, winId)
! in
! XWin.newXWin conn {
! id = winId,
! parent = root,
! in_only = SOME false,
! depth = depth,
! visual = NONE,
! geom = chkGeom geom,
! attrs = [
! XWin.XWV_BorderPixel(pixelOf border),
! XWin.XWV_BackgroundPixel(pixelOf backgrnd),
! XWin.XWV_EventMask stdXEventMask
! ]
! };
! setProperty (
! dpy, winId, A.atom_WM_TRANSIENT_FOR, makeTransientHint propWin);
! (win, inEnv)
! end
exception InputOnly
fun createInputOnlyWin win (RECT{x, y, wid, ht}) = let
! val WIN{id=parentId, scr, scr_depth, draw_cmd, ...} = win
! val SCREEN{dpy=DPY{xdpy=XDisplay.XDPY{conn, nextXId, ...}, ...}, ...} = scr
! val winId = nextXId()
! fun drawCmd (arg as (DrawMaster.DMSG_Destroy _)) = draw_cmd arg
! | drawCmd _ = raise InputOnly
! val win = WIN{
! id = winId,
! scr = scr,
! draw_cmd = drawCmd,
! scr_depth = scr_depth
! }
! in
! XWin.newXWin conn {
! id = winId,
! parent = parentId,
! in_only = SOME true,
! depth = 0,
! visual = NONE,
! geom = chkGeom(WGEOM{pos=PT{x=x, y=y}, sz=SIZE{wid=wid, ht=ht}, border=0}),
! attrs = [XWin.XWV_EventMask stdXEventMask]
! };
! win
! end
(* Set the standard window-manager properties of a top-level window *)
fun setWMProperties win {
! win_name, icon_name, argv, size_hints, wm_hints, class_hints
! } = let
! open XProtTypes XAtoms XProps
! val WIN{id, scr=SCREEN{dpy, ...}, ...} = win
! fun putProp (name, value) = setProperty (dpy, id, name, value)
! fun putStrProp (_, NONE) = ()
! | putStrProp (atom, SOME s) = putProp (atom, makeStringProp s)
! in
! putStrProp (A.atom_WM_NAME, win_name);
! putStrProp (A.atom_WM_ICON_NAME, icon_name);
! putProp (A.atom_WM_NORMAL_HINTS, makeWMSizeHints size_hints);
! putProp (A.atom_WM_HINTS, makeWMHints wm_hints);
! case class_hints
! of SOME{res_name, res_class} =>
! putProp (A.atom_WM_CLASS,
! makeStringProp (String.concat[res_name, "\000", res_class]))
! | NONE => ()
! (* end case *);
! case argv
! of [] => ()
! | _ => putProp (A.atom_WM_COMMAND, makeCommandHints(argv))
! (* end case *)
! end
(* Set the window-manager protocols for a window *)
fun setWMProtocols win atoml = let
! open XProtTypes XProps
! val WIN{id, scr=SCREEN{dpy, ...}, ...} = win
! fun putProp n a = setProperty (dpy, id, n, makeAtomProp a)
in
case (XAtoms.lookupAtom dpy "WM_PROTOCOLS")
! of NONE => false
| (SOME protocols_atom) => (app (putProp protocols_atom) atoml; true)
! (* end case *)
end
(* Map window configuration values to a value list *)
fun doConfigVal arr = let
! fun upd (i, v) = Array.update(arr, i, SOME v)
! in
! fn (WC_Origin(PT{x, y})) => (
! upd(0, Word.fromInt x); upd(1, Word.fromInt y))
! | (WC_Size(SIZE{wid, ht})) => (
! upd(2, Word.fromInt wid); upd(3, Word.fromInt ht))
! | (WC_BorderWid wid) => upd(4, Word.fromInt wid)
! | (WC_StackMode mode) => (
! Array.update(arr, 5, NONE);
! upd(6, XCvtFuns.stackModeToWire mode))
! | (WC_RelStackMode(WIN{id=(XID x), ...}, mode)) => (
! upd(5, x); upd(6, XCvtFuns.stackModeToWire mode))
! end
val doConfigVals = XCvtFuns.doValList 7 doConfigVal
fun configureWin (WIN{id, scr=SCREEN{dpy, ...}, ...}) vals =
! dpyRequest dpy (XRequest.encodeConfigureWindow{
! win = id, vals = doConfigVals vals
! })
fun moveWin win pt = configureWin win [WC_Origin pt]
--- 98,313 ----
fun createSimpleTopWin (scr as SCREEN{scr=scrinfo, dpy}) = let
! val SCR{xscr=XDisplay.XSCR{root, ...}, root_servers, ...} = scrinfo
! val SCRDEPTH{depth, ...} = root_servers
! val DPY{xdpy = XDisplay.XDPY{conn, nextXId, ...}, ...} = dpy
! val winId = nextXId()
! (* modified ddeboer Jul 2004: original:
! val (inEnv, win) = TopLevelWin.mkTopLevelWinEnv (scr, root_servers, winId) *)
! val (inEnv, win, delCh) = TopLevelWin.mkTopLevelWinEnv (scr, root_servers, winId)
! fun createFn {geom, border, backgrnd} = (
! XWin.newXWin conn {
! id = winId,
! parent = root,
! in_only = SOME false,
! depth = depth,
! visual = NONE,
! geom = chkGeom geom,
! attrs = [
! XWin.XWV_BorderPixel(pixelOf border),
! XWin.XWV_BackgroundPixel(pixelOf backgrnd),
! XWin.XWV_EventMask stdXEventMask
! ]
! };
! (* modified ddeboer Jul 2004; original: *
! (win, inEnv)) *)
! (win, inEnv, delCh))
! in
! createFn
! end (* createSimpleTopWin *)
fun createSimpleSubwin (WIN{id=parentId, scr, draw_cmd, scr_depth, ...}) = let
! val SCREEN{dpy=DPY{xdpy=XDisplay.XDPY{conn, nextXId, ...}, ...}, ...} = scr
! val winId = nextXId()
! val win = WIN{
! id = winId,
! scr = scr,
! draw_cmd = draw_cmd,
! scr_depth = scr_depth
! }
! val SCRDEPTH{depth, ...} = scr_depth
! fun createFn {geom, border, backgrnd} = let
! val borderPixel = (case border
! of NONE => XWin.XWV_BorderPixmap_CopyFromParent
! | (SOME c) => XWin.XWV_BorderPixel(pixelOf c)
! (* end case *))
! val backgroundPixel = (case backgrnd
! of NONE => XWin.XWV_BackgroundPixmap_ParentRelative
! | (SOME c) => XWin.XWV_BackgroundPixel(pixelOf c)
! (* end case *))
! in
! XWin.newXWin conn {
! id = winId,
! parent = parentId,
! in_only = SOME false,
! depth = depth,
! visual = NONE,
! geom = chkGeom geom,
! attrs = [
! borderPixel,
! backgroundPixel,
! XWin.XWV_EventMask stdXEventMask
! ]
! };
! win
! end
! in
! createFn
! end
(* create a simple popup window *)
fun createSimplePopupWin (scrn as SCREEN{scr, dpy}) {geom, border, backgrnd} = let
! val SCR{xscr=XDisplay.XSCR{root, ...}, root_servers, ...} = scr
! val SCRDEPTH{depth, ...} = root_servers
! val DPY{xdpy = XDisplay.XDPY{conn, nextXId, ...}, ...} = dpy
! val winId = nextXId()
! (* modified ddeboer, Jul 2004; original:
! val (inEnv, win) = TopLevelWin.mkTopLevelWinEnv(scrn, root_servers, winId) *)
! val (inEnv, win, delCh) = TopLevelWin.mkTopLevelWinEnv(scrn, root_servers, winId)
! in
! XWin.newXWin conn {
! id = winId,
! parent = root,
! in_only = SOME false,
! depth = depth,
! visual = NONE,
! geom = chkGeom geom,
! attrs = [
! XWin.XWV_OverrideRedirect true,
! XWin.XWV_SaveUnder true,
! XWin.XWV_BorderPixel(pixelOf border),
! XWin.XWV_BackgroundPixel(pixelOf backgrnd),
! XWin.XWV_EventMask popupXEventMask
! ]
! };
! (win, inEnv)
! end
(* create a simple transient window *)
fun createTransientWin propWin {geom, border, backgrnd} = let
! open XProps
val WIN{id, scr=scrn as SCREEN{scr, dpy},...} = propWin
! val SCR{xscr=XDisplay.XSCR{root, ...}, root_servers, ...} = scr
! val SCRDEPTH{depth, ...} = root_servers
! val DPY{xdpy = XDisplay.XDPY{conn, nextXId, ...}, ...} = dpy
! val winId = nextXId()
! (* modified ddeboer, Jul 2004; original:
! val (inEnv, win) = TopLevelWin.mkTopLevelWinEnv(scrn, root_servers, winId) *)
! val (inEnv, win, delCh) = TopLevelWin.mkTopLevelWinEnv(scrn, root_servers, winId)
! in
! XWin.newXWin conn {
! id = winId,
! parent = root,
! in_only = SOME false,
! depth = depth,
! visual = NONE,
! geom = chkGeom geom,
! attrs = [
! XWin.XWV_BorderPixel(pixelOf border),
! XWin.XWV_BackgroundPixel(pixelOf backgrnd),
! XWin.XWV_EventMask stdXEventMask
! ]
! };
! setProperty (
! dpy, winId, A.atom_WM_TRANSIENT_FOR, makeTransientHint propWin);
! (win, inEnv)
! end
exception InputOnly
fun createInputOnlyWin win (RECT{x, y, wid, ht}) = let
! val WIN{id=parentId, scr, scr_depth, draw_cmd, ...} = win
! val SCREEN{dpy=DPY{xdpy=XDisplay.XDPY{conn, nextXId, ...}, ...}, ...} = scr
! val winId = nextXId()
! fun drawCmd (arg as (DrawMaster.DMSG_Destroy _)) = draw_cmd arg
! | drawCmd _ = raise InputOnly
! val win = WIN{
! id = winId,
! scr = scr,
! draw_cmd = drawCmd,
! scr_depth = scr_depth
! }
! in
! XWin.newXWin conn {
! id = winId,
! parent = parentId,
! in_only = SOME true,
! depth = 0,
! visual = NONE,
! geom = chkGeom(WGEOM{pos=PT{x=x, y=y}, sz=SIZE{wid=wid, ht=ht}, border=0}),
! attrs = [XWin.XWV_EventMask stdXEventMask]
! };
! win
! end
(* Set the standard window-manager properties of a top-level window *)
fun setWMProperties win {
! win_name, icon_name, argv, size_hints, wm_hints, class_hints
! } = let
! open XProtTypes XAtoms XProps
! val WIN{id, scr=SCREEN{dpy, ...}, ...} = win
! fun putProp (name, value) = setProperty (dpy, id, name, value)
! fun putStrProp (_, NONE) = ()
! | putStrProp (atom, SOME s) = putProp (atom, makeStringProp s)
! in
! putStrProp (A.atom_WM_NAME, win_name);
! putStrProp (A.atom_WM_ICON_NAME, icon_name);
! putProp (A.atom_WM_NORMAL_HINTS, makeWMSizeHints size_hints);
! putProp (A.atom_WM_HINTS, makeWMHints wm_hints);
! case class_hints
! of SOME{res_name, res_class} =>
! putProp (A.atom_WM_CLASS,
! makeStringProp (String.concat[res_name, "\000", res_class]))
! | NONE => ()
! (* end case *);
! case argv
! of [] => ()
! | _ => putProp (A.atom_WM_COMMAND, makeCommandHints(argv))
! (* end case *)
! end
(* Set the window-manager protocols for a window *)
fun setWMProtocols win atoml = let
! open XProtTypes XProps
! val WIN{id, scr=SCREEN{dpy, ...}, ...} = win
! fun putProp n a = setProperty (dpy, id, n, makeAtomProp a)
in
case (XAtoms.lookupAtom dpy "WM_PROTOCOLS")
! of NONE => false
| (SOME protocols_atom) => (app (putProp protocols_atom) atoml; true)
! (* end case *)
end
(* Map window configuration values to a value list *)
fun doConfigVal arr = let
! fun upd (i, v) = Array.update(arr, i, SOME v)
! in
! fn (WC_Origin(PT{x, y})) => (
! upd(0, Word.fromInt x); upd(1, Word.fromInt y))
! | (WC_Size(SIZE{wid, ht})) => (
! upd(2, Word.fromInt wid); upd(3, Word.fromInt ht))
! | (WC_BorderWid wid) => upd(4, Word.fromInt wid)
! | (WC_StackMode mode) => (
! Array.update(arr, 5, NONE);
! upd(6, XCvtFuns.stackModeToWire mode))
! | (WC_RelStackMode(WIN{id=(XID x), ...}, mode)) => (
! upd(5, x); upd(6, XCvtFuns.stackModeToWire mode))
! end
val doConfigVals = XCvtFuns.doValList 7 doConfigVal
fun configureWin (WIN{id, scr=SCREEN{dpy, ...}, ...}) vals =
! dpyRequest dpy (XRequest.encodeConfigureWindow{
! win = id, vals = doConfigVals vals
! })
fun moveWin win pt = configureWin win [WC_Origin pt]
***************
*** 308,323 ****
fun moveAndResizeWin win (RECT{x, y, wid, ht}) = configureWin win [
! WC_Origin(PT{x=x, y=y}), WC_Size(SIZE{wid=wid, ht=ht})
! ]
(* Map a window *)
fun mapWin (WIN{id, scr=SCREEN{dpy, ...}, ...}) = (
! dpyRequest dpy (XRequest.encodeMapWindow{win=id});
! dpyFlushOut dpy)
(* Unmap a window *)
fun unmapWin (WIN{id, scr=SCREEN{dpy, ...}, ...}) = (
! dpyRequest dpy (XRequest.encodeUnmapWindow{win=id});
! dpyFlushOut dpy)
(* Withdraw (unmap and notify window manager) a top-level window *)
--- 316,331 ----
fun moveAndResizeWin win (RECT{x, y, wid, ht}) = configureWin win [
! WC_Origin(PT{x=x, y=y}), WC_Size(SIZE{wid=wid, ht=ht})
! ]
(* Map a window *)
fun mapWin (WIN{id, scr=SCREEN{dpy, ...}, ...}) = (
! dpyRequest dpy (XRequest.encodeMapWindow{win=id});
! dpyFlushOut dpy)
(* Unmap a window *)
fun unmapWin (WIN{id, scr=SCREEN{dpy, ...}, ...}) = (
! dpyRequest dpy (XRequest.encodeUnmapWindow{win=id});
! dpyFlushOut dpy)
(* Withdraw (unmap and notify window manager) a top-level window *)
***************
*** 330,337 ****
val XDisplay.XSCR{root,...} = xscr
in
! dpyRequest dpy (XSendEvent.encodeSendUnmapNotify
! {dst=SendEvtTo_Window root, propagate=false, evt_mask=mask,
event=root, window=id, from_configure=false});
! dpyFlushOut dpy
end
end (* local *)
--- 338,345 ----
val XDisplay.XSCR{root,...} = xscr
in
! dpyRequest dpy (XSendEvent.encodeSendUnmapNotify
! {dst=SendEvtTo_Window root, propagate=false, evt_mask=mask,
event=root, window=id, from_configure=false});
! dpyFlushOut dpy
end
end (* local *)
***************
*** 346,369 ****
* coordinate system *)
fun winPtToScrPt (WIN{id, scr, ...}) pt = let
! val SCREEN{dpy, scr=SCR{xscr=XDisplay.XSCR{root, ...}, ...}, ...} = scr
! val {dst_pt, ...} = XReply.decodeTranslateCoordsReply (
! CML.sync (dpyRequestReply dpy
! (XRequest.encodeTranslateCoords{
! src_win=id, dst_win=root, src_pt=pt
! })))
! in
! dst_pt
! end
(* set the cursor of the window *)
fun setCursor (WIN{id, scr, ...}) c = let
! val SCREEN{dpy=DPY{xdpy=XDisplay.XDPY{conn, ...}, ...}, ...} = scr
! val cur = (case c
! of NONE => XWV_Cursor_None
! | (SOME(Cursor.CURSOR{id, ...})) => XWV_Cursor id
! (* end case *))
! in
! XWin.changeXWinAttrs conn (id, [cur])
! end
(* set the background color attribute of the window. Note that this does
--- 354,377 ----
* coordinate system *)
fun winPtToScrPt (WIN{id, scr, ...}) pt = let
! val SCREEN{dpy, scr=SCR{xscr=XDisplay.XSCR{root, ...}, ...}, ...} = scr
! val {dst_pt, ...} = XReply.decodeTranslateCoordsReply (
! CML.sync (dpyRequestReply dpy
! (XRequest.encodeTranslateCoords{
! src_win=id, dst_win=root, src_pt=pt
! })))
! in
! dst_pt
! end
(* set the cursor of the window *)
fun setCursor (WIN{id, scr, ...}) c = let
! val SCREEN{dpy=DPY{xdpy=XDisplay.XDPY{conn, ...}, ...}, ...} = scr
! val cur = (case c
! of NONE => XWV_Cursor_None
! | (SOME(Cursor.CURSOR{id, ...})) => XWV_Cursor id
! (* end case *))
! in
! XWin.changeXWinAttrs conn (id, [cur])
! end
(* set the background color attribute of the window. Note that this does
***************
*** 372,394 ****
*)
fun setBackground (WIN{id, scr, ...}) color = let
! val SCREEN{dpy=DPY{xdpy=XDisplay.XDPY{conn, ...}, ...}, ...} = scr
! val color = (case color
! of NONE => XWV_BackgroundPixmap_ParentRelative
! | (SOME c) => XWV_BackgroundPixel(pixelOf c)
! (* end case *))
! in
! XWin.changeXWinAttrs conn (id, [color])
! end (* setBackground *)
(* Set various window attributes *)
fun changeWinAttrs (WIN{id, scr, ...}) = let
! val SCREEN{dpy=DPY{xdpy=XDisplay.XDPY{conn, ...}, ...}, ...} = scr
! val change = XWin.changeXWinAttrs conn
! in
! fn attrs => change (id, map winAttrToXWinAttr attrs)
! end (* changeWinAttrs *)
fun screenOfWin (WIN{scr, ...}) = scr
fun displayOfWin (WIN{scr=SCREEN{dpy, ...}, ...}) = dpy
end (* Window *)
--- 380,436 ----
*)
fun setBackground (WIN{id, scr, ...}) color = let
! val SCREEN{dpy=DPY{xdpy=XDisplay.XDPY{conn, ...}, ...}, ...} = scr
! val color = (case color
! of NONE => XWV_BackgroundPixmap_ParentRelative
! | (SOME c) => XWV_BackgroundPixel(pixelOf c)
! (* end case *))
! in
! XWin.changeXWinAttrs conn (id, [color])
! end (* setBackground *)
(* Set various window attributes *)
fun changeWinAttrs (WIN{id, scr, ...}) = let
! val SCREEN{dpy=DPY{xdpy=XDisplay.XDPY{conn, ...}, ...}, ...} = scr
! val change = XWin.changeXWinAttrs conn
! in
! fn attrs => change (id, map winAttrToXWinAttr attrs)
! end (* changeWinAttrs *)
fun screenOfWin (WIN{scr, ...}) = scr
fun displayOfWin (WIN{scr=SCREEN{dpy, ...}, ...}) = dpy
+ (* added ddeboer Jan 2005 *)
+ (* grabKeyboard: we would like a reply of XProtTypes.GrabSuccess *)
+ fun grabKeyboard (WIN{id,scr=SCREEN{dpy, ...}, ...}) = 0
+ (* commented out, ddeboer, mar 2005 - this needs reworked.
+ let val ans =
+ (XReply.decodeGrabKeyboardReply (CML.sync (Display.dpyRequestReply dpy
+ (XRequest.encodeGrabKeyboard {
+ win=id, * type XTy.XID *
+ owner_evts=false,
+ ptr_mode=XProtTypes.AsynchronousGrab,
+ kbd_mode=XProtTypes.AsynchronousGrab,
+ time=XProtTypes.CurrentTime}))))
+ handle XIo.LostReply => raise (MLXError.XERROR "[reply lost]")
+ | (XIo.ErrorReply err) =>
+ raise (MLXError.XERROR(XPrint.xerrorToString err))
+ in (case (ans) of
+ XProtTypes.GrabSuccess => 0
+ | XProtTypes.AlreadyGrabbed => 1
+ | XProtTypes.GrabInvalidTime => 2
+ | XProtTypes.GrabNotViewable => 3
+ | XProtTypes.GrabFrozen => 4)
+ end *)
+ fun ungrabKeyboard (WIN{id,scr=SCREEN{dpy, ...}, ...}) =
+ let val ans =
+ ( (* XReply.decodeGrabKeyboardReply *) (CML.sync (Display.dpyRequestReply dpy
+ (XRequest.encodeUngrabKeyboard {
+ time=XProtTypes.CurrentTime}))))
+ handle XIo.LostReply => raise (MLXError.XERROR "[reply lost]")
+ | (XIo.ErrorReply err) =>
+ raise (MLXError.XERROR(XPrint.xerrorToString err))
+ in (* TODO: figure out what type of reply comes from an ungrab request, and decode it *)
+ 0
+ end
+ (* end added ddeboer *)
end (* Window *)
Index: winreg.sml
===================================================================
RCS file: /cvsroot/smlnj/sml-dist/src/eXene/lib/window/winreg.sml,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** winreg.sml 1 Jun 2000 18:33:40 -0000 1.2
--- winreg.sml 3 Mar 2006 03:33:15 -0000 1.3
***************
*** 75,78 ****
--- 75,81 ----
| ToTrash
+ (* ddeboer test, fall 2004.
+ val rcref = ref 0*)
+
(* discard instances of an X-event that are the product of SubstructureNotify,
* instead of StructureNotify. *)
***************
*** 171,174 ****
--- 174,182 ----
fun createRegistry {dpy=XDpy.XDPY{conn, ...}, keymap, propEvtCh, selEvtCh} = let
+ (* testing: ddeboer, fall 2004. *
+ val rn = (!rcref)
+ val _ = (TextIO.print ("Started registry " ^ (Int.toString rn) ^ "\n");
+ rcref:=(!rcref)+1)
+ * end testing. *)
val xevtIn = XIo.waitForXEvent conn
val registerReqCh = CML.channel() and registerReplyCh = CML.channel()
***************
*** 207,215 ****
insert (childId, child)
end
! fun sendEvt (e, WD{path, evt_strm, ...}) = CML.send (evt_strm, (path, e))
fun sendEvtToWin (e, winId) = (sendEvt (e, find winId))
handle HashXId.XIdNotFound => ()
fun handleEvt e = (case (extractDst e)
! of (ToWindow winId) => sendEvtToWin(e, winId)
| (CreateWin{parent, new_win}) => (
newSubwin(parent, new_win);
--- 215,230 ----
insert (childId, child)
end
! (* ddeboer, test, fall 2004
! val cref = ref 0*)
! fun sendEvt (e, WD{path, evt_strm, ...}) =
! (* test, ddeboer, fall 2004: *)
! ( (*TextIO.print ("reg sending "^(Int.toString rn)^" "^(Int.toString (!cref))^"\n");*)
! CML.send (evt_strm, (path, e)))
! (*TextIO.print ("reg sent "^(Int.toString rn)^" "^(Int.toString (!cref))^"\n");
! cref := ((!cref)+1))*)
fun sendEvtToWin (e, winId) = (sendEvt (e, find winId))
handle HashXId.XIdNotFound => ()
fun handleEvt e = (case (extractDst e)
! of (ToWindow winId) => (sendEvtToWin(e, winId))
| (CreateWin{parent, new_win}) => (
newSubwin(parent, new_win);
-------------------------------------------------------
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