StdMenu.icl 20.2 KB
Newer Older
Peter Achten's avatar
Peter Achten committed
1
2
3
implementation module StdMenu


4
//	Clean Object I/O library, version 1.2.1
Peter Achten's avatar
Peter Achten committed
5
6
7
8


import	StdBool, StdList, StdTuple
import	osmenu
9
import	commondef, iostate, menuaccess, menucreate, menudevice, menuinternal, menuitems, StdId
10
11
12
13
14
from	devicesystemstate	import WindowSystemStateGetWindowHandles
from	menudefaccess		import menuDefGetMenuId
from	menuevent			import MenuSystemStateGetMenuHandles, MenuHandlesGetMenuStateHandles
from	StdPSt				import accPIO
from	windowaccess		import getWindowHandlesActiveModalDialog
Peter Achten's avatar
Peter Achten committed
15
16
17
18
19
20
21
22
23


StdMenuFatalError :: String String -> .x
StdMenuFatalError function error
	= FatalError function "StdMenu" error


//	General rules to access MenuHandles:

24
accessMenuHandles :: !Id !((MenuStateHandle (PSt .l)) -> (x,!MenuStateHandle (PSt .l))) !(IOSt .l) -> (!Maybe x,!IOSt .l)
Peter Achten's avatar
Peter Achten committed
25
accessMenuHandles id f ioState
26
27
28
29
30
31
	# (found,mDevice,ioState)	= IOStGetDevice MenuDevice ioState
	| not found
		= (Nothing,ioState)
	# mHs						= MenuSystemStateGetMenuHandles mDevice
	  (result,msHs)				= accessmenuhandles id f mHs.mMenus
	# ioState					= IOStSetDevice (MenuSystemState {mHs & mMenus=msHs}) ioState
Peter Achten's avatar
Peter Achten committed
32
33
	= (result,ioState)
where
34
	accessmenuhandles :: !Id !((MenuStateHandle .pst) -> (x,!MenuStateHandle .pst)) ![MenuStateHandle .pst] -> (!Maybe x,![MenuStateHandle .pst])
Peter Achten's avatar
Peter Achten committed
35
36
37
38
39
40
41
42
43
44
45
	accessmenuhandles id f [mH:mHs]
		# (menu_id,mH)			= menuStateHandleGetMenuId mH
		| id==menu_id
			# (result,mH)		= f mH
			= (Just result,[mH:mHs])
		| otherwise
			# (opt_result,mHs)	= accessmenuhandles id f mHs
			= (opt_result,[mH:mHs])
	accessmenuhandles _ _ _
		= (Nothing,[])

46
changeMenuSystemState :: !Bool
47
						 !(OSMenuBar -> (MenuHandles (PSt .l)) -> *(*OSToolbox -> *(MenuHandles (PSt .l),*OSToolbox)))
48
49
						 !(IOSt .l)
						-> IOSt .l
Peter Achten's avatar
Peter Achten committed
50
changeMenuSystemState redrawMenus f ioState
51
52
53
54
55
56
57
58
59
60
61
	# (osdInfo,ioState)			= IOStGetOSDInfo ioState
	  maybeOSMenuBar			= getOSDInfoOSMenuBar osdInfo
	| isNothing maybeOSMenuBar		// This condition should never hold
		= StdMenuFatalError "changeMenuSystemState" "could not retrieve OSMenuBar from IOSt"
	# osMenuBar					= fromJust maybeOSMenuBar
	# (found,mDevice,ioState)	= IOStGetDevice MenuDevice ioState
	| not found
		= ioState
	# (tb,ioState)				= getIOToolbox ioState
	  menus						= MenuSystemStateGetMenuHandles mDevice
	# (menus,tb)				= f osMenuBar menus tb
Peter Achten's avatar
Peter Achten committed
62
	| not redrawMenus
63
		# ioState				= setIOToolbox tb ioState
Peter Achten's avatar
Peter Achten committed
64
65
		= IOStSetDevice (MenuSystemState menus) ioState
	| otherwise
66
67
68
69
		# tb					= DrawMenuBar osMenuBar tb
		  osdInfo				= setOSDInfoOSMenuBar osMenuBar osdInfo
		# ioState				= IOStSetOSDInfo osdInfo ioState
		# ioState				= setIOToolbox tb ioState
