Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/eXene/lib/window/window.sml
ViewVC logotype

Annotation of /sml/trunk/src/eXene/lib/window/window.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1911 - (view) (download)

1 : monnier 2 (* window.sml
2 :     *
3 :     * COPYRIGHT (c) 1990,1991 by John H. Reppy. See COPYRIGHT file for details.
4 :     *)
5 :    
6 :     structure Window : WINDOW =
7 :     struct
8 :    
9 :     structure A = StdAtoms
10 :    
11 :     open Geometry XProtTypes XWin Display DrawTypes
12 :    
13 :     (* set the value of a property *)
14 :     fun setProperty (dpy, winId, name, value) =
15 : mblume 1911 dpyRequest dpy (XRequest.encodeChangeProperty {
16 : monnier 2 win = winId, name = name, prop = value, mode = ReplaceProp
17 :     });
18 :    
19 :     (* user-level window attributes *)
20 :     datatype window_attr
21 :     = WA_Background_None
22 :     | WA_Background_ParentRelative
23 :     | WA_Background_Pixmap of DrawTypes.pixmap
24 :     | WA_Background_Tile of DrawTypes.tile
25 :     | WA_Background_Color of ColorServer.color
26 :     | WA_Border_CopyFromParent
27 :     | WA_Border_Pixmap of DrawTypes.pixmap
28 :     | WA_Border_Tile of DrawTypes.tile
29 :     | WA_Border_Color of ColorServer.color
30 :     | WA_BitGravity of XProtTypes.gravity
31 :     | WA_WinGravity of XProtTypes.gravity
32 :     | WA_Cursor_None
33 :     | WA_Cursor of Cursor.cursor
34 :    
35 :     (* window configuration values *)
36 :     datatype window_config
37 :     = WC_Origin of point
38 :     | WC_Size of size
39 :     | WC_BorderWid of int
40 :     | WC_StackMode of XProtTypes.stack_mode
41 :     | WC_RelStackMode of (window * XProtTypes.stack_mode)
42 :    
43 :     (* extract the pixel from a color *)
44 :     fun pixelOf (ColorServer.COLOR{pixel, ...}) = pixel
45 :    
46 :     (* map user-level window attributes to internal x-window attributes *)
47 :     fun winAttrToXWinAttr (WA_Background_None) =
48 : mblume 1911 XWV_BackgroundPixmap_None
49 : monnier 2 | winAttrToXWinAttr (WA_Background_ParentRelative) =
50 : mblume 1911 XWV_BackgroundPixmap_ParentRelative
51 : monnier 2 | winAttrToXWinAttr (WA_Background_Pixmap(PM{id, ...})) =
52 : mblume 1911 XWV_BackgroundPixmap id
53 : monnier 2 | winAttrToXWinAttr (WA_Background_Tile(TILE(PM{id, ...}))) =
54 : mblume 1911 XWV_BackgroundPixmap id
55 : monnier 2 | winAttrToXWinAttr (WA_Background_Color color) =
56 : mblume 1911 XWV_BackgroundPixel(pixelOf color)
57 : monnier 2 | winAttrToXWinAttr (WA_Border_CopyFromParent) =
58 : mblume 1911 XWV_BorderPixmap_CopyFromParent
59 : monnier 2 | winAttrToXWinAttr (WA_Border_Pixmap(PM{id, ...})) =
60 : mblume 1911 XWV_BorderPixmap id
61 : monnier 2 | winAttrToXWinAttr (WA_Border_Tile(TILE(PM{id, ...}))) =
62 : mblume 1911 XWV_BorderPixmap id
63 : monnier 2 | winAttrToXWinAttr (WA_Border_Color color) =
64 : mblume 1911 XWV_BorderPixel(pixelOf color)
65 : monnier 2 | winAttrToXWinAttr (WA_BitGravity g) =
66 : mblume 1911 XWV_BitGravity g
67 : monnier 2 | winAttrToXWinAttr (WA_WinGravity g) =
68 : mblume 1911 XWV_WinGravity g
69 : monnier 2 | winAttrToXWinAttr (WA_Cursor_None) =
70 : mblume 1911 XWV_Cursor_None
71 : monnier 2 | winAttrToXWinAttr (WA_Cursor(Cursor.CURSOR{id, ...})) =
72 : mblume 1911 XWV_Cursor id
73 : monnier 2
74 :     val mapAttrs = List.map winAttrToXWinAttr
75 :    
76 :     val stdXEventMask = XEventTypes.maskOfXEvtList [
77 : mblume 1911 XEventTypes.XEVT_KeyPress,
78 :     XEventTypes.XEVT_KeyRelease,
79 :     XEventTypes.XEVT_ButtonPress,
80 :     XEventTypes.XEVT_ButtonRelease,
81 :     XEventTypes.XEVT_PointerMotion,
82 : monnier 2 XEventTypes.XEVT_EnterWindow,
83 :     XEventTypes.XEVT_LeaveWindow,
84 : mblume 1911 XEventTypes.XEVT_Exposure,
85 :     XEventTypes.XEVT_StructureNotify,
86 :     XEventTypes.XEVT_SubstructureNotify
87 :     ]
88 : monnier 2
89 :     val popupXEventMask = XEventTypes.maskOfXEvtList [
90 : mblume 1911 XEventTypes.XEVT_Exposure,
91 :     XEventTypes.XEVT_StructureNotify,
92 :     XEventTypes.XEVT_SubstructureNotify
93 :     ]
94 : monnier 2
95 :     exception BadWindowGeometry
96 :    
97 :     fun chkGeom g = if Geometry.validGeom g then g else raise BadWindowGeometry
98 :    
99 :     fun createSimpleTopWin (scr as SCREEN{scr=scrinfo, dpy}) = let
100 : mblume 1911 val SCR{xscr=XDisplay.XSCR{root, ...}, root_servers, ...} = scrinfo
101 :     val SCRDEPTH{depth, ...} = root_servers
102 :     val DPY{xdpy = XDisplay.XDPY{conn, nextXId, ...}, ...} = dpy
103 :     val winId = nextXId()
104 :     (* modified ddeboer Jul 2004: original:
105 :     val (inEnv, win) = TopLevelWin.mkTopLevelWinEnv (scr, root_servers, winId) *)
106 :     val (inEnv, win, delCh) = TopLevelWin.mkTopLevelWinEnv (scr, root_servers, winId)
107 :     fun createFn {geom, border, backgrnd} = (
108 :     XWin.newXWin conn {
109 :     id = winId,
110 :     parent = root,
111 :     in_only = SOME false,
112 :     depth = depth,
113 :     visual = NONE,
114 :     geom = chkGeom geom,
115 :     attrs = [
116 :     XWin.XWV_BorderPixel(pixelOf border),
117 :     XWin.XWV_BackgroundPixel(pixelOf backgrnd),
118 :     XWin.XWV_EventMask stdXEventMask
119 :     ]
120 :     };
121 :     (* modified ddeboer Jul 2004; original: *
122 :     (win, inEnv)) *)
123 :     (win, inEnv, delCh))
124 :     in
125 :     createFn
126 :     end (* createSimpleTopWin *)
127 : monnier 2
128 :     fun createSimpleSubwin (WIN{id=parentId, scr, draw_cmd, scr_depth, ...}) = let
129 : mblume 1911 val SCREEN{dpy=DPY{xdpy=XDisplay.XDPY{conn, nextXId, ...}, ...}, ...} = scr
130 :     val winId = nextXId()
131 :     val win = WIN{
132 :     id = winId,
133 :     scr = scr,
134 :     draw_cmd = draw_cmd,
135 :     scr_depth = scr_depth
136 :     }
137 :     val SCRDEPTH{depth, ...} = scr_depth
138 :     fun createFn {geom, border, backgrnd} = let
139 :     val borderPixel = (case border
140 :     of NONE => XWin.XWV_BorderPixmap_CopyFromParent
141 :     | (SOME c) => XWin.XWV_BorderPixel(pixelOf c)
142 :     (* end case *))
143 :     val backgroundPixel = (case backgrnd
144 :     of NONE => XWin.XWV_BackgroundPixmap_ParentRelative
145 :     | (SOME c) => XWin.XWV_BackgroundPixel(pixelOf c)
146 :     (* end case *))
147 :     in
148 :     XWin.newXWin conn {
149 :     id = winId,
150 :     parent = parentId,
151 :     in_only = SOME false,
152 :     depth = depth,
153 :     visual = NONE,
154 :     geom = chkGeom geom,
155 :     attrs = [
156 :     borderPixel,
157 :     backgroundPixel,
158 :     XWin.XWV_EventMask stdXEventMask
159 :     ]
160 :     };
161 :     win
162 :     end
163 :     in
164 :     createFn
165 :     end
166 : monnier 2
167 :    
168 :     (* create a simple popup window *)
169 :     fun createSimplePopupWin (scrn as SCREEN{scr, dpy}) {geom, border, backgrnd} = let
170 : mblume 1911 val SCR{xscr=XDisplay.XSCR{root, ...}, root_servers, ...} = scr
171 :     val SCRDEPTH{depth, ...} = root_servers
172 :     val DPY{xdpy = XDisplay.XDPY{conn, nextXId, ...}, ...} = dpy
173 :     val winId = nextXId()
174 :     (* modified ddeboer, Jul 2004; original:
175 :     val (inEnv, win) = TopLevelWin.mkTopLevelWinEnv(scrn, root_servers, winId) *)
176 :     val (inEnv, win, delCh) = TopLevelWin.mkTopLevelWinEnv(scrn, root_servers, winId)
177 :     in
178 :     XWin.newXWin conn {
179 :     id = winId,
180 :     parent = root,
181 :     in_only = SOME false,
182 :     depth = depth,
183 :     visual = NONE,
184 :     geom = chkGeom geom,
185 :     attrs = [
186 :     XWin.XWV_OverrideRedirect true,
187 :     XWin.XWV_SaveUnder true,
188 :     XWin.XWV_BorderPixel(pixelOf border),
189 :     XWin.XWV_BackgroundPixel(pixelOf backgrnd),
190 :     XWin.XWV_EventMask popupXEventMask
191 :     ]
192 :     };
193 :     (win, inEnv)
194 :     end
195 : monnier 2
196 :     (* create a simple transient window *)
197 :     fun createTransientWin propWin {geom, border, backgrnd} = let
198 : mblume 1911 open XProps
199 : monnier 2 val WIN{id, scr=scrn as SCREEN{scr, dpy},...} = propWin
200 : mblume 1911 val SCR{xscr=XDisplay.XSCR{root, ...}, root_servers, ...} = scr
201 :     val SCRDEPTH{depth, ...} = root_servers
202 :     val DPY{xdpy = XDisplay.XDPY{conn, nextXId, ...}, ...} = dpy
203 :     val winId = nextXId()
204 :     (* modified ddeboer, Jul 2004; original:
205 :     val (inEnv, win) = TopLevelWin.mkTopLevelWinEnv(scrn, root_servers, winId) *)
206 :     val (inEnv, win, delCh) = TopLevelWin.mkTopLevelWinEnv(scrn, root_servers, winId)
207 :     in
208 :     XWin.newXWin conn {
209 :     id = winId,
210 :     parent = root,
211 :     in_only = SOME false,
212 :     depth = depth,
213 :     visual = NONE,
214 :     geom = chkGeom geom,
215 :     attrs = [
216 :     XWin.XWV_BorderPixel(pixelOf border),
217 :     XWin.XWV_BackgroundPixel(pixelOf backgrnd),
218 :     XWin.XWV_EventMask stdXEventMask
219 :     ]
220 :     };
221 :     setProperty (
222 :     dpy, winId, A.atom_WM_TRANSIENT_FOR, makeTransientHint propWin);
223 :     (win, inEnv)
224 :     end
225 : monnier 2
226 :     exception InputOnly
227 :    
228 :     fun createInputOnlyWin win (RECT{x, y, wid, ht}) = let
229 : mblume 1911 val WIN{id=parentId, scr, scr_depth, draw_cmd, ...} = win
230 :     val SCREEN{dpy=DPY{xdpy=XDisplay.XDPY{conn, nextXId, ...}, ...}, ...} = scr
231 :     val winId = nextXId()
232 :     fun drawCmd (arg as (DrawMaster.DMSG_Destroy _)) = draw_cmd arg
233 :     | drawCmd _ = raise InputOnly
234 :     val win = WIN{
235 :     id = winId,
236 :     scr = scr,
237 :     draw_cmd = drawCmd,
238 :     scr_depth = scr_depth
239 :     }
240 :     in
241 :     XWin.newXWin conn {
242 :     id = winId,
243 :     parent = parentId,
244 :     in_only = SOME true,
245 :     depth = 0,
246 :     visual = NONE,
247 :     geom = chkGeom(WGEOM{pos=PT{x=x, y=y}, sz=SIZE{wid=wid, ht=ht}, border=0}),
248 :     attrs = [XWin.XWV_EventMask stdXEventMask]
249 :     };
250 :     win
251 :     end
252 : monnier 2
253 :     (* Set the standard window-manager properties of a top-level window *)
254 :     fun setWMProperties win {
255 : mblume 1911 win_name, icon_name, argv, size_hints, wm_hints, class_hints
256 :     } = let
257 :     open XProtTypes XAtoms XProps
258 :     val WIN{id, scr=SCREEN{dpy, ...}, ...} = win
259 :     fun putProp (name, value) = setProperty (dpy, id, name, value)
260 :     fun putStrProp (_, NONE) = ()
261 :     | putStrProp (atom, SOME s) = putProp (atom, makeStringProp s)
262 :     in
263 :     putStrProp (A.atom_WM_NAME, win_name);
264 :     putStrProp (A.atom_WM_ICON_NAME, icon_name);
265 :     putProp (A.atom_WM_NORMAL_HINTS, makeWMSizeHints size_hints);
266 :     putProp (A.atom_WM_HINTS, makeWMHints wm_hints);
267 :     case class_hints
268 :     of SOME{res_name, res_class} =>
269 :     putProp (A.atom_WM_CLASS,
270 :     makeStringProp (String.concat[res_name, "\000", res_class]))
271 :     | NONE => ()
272 :     (* end case *);
273 :     case argv
274 :     of [] => ()
275 :     | _ => putProp (A.atom_WM_COMMAND, makeCommandHints(argv))
276 :     (* end case *)
277 :     end
278 : monnier 2
279 :     (* Set the window-manager protocols for a window *)
280 :     fun setWMProtocols win atoml = let
281 : mblume 1911 open XProtTypes XProps
282 :     val WIN{id, scr=SCREEN{dpy, ...}, ...} = win
283 :     fun putProp n a = setProperty (dpy, id, n, makeAtomProp a)
284 : monnier 2 in
285 :     case (XAtoms.lookupAtom dpy "WM_PROTOCOLS")
286 : mblume 1911 of NONE => false
287 : monnier 2 | (SOME protocols_atom) => (app (putProp protocols_atom) atoml; true)
288 : mblume 1911 (* end case *)
289 : monnier 2 end
290 :    
291 :     (* Map window configuration values to a value list *)
292 :     fun doConfigVal arr = let
293 : mblume 1911 fun upd (i, v) = Array.update(arr, i, SOME v)
294 :     in
295 :     fn (WC_Origin(PT{x, y})) => (
296 :     upd(0, Word.fromInt x); upd(1, Word.fromInt y))
297 :     | (WC_Size(SIZE{wid, ht})) => (
298 :     upd(2, Word.fromInt wid); upd(3, Word.fromInt ht))
299 :     | (WC_BorderWid wid) => upd(4, Word.fromInt wid)
300 :     | (WC_StackMode mode) => (
301 :     Array.update(arr, 5, NONE);
302 :     upd(6, XCvtFuns.stackModeToWire mode))
303 :     | (WC_RelStackMode(WIN{id=(XID x), ...}, mode)) => (
304 :     upd(5, x); upd(6, XCvtFuns.stackModeToWire mode))
305 :     end
306 : monnier 2 val doConfigVals = XCvtFuns.doValList 7 doConfigVal
307 :    
308 :     fun configureWin (WIN{id, scr=SCREEN{dpy, ...}, ...}) vals =
309 : mblume 1911 dpyRequest dpy (XRequest.encodeConfigureWindow{
310 :     win = id, vals = doConfigVals vals
311 :     })
312 : monnier 2
313 :     fun moveWin win pt = configureWin win [WC_Origin pt]
314 :    
315 :     fun resizeWin win sz = configureWin win [WC_Size sz]
316 :    
317 :     fun moveAndResizeWin win (RECT{x, y, wid, ht}) = configureWin win [
318 : mblume 1911 WC_Origin(PT{x=x, y=y}), WC_Size(SIZE{wid=wid, ht=ht})
319 :     ]
320 : monnier 2
321 :     (* Map a window *)
322 :     fun mapWin (WIN{id, scr=SCREEN{dpy, ...}, ...}) = (
323 : mblume 1911 dpyRequest dpy (XRequest.encodeMapWindow{win=id});
324 :     dpyFlushOut dpy)
325 : monnier 2
326 :     (* Unmap a window *)
327 :     fun unmapWin (WIN{id, scr=SCREEN{dpy, ...}, ...}) = (
328 : mblume 1911 dpyRequest dpy (XRequest.encodeUnmapWindow{win=id});
329 :     dpyFlushOut dpy)
330 : monnier 2
331 :     (* Withdraw (unmap and notify window manager) a top-level window *)
332 :     local
333 :     open XEventTypes
334 :     val mask = maskOfXEvtList[XEVT_SubstructureNotify,
335 :     XEVT_SubstructureRedirect]
336 :     in
337 :     fun withdrawWin (WIN{id, scr=SCREEN{scr=SCR{xscr,...}, dpy}, ...}) = let
338 :     val XDisplay.XSCR{root,...} = xscr
339 :     in
340 : mblume 1911 dpyRequest dpy (XSendEvent.encodeSendUnmapNotify
341 :     {dst=SendEvtTo_Window root, propagate=false, evt_mask=mask,
342 : monnier 2 event=root, window=id, from_configure=false});
343 : mblume 1911 dpyFlushOut dpy
344 : monnier 2 end
345 :     end (* local *)
346 :    
347 :     (* Destroy a window. We do this via the draw-master, to avoid a race with any
348 :     * pending draw requests on the window.
349 :     *)
350 :     fun destroyWin (WIN{id, draw_cmd, ...}) =
351 :     draw_cmd(DrawMaster.DMSG_Destroy(DrawMaster.DSTRY_Win id))
352 :    
353 :     (* map a point in the window's coordinate system to the screen's
354 :     * coordinate system *)
355 :     fun winPtToScrPt (WIN{id, scr, ...}) pt = let
356 : mblume 1911 val SCREEN{dpy, scr=SCR{xscr=XDisplay.XSCR{root, ...}, ...}, ...} = scr
357 :     val {dst_pt, ...} = XReply.decodeTranslateCoordsReply (
358 :     CML.sync (dpyRequestReply dpy
359 :     (XRequest.encodeTranslateCoords{
360 :     src_win=id, dst_win=root, src_pt=pt
361 :     })))
362 :     in
363 :     dst_pt
364 :     end
365 : monnier 2
366 :     (* set the cursor of the window *)
367 :     fun setCursor (WIN{id, scr, ...}) c = let
368 : mblume 1911 val SCREEN{dpy=DPY{xdpy=XDisplay.XDPY{conn, ...}, ...}, ...} = scr
369 :     val cur = (case c
370 :     of NONE => XWV_Cursor_None
371 :     | (SOME(Cursor.CURSOR{id, ...})) => XWV_Cursor id
372 :     (* end case *))
373 :     in
374 :     XWin.changeXWinAttrs conn (id, [cur])
375 :     end
376 : monnier 2
377 :     (* set the background color attribute of the window. Note that this does
378 :     * not have an immediate affect on the window's contents, but if it is done
379 :     * before the window is mapped, the window will come up with the right color.
380 :     *)
381 :     fun setBackground (WIN{id, scr, ...}) color = let
382 : mblume 1911 val SCREEN{dpy=DPY{xdpy=XDisplay.XDPY{conn, ...}, ...}, ...} = scr
383 :     val color = (case color
384 :     of NONE => XWV_BackgroundPixmap_ParentRelative
385 :     | (SOME c) => XWV_BackgroundPixel(pixelOf c)
386 :     (* end case *))
387 :     in
388 :     XWin.changeXWinAttrs conn (id, [color])
389 :     end (* setBackground *)
390 : monnier 2
391 :     (* Set various window attributes *)
392 :     fun changeWinAttrs (WIN{id, scr, ...}) = let
393 : mblume 1911 val SCREEN{dpy=DPY{xdpy=XDisplay.XDPY{conn, ...}, ...}, ...} = scr
394 :     val change = XWin.changeXWinAttrs conn
395 :     in
396 :     fn attrs => change (id, map winAttrToXWinAttr attrs)
397 :     end (* changeWinAttrs *)
398 : monnier 2
399 :     fun screenOfWin (WIN{scr, ...}) = scr
400 :     fun displayOfWin (WIN{scr=SCREEN{dpy, ...}, ...}) = dpy
401 :    
402 : mblume 1911 (* added ddeboer Jan 2005 *)
403 :     (* grabKeyboard: we would like a reply of XProtTypes.GrabSuccess *)
404 :     fun grabKeyboard (WIN{id,scr=SCREEN{dpy, ...}, ...}) = 0
405 :     (* commented out, ddeboer, mar 2005 - this needs reworked.
406 :     let val ans =
407 :     (XReply.decodeGrabKeyboardReply (CML.sync (Display.dpyRequestReply dpy
408 :     (XRequest.encodeGrabKeyboard {
409 :     win=id, * type XTy.XID *
410 :     owner_evts=false,
411 :     ptr_mode=XProtTypes.AsynchronousGrab,
412 :     kbd_mode=XProtTypes.AsynchronousGrab,
413 :     time=XProtTypes.CurrentTime}))))
414 :     handle XIo.LostReply => raise (MLXError.XERROR "[reply lost]")
415 :     | (XIo.ErrorReply err) =>
416 :     raise (MLXError.XERROR(XPrint.xerrorToString err))
417 :     in (case (ans) of
418 :     XProtTypes.GrabSuccess => 0
419 :     | XProtTypes.AlreadyGrabbed => 1
420 :     | XProtTypes.GrabInvalidTime => 2
421 :     | XProtTypes.GrabNotViewable => 3
422 :     | XProtTypes.GrabFrozen => 4)
423 :     end *)
424 :     fun ungrabKeyboard (WIN{id,scr=SCREEN{dpy, ...}, ...}) =
425 :     let val ans =
426 :     ( (* XReply.decodeGrabKeyboardReply *) (CML.sync (Display.dpyRequestReply dpy
427 :     (XRequest.encodeUngrabKeyboard {
428 :     time=XProtTypes.CurrentTime}))))
429 :     handle XIo.LostReply => raise (MLXError.XERROR "[reply lost]")
430 :     | (XIo.ErrorReply err) =>
431 :     raise (MLXError.XERROR(XPrint.xerrorToString err))
432 :     in (* TODO: figure out what type of reply comes from an ungrab request, and decode it *)
433 :     0
434 :     end
435 :     (* end added ddeboer *)
436 : monnier 2 end (* Window *)

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