Peter Achten's avatar
Peter Achten committed
70
71
		= IOStSetDevice (MenuSystemState menus) ioState

72
accessMenuSystemState :: !Bool
73
						 !(OSMenuBar -> (MenuHandles (PSt .l)) -> *(*OSToolbox -> *(.x,MenuHandles (PSt .l),*OSToolbox)))
74
75
						 !(IOSt .l)
					-> (!Maybe .x,!IOSt .l)
Peter Achten's avatar
Peter Achten committed
76
accessMenuSystemState redrawMenus f ioState
77
78
79
80
81
82
83
84
85
86
87
	# (osdInfo,ioState)			= IOStGetOSDInfo ioState
	  maybeOSMenuBar			= getOSDInfoOSMenuBar osdInfo
	| isNothing maybeOSMenuBar		// This condition should never hold
		= StdMenuFatalError "accessMenuSystemState" "could not retrieve OSMenuBar from IOSt"
	# osMenuBar					= fromJust maybeOSMenuBar
	# (found,mDevice,ioState)	= IOStGetDevice MenuDevice ioState
	| not found
		= (Nothing,ioState)
	# (tb,ioState)				= getIOToolbox ioState
	  menus						= MenuSystemStateGetMenuHandles mDevice
	# (x,menus,tb)				= f osMenuBar menus tb
Peter Achten's avatar
Peter Achten committed
88
	| not redrawMenus
89
90
		# ioState				= setIOToolbox tb ioState
		= (Just x,IOStSetDevice (MenuSystemState menus) ioState)
Peter Achten's avatar
Peter Achten committed
91
	| otherwise
92
93
94
95
96
		# tb					= DrawMenuBar osMenuBar tb
		  osdInfo				= setOSDInfoOSMenuBar osMenuBar osdInfo
		# ioState				= IOStSetOSDInfo osdInfo ioState
		# ioState				= setIOToolbox tb ioState
		= (Just x,IOStSetDevice (MenuSystemState menus) ioState)
Peter Achten's avatar
Peter Achten committed
97
98
99
100
101


//	Opening a menu for an interactive process.

class Menus mdef where
102
103
	openMenu	:: .ls !(mdef .ls (PSt .l)) !(PSt .l)	-> (!ErrorReport,!PSt .l)
	getMenuType	::      (mdef .ls .pst)					-> MenuType
Peter Achten's avatar
Peter Achten committed
104
105

instance Menus (Menu m)	| MenuElements m where
106
	openMenu :: .ls !(Menu m .ls (PSt .l)) !(PSt .l) -> (!ErrorReport,!PSt .l)	| MenuElements m
Peter Achten's avatar
Peter Achten committed
107
108
109
110
111
112
113
114
115
116
117
118
119
120
	openMenu ls mDef pState
		# pState			= MenuFunctions.dOpen pState
		# (isZero,pState)	= accPIO checkZeroMenuBound pState
		| isZero
			= (ErrorViolateDI,pState)
		# (optMenuId,mDef)	= menuDefGetMenuId mDef
		# (optMenuId,pState)= accPIO (validateMenuId optMenuId) pState
		| isNothing optMenuId
			= (ErrorIdsInUse,pState)
		# menuId			= fromJust optMenuId
		| menuId==WindowMenuId
			= (ErrorIdsInUse,pState)
		| otherwise
			= OpenMenu` menuId ls mDef pState
121
	where
122
		checkZeroMenuBound :: !(IOSt .l) -> (!Bool,!IOSt .l)
123
124
125
126
127
128
129
130
		checkZeroMenuBound ioState
			# (found,mDevice,ioState)	= IOStGetDevice MenuDevice ioState
			| not found					// This condition should never occur
				= StdMenuFatalError "openMenu (Menu)" "could not retrieve MenuSystemState from IOSt"
			# mHs						= MenuSystemStateGetMenuHandles mDevice
			  (bound,mHs)				= (\msHs=:{mNrMenuBound}->(mNrMenuBound,msHs)) mHs
			# ioState					= IOStSetDevice (MenuSystemState mHs) ioState
			= (zeroBound bound,ioState)
Peter Achten's avatar
Peter Achten committed
131
132
133
134
	
	getMenuType :: (Menu m .ls .pst) -> MenuType | MenuElements m
	getMenuType _ = "Menu"

135
validateMenuId :: !(Maybe Id) !(IOSt .l) -> (!Maybe Id,!IOSt .l)
Peter Achten's avatar
Peter Achten committed
136
137
138
139
140
validateMenuId Nothing ioState
	# (mId,ioState)				= openId ioState
	= (Just mId,ioState)
validateMenuId (Just id) ioState
	# (idtable,ioState)			= IOStGetIdTable ioState
141
142
	| memberIdTable id idtable	= (Nothing,IOStSetIdTable idtable ioState)
	| otherwise					= (Just id,IOStSetIdTable idtable ioState)
Peter Achten's avatar
Peter Achten committed
143
144

instance Menus (PopUpMenu m) | PopUpMenuElements m where
145
	openMenu :: .ls !(PopUpMenu m .ls (PSt .l)) !(PSt .l) -> (!ErrorReport,!PSt .l) | PopUpMenuElements m
Peter Achten's avatar
Peter Achten committed
146
	openMenu ls mDef pState
147
		# (osdInfo,pState)			= accPIO IOStGetOSDInfo pState
Peter Achten's avatar
Peter Achten committed
148
149
		| getOSDInfoDocumentInterface osdInfo==NDI
			= (ErrorViolateDI,pState)
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
		# maybeOSMenuBar			= getOSDInfoOSMenuBar osdInfo
		| isNothing maybeOSMenuBar	// This condition should never occur
			= StdMenuFatalError "openMenu (PopUpMen)" "OSMenuBar could not be retrieved from OSDInfo"
		# pState					= MenuFunctions.dOpen pState
		# (found,mDevice,ioState)	= IOStGetDevice MenuDevice pState.io
		| not found
			= (ErrorUnknownObject,{pState & io=ioState})
		# mHs						= MenuSystemStateGetMenuHandles mDevice
		  mHs						= closepopupmenu mHs
		  osMenuBar					= fromJust maybeOSMenuBar
		# (idtable,ioState)			= IOStGetIdTable ioState
		# (rt,ioState)				= IOStGetReceiverTable ioState
		# (ioid,ioState)			= IOStGetIOId ioState
		# (ok,mHs,rt,idtable,osMenuBar,pState)
									= createPopUpMenu ioid ls mDef mHs rt idtable osMenuBar {pState & io=ioState}
	 	  osdInfo					= setOSDInfoOSMenuBar osMenuBar osdInfo
	 	# ioState					= IOStSetOSDInfo osdInfo pState.io
	 	# ioState					= IOStSetReceiverTable rt ioState
	 	# ioState					= IOStSetIdTable idtable ioState
		# ioState					= IOStSetDevice (MenuSystemState mHs) ioState
		# pState					= {pState & io=ioState}
Peter Achten's avatar
Peter Achten committed
171
172
173
174
175
176
		| ok
			= handlePopUpMenu pState
		| otherwise
			= (ErrorIdsInUse,pState)
	where
	//	handlePopUpMenu opens the pop up menu.
177
		handlePopUpMenu :: !(PSt .l) -> (!ErrorReport,!PSt .l)
Peter Achten's avatar
Peter Achten committed
178
		handlePopUpMenu pState
179
180
181
182
183
184
185
186
			# (osdInfo,ioState)			= IOStGetOSDInfo pState.io
			  framePtr					= case (getOSDInfoOSInfo osdInfo) of
			  								Just info -> info.osFrame
			  								nothing   -> StdMenuFatalError "openMenu (PopUpMenu)" "incorrect OSDInfo retrieved"
			# (found,mDevice,ioState)	= IOStGetDevice MenuDevice ioState
			| not found					// This condition should never occur
				= StdMenuFatalError "openMenu (PopUpMenu)" "could not retrieve MenuSystemState from IOSt"
			# mHs						= MenuSystemStateGetMenuHandles mDevice
187
			  (menus,mHs)				= menuHandlesGetMenus mHs
188
189
190
191
			  (popUpMenu,menus)			= HdTl menus
			  (popUpId,popUpMenu)		= menuStateHandleGetMenuId popUpMenu
			  (mPtr,popUpMenu)			= menuStateHandleGetHandle popUpMenu
			# (ok,ioState)				= accIOToolbox (OStrackPopUpMenu mPtr framePtr) ioState
Peter Achten's avatar
Peter Achten committed
192
			| not ok
193
194
				# ioState				= IOStSetDevice (MenuSystemState {mHs & mMenus=menus,mPopUpId=Just popUpId}) ioState
				# pState				= {pState & io=ioState}
Peter Achten's avatar
Peter Achten committed
195
196
				= (OtherError "PopUpMenu tracking error",pState)
			| otherwise
197
198
				# ioState				= IOStSetDevice (MenuSystemState {mHs & mMenus=[popUpMenu:menus]}) ioState
				# pState				= {pState & io=ioState}
Peter Achten's avatar
Peter Achten committed
199
200
201
202
203
204
205
206
				= (NoError,pState)
	
	getMenuType :: (PopUpMenu m .ls .pst) -> MenuType | PopUpMenuElements m
	getMenuType _ = "PopUpMenu"


//	Closing a menu.

207
closeMenu :: !Id !(IOSt .l) -> IOSt .l
Peter Achten's avatar
Peter Achten committed
208
209
210
211
212
213
214
closeMenu id ioState
	| id==WindowMenuId	= ioState
	| otherwise			= closemenu id ioState


//	Enabling and Disabling of the MenuSystem:

215
enableMenuSystem :: !(IOSt .l) -> IOSt .l
Peter Achten's avatar
Peter Achten committed
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
enableMenuSystem ioState
/*	# (optModal,ioState)	= IOStGetIOIsModal ioState
	# (ioId,    ioState)	= IOStGetIOId ioState
	  modalId				= fromJust optModal
	| isJust optModal && ioId==modalId
		= ioState */
	# (isModal,ioState)		= hasModalDialog ioState
	| isModal
		= ioState
	# (di,ioState)			= IOStGetDocumentInterface ioState
	| di==NDI
		= ioState
	| otherwise
		= changeMenuSystemState True (enablemenusystem di) ioState
where
231
	hasModalDialog :: !(IOSt .l) -> (!Bool,!IOSt .l)
Peter Achten's avatar
Peter Achten committed
232
	hasModalDialog ioState
233
234
235
236
237
238
		# (found,wDevice,ioState)	= IOStGetDevice WindowDevice ioState
		| not found
			= (False,ioState)
		# windows					= WindowSystemStateGetWindowHandles wDevice
		  (modalWIDS,windows)		= getWindowHandlesActiveModalDialog windows
		# ioState					= IOStSetDevice (WindowSystemState windows) ioState
Peter Achten's avatar
Peter Achten committed
239
240
		= (isJust modalWIDS,ioState)
	
241
242
	enablemenusystem :: !DocumentInterface !OSMenuBar !(MenuHandles .pst) !*OSToolbox -> (!MenuHandles .pst,!*OSToolbox)
	enablemenusystem di osMenuBar menus=:{mEnabled,mMenus} tb
Peter Achten's avatar
Peter Achten committed
243
244
245
246
		| mEnabled
			= (menus,tb)
		| otherwise
			# (nrMenus,msHs)= Ulength mMenus
247
			# tb			= enablemenus (if (di==MDI) (nrMenus+1) (nrMenus-1)) osMenuBar tb
Peter Achten's avatar
Peter Achten committed
248
249
250
251
252
			= ({menus & mMenus=msHs,mEnabled=SystemAble},tb)
	where
		enablemenus :: !Int !OSMenuBar !*OSToolbox -> *OSToolbox
		enablemenus i osmenubar tb
			| i<0			= tb
253
			| otherwise		= enablemenus (i-1) osMenuBar (OSEnableMenu i osMenuBar tb)
Peter Achten's avatar
Peter Achten committed
254

255
disableMenuSystem :: !(IOSt .l) -> IOSt .l
Peter Achten's avatar
Peter Achten committed
256
257
258
259
260
disableMenuSystem ioState
	# (di,ioState)	= IOStGetDocumentInterface ioState
	| di==NDI		= ioState
	| otherwise		= changeMenuSystemState True (disablemenusystem di) ioState
where
261
262
	disablemenusystem :: !DocumentInterface !OSMenuBar !(MenuHandles .pst) !*OSToolbox -> (!MenuHandles .pst,!*OSToolbox)
	disablemenusystem di osMenuBar menus=:{mEnabled,mMenus} tb
Peter Achten's avatar
Peter Achten committed
263
264
265
266
		| not mEnabled
			= (menus,tb)
		| otherwise
			# (nrMenus,msHs)= Ulength mMenus
267
			# tb			= disablemenus (if (di==MDI) (nrMenus+1) (nrMenus-1)) osMenuBar tb
Peter Achten's avatar
Peter Achten committed
268
269
270
			= ({menus & mMenus=msHs,mEnabled=SystemUnable},tb)
	where
		disablemenus :: !Int !OSMenuBar !*OSToolbox -> *OSToolbox
271
		disablemenus i osMenuBar tb
Peter Achten's avatar
Peter Achten committed
272
			| i<0			= tb
273
			| otherwise		= disablemenus (i-1) osMenuBar (OSDisableMenu i osMenuBar tb)
Peter Achten's avatar
Peter Achten committed
274
275
276
277


//	Enabling and Disabling of Menus:

278
enableMenus :: ![Id] !(IOSt .l) -> IOSt .l
Peter Achten's avatar
Peter Achten committed
279
280
281
282
283
enableMenus ids ioState
	# ids			= filter ((<>) WindowMenuId) ids
	| isEmpty ids	= ioState
	| otherwise		= enablemenus ids ioState

284
disableMenus :: ![Id] !(IOSt .l) -> IOSt .l
Peter Achten's avatar
Peter Achten committed
285
286
287
288
289
290
291
292
disableMenus ids ioState
	# ids			= filter ((<>) WindowMenuId) ids
	| isEmpty ids	= ioState
	| otherwise		= disablemenus ids ioState


//	Get the SelectState of a menu: 

293
getMenuSelectState :: !Id !(IOSt .l) -> (!Maybe SelectState,!IOSt .l)
Peter Achten's avatar
Peter Achten committed
294
295
296
297
298
299
300
301
302
303
304
305
306
307
getMenuSelectState id ioState
	# (optSelect,ioState)	= accessMenuHandles id menuStateHandleGetSelect ioState
	| isNothing optSelect	= (Nothing,		ioState)
	| fromJust optSelect	= (Just Able,	ioState)
	| otherwise				= (Just Unable,	ioState)


/*	Adding menu elements to (sub/radio)menus:
		Items in a (sub/radio)menu are positioned starting from 1 and increasing by 1.
		Open with a position less than 1 adds the new elements in front
		Open with a position higher than the number of items adds the new elements to
		the end.
		Open an item on a position adds the item AFTER the item on that position.
*/
308
openMenuElements :: !Id !Index .ls (m .ls (PSt .l)) !(PSt .l) -> (!ErrorReport,!PSt .l) | MenuElements m
Peter Achten's avatar
Peter Achten committed
309
openMenuElements mId pos ls new pState
310
	# (it,ioState)					= IOStGetIdTable pState.io
311
	# (maybeParent,it)				= getIdParent mId it
Peter Achten's avatar
Peter Achten committed
312
	| isNothing maybeParent
313
		= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
314
	# parent						= fromJust maybeParent
Peter Achten's avatar
Peter Achten committed
315
	| parent.idpDevice<>MenuDevice
316
		= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
317
	# (pid,ioState)					= IOStGetIOId ioState
Peter Achten's avatar
Peter Achten committed
318
	| parent.idpIOId<>pid
319
		= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
Peter Achten's avatar
Peter Achten committed
320
	| parent.idpId<>mId
321
		= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
322
323
	# (found,mDevice,ioState)		= IOStGetDevice MenuDevice ioState
	| not found
324
		= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
325
326
	# (osdInfo,ioState)				= IOStGetOSDInfo ioState
	  maybeOSMenuBar				= getOSDInfoOSMenuBar osdInfo
327
	| isNothing maybeOSMenuBar		// This condition should not occur
328
		= StdMenuFatalError "openMenuElements" "OSMenuBar could not be retrieved from OSDInfo"
Peter Achten's avatar
Peter Achten committed
329
	| otherwise
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
		# osMenuBar					= fromJust maybeOSMenuBar
		# (rt, ioState)				= IOStGetReceiverTable ioState
		# (tb, ioState)				= getIOToolbox ioState
		# pState					= {pState & io=ioState}
		  menus						= MenuSystemStateGetMenuHandles mDevice
		# ((error,rt,it),menus,osMenuBar,pState)
									= addMenusItems (mId,Nothing) (max 0 pos) ls new pid rt it menus osMenuBar pState
		# ioState					= setIOToolbox (DrawMenuBar osMenuBar tb) pState.io
		  mDevice					= MenuSystemState menus
		  osdInfo					= setOSDInfoOSMenuBar osMenuBar osdInfo
		# ioState					= IOStSetOSDInfo osdInfo ioState
		# ioState					= IOStSetDevice mDevice ioState
		# ioState					= IOStSetIdTable it ioState
		# ioState					= IOStSetReceiverTable rt ioState
		# pState					= {pState & io=ioState}
Peter Achten's avatar
Peter Achten committed
345
346
		= (error,pState)

347
openSubMenuElements :: !Id !Index .ls (m .ls (PSt .l)) !(PSt .l) -> (!ErrorReport,!PSt .l)	| MenuElements m
Peter Achten's avatar
Peter Achten committed
348
openSubMenuElements sId pos ls new pState
349
	# (it,ioState)				= IOStGetIdTable pState.io
350
	# (maybeParent,it)			= getIdParent sId it
Peter Achten's avatar
Peter Achten committed
351
	| isNothing maybeParent
352
		= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
353
	# parent					= fromJust maybeParent
Peter Achten's avatar
Peter Achten committed
354
	| parent.idpDevice<>MenuDevice
355
		= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
356
	# (pid,ioState)				= IOStGetIOId ioState
Peter Achten's avatar
Peter Achten committed
357
	| parent.idpIOId<>pid
358
		= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
359
360
	# (found,mDevice,ioState)	= IOStGetDevice MenuDevice ioState
	| not found
361
		= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
362
363
	# (osdInfo,ioState)			= IOStGetOSDInfo ioState
	  maybeOSMenuBar			= getOSDInfoOSMenuBar osdInfo
364
	| isNothing maybeOSMenuBar	// This condition should not occur
365
		= StdMenuFatalError "openSubMenuElements" "OSMenuBar could not be retrieved from OSDInfo"
Peter Achten's avatar
Peter Achten committed
366
	| otherwise
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
		# osMenuBar				= fromJust maybeOSMenuBar
		# (rt,ioState)			= IOStGetReceiverTable ioState
		# (tb,ioState)			= getIOToolbox ioState
		# pState				= {pState & io=ioState}
		  menus					= MenuSystemStateGetMenuHandles mDevice
		# ((error,rt,it),menus,osMenuBar,pState)
								= addMenusItems (parent.idpId,Just sId) (max 0 pos) ls new pid rt it menus osMenuBar pState
		# ioState				= setIOToolbox (DrawMenuBar osMenuBar tb) pState.io
		  mDevice				= MenuSystemState menus
		  osdInfo				= setOSDInfoOSMenuBar osMenuBar osdInfo
		# ioState				= IOStSetOSDInfo osdInfo ioState
		# ioState				= IOStSetDevice mDevice ioState
		# ioState				= IOStSetIdTable it ioState
		# ioState				= IOStSetReceiverTable rt ioState
		# pState				= {pState & io=ioState}
Peter Achten's avatar
Peter Achten committed
382
383
		= (error,pState)

384
openRadioMenuItems :: !Id !Index ![MenuRadioItem (PSt .l)] !(IOSt .l) -> (!ErrorReport,!IOSt .l)
Peter Achten's avatar
Peter Achten committed
385
386
openRadioMenuItems rId pos radioItems ioState
	# (idtable,ioState)		= IOStGetIdTable ioState
387
	# (maybeParent,idtable)	= getIdParent rId idtable
Peter Achten's avatar
Peter Achten committed
388
	| isNothing maybeParent
389
		= (ErrorUnknownObject,IOStSetIdTable idtable ioState)
Peter Achten's avatar
Peter Achten committed
390
391
	# parent				= fromJust maybeParent
	| parent.idpDevice<>MenuDevice
392
		= (ErrorUnknownObject,IOStSetIdTable idtable ioState)
Peter Achten's avatar
Peter Achten committed
393
394
	# (ioId,ioState)		= IOStGetIOId ioState
	| parent.idpIOId<>ioId
395
		= (ErrorUnknownObject,IOStSetIdTable idtable ioState)
Peter Achten's avatar
Peter Achten committed
396
	| isEmpty radioItems
397
		= (NoError,IOStSetIdTable idtable ioState)
Peter Achten's avatar
Peter Achten committed
398
399
	# radioIds				= FilterMap (\(_,maybeId,_,_)->(isJust maybeId,fromJust maybeId)) radioItems
	| not (okMembersIdTable radioIds idtable)
400
		= (ErrorIdsInUse,IOStSetIdTable idtable ioState)
Peter Achten's avatar
Peter Achten committed
401
402
403
404
	| otherwise
		# mId				= parent.idpId
		# (error,ioState)	= accessMenuSystemState True (addMenuRadioItems (mId,rId) (max 0 pos) radioItems) ioState
		# ioState			= IOStSetIdTable (snd (addIdsToIdTable (map (\id->(id,{idpIOId=ioId,idpDevice=MenuDevice,idpId=mId})) radioIds) idtable)) ioState
405
406
407
		  error				= case error of
		  						Nothing  -> ErrorUnknownObject
		  						Just err -> err
Peter Achten's avatar
Peter Achten committed
408
409
410
411
412
		= (error,ioState)


//	Removing menu elements from (sub/radio)menus:

413
closeMenuElements :: !Id ![Id] !(IOSt .l) -> IOSt .l
Peter Achten's avatar
Peter Achten committed
414
415
416
417
418
419
420
421
closeMenuElements mId ids ioState
	# ids			= filter (\id->not (isSpecialId id)) ids
	| isEmpty ids	= ioState
	| otherwise		= closemenuelements mId ids ioState


//	Removing menu elements from (sub/radio)menus by index (counting from 1):

422
closeMenuIndexElements :: !Id ![Index] !(IOSt .l) -> IOSt .l
Peter Achten's avatar
Peter Achten committed
423
closeMenuIndexElements mId indices ioState
424
425
426
	# (idtable,ioState)		= IOStGetIdTable ioState
	# (maybeParent,idtable)	= getIdParent mId idtable
	# ioState				= IOStSetIdTable idtable ioState
Peter Achten's avatar
Peter Achten committed
427
428
	| isNothing maybeParent
		= ioState
429
	# parent				= fromJust maybeParent
Peter Achten's avatar
Peter Achten committed
430
431
	| parent.idpDevice<>MenuDevice
		= ioState
432
	# (ioId,ioState)		= IOStGetIOId ioState
Peter Achten's avatar
Peter Achten committed
433
434
435
436
437
	| parent.idpIOId<>ioId || parent.idpId<>mId
		= ioState
	| otherwise
		= closemenuindexelements NotRemoveSpecialMenuElements False ioId (mId,Nothing) indices ioState

438
closeSubMenuIndexElements :: !Id ![Index] !(IOSt .l) -> IOSt .l
Peter Achten's avatar
Peter Achten committed
439
closeSubMenuIndexElements sId indices ioState
440
441
442
	# (idtable,ioState)		= IOStGetIdTable ioState
	# (maybeParent,idtable)	= getIdParent sId idtable
	# ioState				= IOStSetIdTable idtable ioState
Peter Achten's avatar
Peter Achten committed
443
444
	| isNothing maybeParent
		= ioState
445
	# parent				= fromJust maybeParent
Peter Achten's avatar
Peter Achten committed
446
447
	| parent.idpDevice<>MenuDevice
		= ioState
448
	# (ioId,ioState)		= IOStGetIOId ioState
Peter Achten's avatar
Peter Achten committed
449
450
451
452
453
	| parent.idpIOId<>ioId
		= ioState
	| otherwise
		= closemenuindexelements NotRemoveSpecialMenuElements False ioId (parent.idpId,Just sId) indices ioState

454
closeRadioMenuIndexElements :: !Id ![Index] !(IOSt .l) -> IOSt .l
Peter Achten's avatar
Peter Achten committed
455
closeRadioMenuIndexElements rId indices ioState
456
457
458
	# (idtable,ioState)		= IOStGetIdTable ioState
	# (maybeParent,idtable)	= getIdParent rId idtable
	# ioState				= IOStSetIdTable idtable ioState
Peter Achten's avatar
Peter Achten committed
459
460
	| isNothing maybeParent
		= ioState
461
	# parent				= fromJust maybeParent
Peter Achten's avatar
Peter Achten committed
462
463
	| parent.idpDevice<>MenuDevice
		= ioState
464
	# (ioId,ioState)		= IOStGetIOId ioState
Peter Achten's avatar
Peter Achten committed
465
466
467
468
469
470
471
472
	| parent.idpIOId<>ioId
		= ioState
	| otherwise
		= closemenuindexelements NotRemoveSpecialMenuElements True ioId (parent.idpId,Just rId) indices ioState


//	Determine the Ids and MenuTypes of all menus.

473
getMenus :: !(IOSt .l) -> (![(Id,MenuType)],!IOSt .l)
Peter Achten's avatar
Peter Achten committed
474
getMenus ioState
475
476
477
	# (found,mDevice,ioState)	= IOStGetDevice MenuDevice ioState
	| not found
		= ([],ioState)
478
479
480
481
482
	| otherwise
		# mHs					= MenuSystemStateGetMenuHandles mDevice
		  (idtypes,msHs)		= AccessList getIdType mHs.mMenus
		# ioState				= IOStSetDevice (MenuSystemState {mHs & mMenus=msHs}) ioState
		= (tl idtypes,ioState)
Peter Achten's avatar
Peter Achten committed
483
where
484
	getIdType :: !(MenuStateHandle .pst) -> *((Id,MenuType),!MenuStateHandle .pst)
Peter Achten's avatar
Peter Achten committed
485
	getIdType msH
486
		# (id,msH)				= menuStateHandleGetMenuId msH
Peter Achten's avatar
Peter Achten committed
487
488
489
490
491
		= ((id,"Menu"),msH)


//	Determine the index position of a menu.

492
getMenuPos :: !Id !(IOSt .l) -> (!Maybe Index,!IOSt .l)
Peter Achten's avatar
Peter Achten committed
493
getMenuPos id ioState
494
495
496
	# (found,mDevice,ioState)	= IOStGetDevice MenuDevice ioState
	| not found
		= (Nothing,ioState)
497
498
499
500
501
	| otherwise
		# mHs					= MenuSystemStateGetMenuHandles mDevice
		  (optIndex,msHs)		= getmenuindex id 0 mHs.mMenus
		# ioState				= IOStSetDevice (MenuSystemState {mHs & mMenus=msHs}) ioState
		= (optIndex,ioState)
Peter Achten's avatar
Peter Achten committed
502
where
503
	getmenuindex :: !Id !Int ![MenuStateHandle .pst] -> (!Maybe Int,![MenuStateHandle .pst])
Peter Achten's avatar
Peter Achten committed
504
	getmenuindex id index [mH:mHs]
505
		# (menu_id,mH)			= menuStateHandleGetMenuId mH
Peter Achten's avatar
Peter Achten committed
506
507
508
		| id==menu_id
			= (Just index,[mH:mHs])
		| otherwise
509
			# (optIndex,mHs)	= getmenuindex id (index+1) mHs
Peter Achten's avatar
Peter Achten committed
510
511
512
513
514
515
516
			= (optIndex, [mH:mHs])
	getmenuindex _ _ _
		= (Nothing,[])


//	Set & Get the title of a menu.

517
setMenuTitle :: !Id !Title !(IOSt .l) -> IOSt .l
Peter Achten's avatar
Peter Achten committed
518
519
520
521
setMenuTitle id title ioState
	| id==WindowMenuId	= ioState
	| otherwise			= setmenutitle id title ioState

522
getMenuTitle :: !Id !(IOSt .l) -> (!Maybe Title,!IOSt .l)
Peter Achten's avatar
Peter Achten committed
523
524
getMenuTitle id ioState
	= accessMenuHandles id menuStateHandleGetTitle ioState