Commit 1e5829e9 authored by Peter Achten's avatar Peter Achten

(PA) added uniqueness so that 'Reuse Unique Nodes'

code generation can be applied in more cases.
parent 4dc496e3
......@@ -86,12 +86,12 @@ where
where
recLoc = getMsgEventRecLoc msgEvent
hasMenuHandlesMenu :: !Id !(MenuHandles .pst) -> (!Bool,!MenuHandles .pst)
hasMenuHandlesMenu :: !Id !*(MenuHandles .pst) -> (!Bool,!*MenuHandles .pst)
hasMenuHandlesMenu menuId mHs=:{mMenus}
# (found,mMenus)= UContains (eqMenuId menuId) mMenus
= (found,{mHs & mMenus=mMenus})
where
eqMenuId :: !Id !(MenuStateHandle .pst) -> *(!Bool,!MenuStateHandle .pst)
eqMenuId :: !Id !*(MenuStateHandle .pst) -> *(!Bool,!*MenuStateHandle .pst)
eqMenuId theId msH
# (mId,msH) = menuStateHandleGetMenuId msH
= (theId==mId,msH)
......@@ -164,10 +164,11 @@ filterOSEvent {ccMsg=CcWmCOMMAND,p1=item,p2=mods} _ menus=:{mEnabled,mMenus=mHs}
# (found,deviceEvent,mHs,tb)= getSelectedMenuStateHandlesItem item mods mHs tb
= (found,Nothing,deviceEvent,{menus & mMenus=mHs},tb)
where
getSelectedMenuStateHandlesItem :: !Int !Int ![MenuStateHandle .pst] !*OSToolbox
-> (!Bool,!Maybe DeviceEvent,![MenuStateHandle .pst],!*OSToolbox)
getSelectedMenuStateHandlesItem :: !Int !Int !*[*MenuStateHandle .pst] !*OSToolbox
-> (!Bool,!Maybe DeviceEvent,!*[*MenuStateHandle .pst],!*OSToolbox)
getSelectedMenuStateHandlesItem item mods msHs tb
| isEmpty msHs
# (empty,msHs) = u_isEmpty msHs
| empty
= (False,Nothing,msHs,tb)
# (msH,msHs) = HdTl msHs
# (found,menuEvent,msH,tb) = getSelectedMenuStateHandleItem item mods msH tb
......@@ -177,8 +178,8 @@ where
# (found,menuEvent,msHs,tb) = getSelectedMenuStateHandlesItem item mods msHs tb
= (found,menuEvent,[msH:msHs],tb)
where
getSelectedMenuStateHandleItem :: !Int !Int !(MenuStateHandle .pst) !*OSToolbox
-> (!Bool,!Maybe DeviceEvent,!MenuStateHandle .pst, !*OSToolbox)
getSelectedMenuStateHandleItem :: !Int !Int !*(MenuStateHandle .pst) !*OSToolbox
-> (!Bool,!Maybe DeviceEvent,!*MenuStateHandle .pst, !*OSToolbox)
getSelectedMenuStateHandleItem item mods msH=:(MenuLSHandle mlsH=:{mlsHandle=mH=:{mSelect,mHandle,mMenuId,mItems}}) tb
| not mSelect
= (False,Nothing,msH,tb)
......@@ -186,10 +187,11 @@ where
# (found,menuEvent,_,_,itemHs,tb) = getSelectedMenuElementHandlesItem item mHandle mMenuId mods [] 0 mItems tb
= (found,menuEvent,MenuLSHandle {mlsH & mlsHandle={mH & mItems=itemHs}},tb)
where
getSelectedMenuElementHandlesItem :: !Int !OSMenu !Id !Int ![Int] !Int ![MenuElementHandle .ls .pst] !*OSToolbox
-> (!Bool,!Maybe DeviceEvent,![Int],!Int,![MenuElementHandle .ls .pst],!*OSToolbox)
getSelectedMenuElementHandlesItem :: !Int !OSMenu !Id !Int ![Int] !Int !*[*MenuElementHandle .ls .pst] !*OSToolbox
-> (!Bool,!Maybe DeviceEvent,![Int],!Int,!*[*MenuElementHandle .ls .pst],!*OSToolbox)
getSelectedMenuElementHandlesItem item mH menuId mods parents zIndex itemHs tb
| isEmpty itemHs
# (empty,itemHs) = u_isEmpty itemHs
| empty
= (False,Nothing,parents,zIndex,itemHs,tb)
# (itemH,itemHs) = HdTl itemHs
# (found,menuEvent,parents,zIndex,itemH,tb) = getSelectedMenuElementHandle item mH menuId mods parents zIndex itemH tb
......@@ -199,8 +201,8 @@ where
# (found,menuEvent,parents,zIndex,itemHs,tb)= getSelectedMenuElementHandlesItem item mH menuId mods parents zIndex itemHs tb
= (found,menuEvent,parents,zIndex,[itemH:itemHs],tb)
where
getSelectedMenuElementHandle :: !Int !OSMenu !Id !Int ![Int] !Int !(MenuElementHandle .ls .pst) !*OSToolbox
-> (!Bool,!Maybe DeviceEvent,![Int],!Int, !MenuElementHandle .ls .pst, !*OSToolbox)
getSelectedMenuElementHandle :: !Int !OSMenu !Id !Int ![Int] !Int !*(MenuElementHandle .ls .pst) !*OSToolbox
-> (!Bool,!Maybe DeviceEvent,![Int],!Int, !*MenuElementHandle .ls .pst, !*OSToolbox)
getSelectedMenuElementHandle item mH menuId mods parents zIndex itemH=:(MenuItemHandle {mOSMenuItem,mItemId}) tb
| item==mOSMenuItem
......@@ -218,7 +220,7 @@ where
parents = if found parents1 parents
= (found,menuEvent,parents,zIndex+1,itemH,tb)
getSelectedMenuElementHandle item mH menuId mods parents zIndex (RadioMenuHandle rH=:{mRadioSelect,mRadioItems=itemHs,mRadioIndex}) tb
/* getSelectedMenuElementHandle item mH menuId mods parents zIndex (RadioMenuHandle rH=:{mRadioSelect,mRadioItems=itemHs,mRadioIndex}) tb
# (nrRadios,itemHs) = Ulength itemHs
| not mRadioSelect
= (False,Nothing,parents,zIndex+nrRadios,RadioMenuHandle {rH & mRadioItems=itemHs},tb)
......@@ -238,6 +240,29 @@ where
where
getMenuItemOSMenuItem :: !(MenuElementHandle .ls .pst) -> OSMenuItem
getMenuItemOSMenuItem (MenuItemHandle {mOSMenuItem}) = mOSMenuItem
*/
getSelectedMenuElementHandle item mH menuId mods parents zIndex (RadioMenuHandle rH=:{mRadioSelect,mRadioItems=itemHs,mRadioIndex}) tb
# (nrRadios,itemHs) = Ulength itemHs
| not mRadioSelect
= (False,Nothing,parents,zIndex+nrRadios,RadioMenuHandle {rH & mRadioItems=itemHs},tb)
# (found,menuEvent,parents,zIndex1,itemHs,tb) = getSelectedMenuElementHandlesItem item mH menuId mods parents zIndex itemHs tb
| not found
= (found,menuEvent,parents,zIndex1,RadioMenuHandle {rH & mRadioItems=itemHs},tb)
# curIndex = mRadioIndex
newIndex = zIndex1-zIndex
| curIndex==newIndex
= (found,menuEvent,parents,zIndex1,RadioMenuHandle {rH & mRadioItems=itemHs},tb)
| otherwise
# (before,[itemH:after])= splitAt (curIndex-1) itemHs
# (curH,itemH) = getMenuItemOSMenuItem itemH
# (before,[itemH:after])= splitAt (newIndex-1) (before ++ [itemH:after])
# (newH,itemH) = getMenuItemOSMenuItem itemH
# tb = OSMenuItemCheck False mH curH tb
# tb = OSMenuItemCheck True mH newH tb
= (found,menuEvent,parents,zIndex1,RadioMenuHandle {rH & mRadioItems=before ++ [itemH:after],mRadioIndex=newIndex},tb)
where
getMenuItemOSMenuItem :: !*(MenuElementHandle .ls .pst) -> (!OSMenuItem,!MenuElementHandle .ls .pst)
getMenuItemOSMenuItem itemH=:(MenuItemHandle {mOSMenuItem}) = (mOSMenuItem,itemH)
getSelectedMenuElementHandle item mH menuId mods parents zIndex (MenuListLSHandle itemHs) tb
# (found,menuEvent,parents,zIndex,itemHs,tb) = getSelectedMenuElementHandlesItem item mH menuId mods parents zIndex itemHs tb
......
This diff is collapsed.
......@@ -29,8 +29,8 @@ import StdOverloaded, StdString
:: :+: t1 t2 ls cs = (:+:) infixr 9 (t1 ls cs) (t2 ls cs)
:: ListLS t ls cs = ListLS [t ls cs]
:: NilLS ls cs = NilLS
:: NewLS t ls cs = E..new: {newLS::new, newDef:: t new cs}
:: AddLS t ls cs = E..add: {addLS::add, addDef:: t *(add,ls) cs}
:: NewLS t ls cs = E. .new: {newLS::new, newDef:: t new cs}
:: AddLS t ls cs = E. .add: {addLS::add, addDef:: t *(add,ls) cs}
noLS :: (.a->.b) (.c,.a) -> (.c,.b) // Lift function a -> b
// to (c,a)->(c,b)
......
......@@ -29,8 +29,8 @@ import StdBool, StdInt, StdList, StdOverloaded, StdString
:: :+: t1 t2 ls cs = (:+:) infixr 9 (t1 ls cs) (t2 ls cs)
:: ListLS t ls cs = ListLS [t ls cs]
:: NilLS ls cs = NilLS
:: NewLS t ls cs = E..new: {newLS::new, newDef:: t new cs}
:: AddLS t ls cs = E..add: {addLS::add, addDef:: t *(add,ls) cs}
:: NewLS t ls cs = E. .new: {newLS::new, newDef:: t new cs}
:: AddLS t ls cs = E. .add: {addLS::add, addDef:: t *(add,ls) cs}
noLS :: (.a->.b) (.c,.a) -> (.c,.b)
noLS f (c,a) = (c,f a)
......
......@@ -94,8 +94,9 @@ instance Ids (PSt .l) where
getParentId :: !Id !(IOSt .l) -> (!Maybe Id,!IOSt .l)
getParentId id ioState
# (idtable,ioState) = IOStGetIdTable ioState
maybeParent = getIdParent id idtable
# (idTable,ioState) = IOStGetIdTable ioState
(maybeParent,idTable) = getIdParent id idTable
# ioState = IOStSetIdTable idTable ioState
| isNothing maybeParent
= (Nothing,ioState)
| otherwise
......
......@@ -6,9 +6,8 @@ implementation module StdMenu
import StdBool, StdList, StdTuple
import osmenu
import commondef, iostate, menucreate, menudevice, menuinternal, menuitems, StdId
import commondef, iostate, menuaccess, menucreate, menudevice, menuinternal, menuitems, StdId
from devicesystemstate import WindowSystemStateGetWindowHandles
from menuaccess import menuStateHandleGetMenuId, menuStateHandleGetSelect, menuStateHandleGetTitle, menuStateHandleGetHandle
from menudefaccess import menuDefGetMenuId
from menuevent import MenuSystemStateGetMenuHandles, MenuHandlesGetMenuStateHandles
from StdPSt import accPIO
......@@ -45,7 +44,7 @@ where
= (Nothing,[])
changeMenuSystemState :: !Bool
!(OSMenuBar -> (MenuHandles (PSt .l)) -> *OSToolbox -> *(MenuHandles (PSt .l),*OSToolbox))
!(OSMenuBar -> (MenuHandles (PSt .l)) -> *(*OSToolbox -> *(MenuHandles (PSt .l),*OSToolbox)))
!(IOSt .l)
-> IOSt .l
changeMenuSystemState redrawMenus f ioState
......@@ -71,7 +70,7 @@ changeMenuSystemState redrawMenus f ioState
= IOStSetDevice (MenuSystemState menus) ioState
accessMenuSystemState :: !Bool
!(OSMenuBar -> (MenuHandles (PSt .l)) -> *OSToolbox -> *(.x,MenuHandles (PSt .l),*OSToolbox))
!(OSMenuBar -> (MenuHandles (PSt .l)) -> *(*OSToolbox -> *(.x,MenuHandles (PSt .l),*OSToolbox)))
!(IOSt .l)
-> (!Maybe .x,!IOSt .l)
accessMenuSystemState redrawMenus f ioState
......@@ -139,8 +138,8 @@ validateMenuId Nothing ioState
= (Just mId,ioState)
validateMenuId (Just id) ioState
# (idtable,ioState) = IOStGetIdTable ioState
| memberIdTable id idtable = (Nothing,ioState)
| otherwise = (Just id,ioState)
| memberIdTable id idtable = (Nothing,IOStSetIdTable idtable ioState)
| otherwise = (Just id,IOStSetIdTable idtable ioState)
instance Menus (PopUpMenu m) | PopUpMenuElements m where
openMenu :: .ls !(PopUpMenu m .ls (PSt .l)) !(PSt .l) -> (!ErrorReport,!PSt .l) | PopUpMenuElements m
......@@ -185,7 +184,7 @@ instance Menus (PopUpMenu m) | PopUpMenuElements m where
| not found // This condition should never occur
= StdMenuFatalError "openMenu (PopUpMenu)" "could not retrieve MenuSystemState from IOSt"
# mHs = MenuSystemStateGetMenuHandles mDevice
(menus,mHs) = MenuHandlesGetMenuStateHandles mHs
(menus,mHs) = menuHandlesGetMenus mHs
(popUpMenu,menus) = HdTl menus
(popUpId,popUpMenu) = menuStateHandleGetMenuId popUpMenu
(mPtr,popUpMenu) = menuStateHandleGetHandle popUpMenu
......@@ -309,23 +308,23 @@ getMenuSelectState id ioState
openMenuElements :: !Id !Index .ls (m .ls (PSt .l)) !(PSt .l) -> (!ErrorReport,!PSt .l) | MenuElements m
openMenuElements mId pos ls new pState
# (it,ioState) = IOStGetIdTable pState.io
maybeParent = getIdParent mId it
# (maybeParent,it) = getIdParent mId it
| isNothing maybeParent
= (ErrorUnknownObject,{pState & io=ioState})
= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
# parent = fromJust maybeParent
| parent.idpDevice<>MenuDevice
= (ErrorUnknownObject,{pState & io=ioState})
= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
# (pid,ioState) = IOStGetIOId ioState
| parent.idpIOId<>pid
= (ErrorUnknownObject,{pState & io=ioState})
= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
| parent.idpId<>mId
= (ErrorUnknownObject,{pState & io=ioState})
= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
# (found,mDevice,ioState) = IOStGetDevice MenuDevice ioState
| not found
= (ErrorUnknownObject,{pState & io=ioState})
= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
# (osdInfo,ioState) = IOStGetOSDInfo ioState
maybeOSMenuBar = getOSDInfoOSMenuBar osdInfo
| isNothing maybeOSMenuBar // This condition should not occur
| isNothing maybeOSMenuBar // This condition should not occur
= StdMenuFatalError "openMenuElements" "OSMenuBar could not be retrieved from OSDInfo"
| otherwise
# osMenuBar = fromJust maybeOSMenuBar
......@@ -348,21 +347,21 @@ openMenuElements mId pos ls new pState
openSubMenuElements :: !Id !Index .ls (m .ls (PSt .l)) !(PSt .l) -> (!ErrorReport,!PSt .l) | MenuElements m
openSubMenuElements sId pos ls new pState
# (it,ioState) = IOStGetIdTable pState.io
maybeParent = getIdParent sId it
# (maybeParent,it) = getIdParent sId it
| isNothing maybeParent
= (ErrorUnknownObject,{pState & io=ioState})
= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
# parent = fromJust maybeParent
| parent.idpDevice<>MenuDevice
= (ErrorUnknownObject,{pState & io=ioState})
= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
# (pid,ioState) = IOStGetIOId ioState
| parent.idpIOId<>pid
= (ErrorUnknownObject,{pState & io=ioState})
= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
# (found,mDevice,ioState) = IOStGetDevice MenuDevice ioState
| not found
= (ErrorUnknownObject,{pState & io=ioState})
= (ErrorUnknownObject,{pState & io=IOStSetIdTable it ioState})
# (osdInfo,ioState) = IOStGetOSDInfo ioState
maybeOSMenuBar = getOSDInfoOSMenuBar osdInfo
| isNothing maybeOSMenuBar // This condition should not occur
| isNothing maybeOSMenuBar // This condition should not occur
= StdMenuFatalError "openSubMenuElements" "OSMenuBar could not be retrieved from OSDInfo"
| otherwise
# osMenuBar = fromJust maybeOSMenuBar
......@@ -385,20 +384,20 @@ openSubMenuElements sId pos ls new pState
openRadioMenuItems :: !Id !Index ![MenuRadioItem (PSt .l)] !(IOSt .l) -> (!ErrorReport,!IOSt .l)
openRadioMenuItems rId pos radioItems ioState
# (idtable,ioState) = IOStGetIdTable ioState
maybeParent = getIdParent rId idtable
# (maybeParent,idtable) = getIdParent rId idtable
| isNothing maybeParent
= (ErrorUnknownObject,ioState)
= (ErrorUnknownObject,IOStSetIdTable idtable ioState)
# parent = fromJust maybeParent
| parent.idpDevice<>MenuDevice
= (ErrorUnknownObject,ioState)
= (ErrorUnknownObject,IOStSetIdTable idtable ioState)
# (ioId,ioState) = IOStGetIOId ioState
| parent.idpIOId<>ioId
= (ErrorUnknownObject,ioState)
= (ErrorUnknownObject,IOStSetIdTable idtable ioState)
| isEmpty radioItems
= (NoError,ioState)
= (NoError,IOStSetIdTable idtable ioState)
# radioIds = FilterMap (\(_,maybeId,_,_)->(isJust maybeId,fromJust maybeId)) radioItems
| not (okMembersIdTable radioIds idtable)
= (ErrorIdsInUse,ioState)
= (ErrorIdsInUse,IOStSetIdTable idtable ioState)
| otherwise
# mId = parent.idpId
# (error,ioState) = accessMenuSystemState True (addMenuRadioItems (mId,rId) (max 0 pos) radioItems) ioState
......@@ -422,14 +421,15 @@ closeMenuElements mId ids ioState
closeMenuIndexElements :: !Id ![Index] !(IOSt .l) -> IOSt .l
closeMenuIndexElements mId indices ioState
# (idtable,ioState) = IOStGetIdTable ioState
maybeParent = getIdParent mId idtable
# (idtable,ioState) = IOStGetIdTable ioState
# (maybeParent,idtable) = getIdParent mId idtable
# ioState = IOStSetIdTable idtable ioState
| isNothing maybeParent
= ioState
# parent = fromJust maybeParent
# parent = fromJust maybeParent
| parent.idpDevice<>MenuDevice
= ioState
# (ioId,ioState) = IOStGetIOId ioState
# (ioId,ioState) = IOStGetIOId ioState
| parent.idpIOId<>ioId || parent.idpId<>mId
= ioState
| otherwise
......@@ -437,14 +437,15 @@ closeMenuIndexElements mId indices ioState
closeSubMenuIndexElements :: !Id ![Index] !(IOSt .l) -> IOSt .l
closeSubMenuIndexElements sId indices ioState
# (idtable,ioState) = IOStGetIdTable ioState
maybeParent = getIdParent sId idtable
# (idtable,ioState) = IOStGetIdTable ioState
# (maybeParent,idtable) = getIdParent sId idtable
# ioState = IOStSetIdTable idtable ioState
| isNothing maybeParent
= ioState
# parent = fromJust maybeParent
# parent = fromJust maybeParent
| parent.idpDevice<>MenuDevice
= ioState
# (ioId,ioState) = IOStGetIOId ioState
# (ioId,ioState) = IOStGetIOId ioState
| parent.idpIOId<>ioId
= ioState
| otherwise
......@@ -452,14 +453,15 @@ closeSubMenuIndexElements sId indices ioState
closeRadioMenuIndexElements :: !Id ![Index] !(IOSt .l) -> IOSt .l
closeRadioMenuIndexElements rId indices ioState
# (idtable,ioState) = IOStGetIdTable ioState
maybeParent = getIdParent rId idtable
# (idtable,ioState) = IOStGetIdTable ioState
# (maybeParent,idtable) = getIdParent rId idtable
# ioState = IOStSetIdTable idtable ioState
| isNothing maybeParent
= ioState
# parent = fromJust maybeParent
# parent = fromJust maybeParent
| parent.idpDevice<>MenuDevice
= ioState
# (ioId,ioState) = IOStGetIOId ioState
# (ioId,ioState) = IOStGetIOId ioState
| parent.idpIOId<>ioId
= ioState
| otherwise
......
......@@ -8,7 +8,7 @@ implementation module StdMenuElementClass
import StdBool, StdList, StdMisc, StdTuple
import StdMenuDef, StdPSt
import commondef, menudefaccess, menuhandle
import commondef, menuaccess, menudefaccess
import osmenu
......
This diff is collapsed.
......@@ -32,17 +32,18 @@ instance Timers (Timer t) | TimerElements t where
| not ok // This condition should never hold: TimerDevice has just been 'installed'
= StdTimerFatalError "openTimer (Timer)" "could not retrieve TimerSystemState from IOSt"
# (pid,ioState) = IOStGetIOId ioState
# (it,ioState) = IOStGetIdTable ioState
# (rt,ioState) = IOStGetReceiverTable ioState
# (tt,ioState) = IOStGetTimerTable ioState
# pState = {pState & io=ioState}
id = fromJust maybe_okId
# (ts,pState) = timerElementToHandles items pState
itemHs = map TimerElementStateToTimerElementHandle ts
# (it,ioState) = IOStGetIdTable pState.io
# (rt,ioState) = IOStGetReceiverTable ioState
(ok,itemHs,rt,it) = bindTimerElementIds pid id itemHs rt it
| not ok
# pState = appPIO (IOStSetDevice (TimerSystemState timers)) pState
= (ErrorIdsInUse,pState)
# ioState = IOStSetDevice (TimerSystemState timers) ioState
# ioState = IOStSetIdTable it ioState
# ioState = IOStSetReceiverTable rt ioState
= (ErrorIdsInUse,{pState & io=ioState})
| otherwise
= (NoError,pState2)
with
......@@ -58,9 +59,8 @@ instance Timers (Timer t) | TimerElements t where
, tlParentId = id
, tlTimerId = id
}
tt1 = if ableTimer (snd (addTimerToTimerTable tLoc period tt)) tt
it1 = snd (addIdToIdTable id {idpIOId=pid,idpDevice=TimerDevice,idpId=id} it)
ioState1 = IOStSetTimerTable tt1 pState.io
ioState1 = addAbleTimerToTimerTable ableTimer tLoc period ioState
ioState2 = IOStSetReceiverTable rt ioState1
ioState3 = IOStSetIdTable it1 ioState2
ioState4 = IOStSetDevice (TimerSystemState {timers & tTimers=[tsH:timers.tTimers]}) ioState3
......@@ -79,8 +79,16 @@ instance Timers (Timer t) | TimerElements t where
= (Just tId,ioState)
validateTimerId (Just id) ioState
# (it,ioState) = IOStGetIdTable ioState
| memberIdTable id it = (Nothing,ioState)
| otherwise = (Just id,ioState)
| memberIdTable id it = (Nothing,IOStSetIdTable it ioState)
| otherwise = (Just id,IOStSetIdTable it ioState)
addAbleTimerToTimerTable :: !Bool !TimerLoc !TimerInterval !(IOSt .l) -> IOSt .l
addAbleTimerToTimerTable True tLoc period ioState
# (tt,ioState) = IOStGetTimerTable ioState
# (_,tt) = addTimerToTimerTable tLoc period tt
= IOStSetTimerTable tt ioState
addAbleTimerToTimerTable _ _ _ ioState
= ioState
getTimerType :: (Timer t .ls .pst) -> TimerType | TimerElements t
getTimerType _
......@@ -110,8 +118,8 @@ closeTimer id ioState
# ioState = IOStSetDevice (TimerSystemState tHs) ioState
= ioState
where
closetimer :: !Id !SystemId !ReceiverTable !TimerTable !IdTable ![TimerStateHandle .pst]
-> (!ReceiverTable,!TimerTable,!IdTable,![TimerStateHandle .pst])
closetimer :: !Id !SystemId !*ReceiverTable !*TimerTable !*IdTable ![TimerStateHandle .pst]
-> (!*ReceiverTable,!*TimerTable,!*IdTable,![TimerStateHandle .pst])
closetimer id pid rt tt it [tsH:tsHs]
# (eqid,tsH) = eqTimerStateHandleId id tsH
| eqid
......@@ -121,7 +129,8 @@ where
# (rt,tt,it,tsHs) = closetimer id pid rt tt it tsHs
= (rt,tt,it,[tsH:tsHs])
where
disposeElementIds :: !SystemId !(TimerStateHandle .pst) !TimerTable !ReceiverTable !IdTable -> (!TimerTable,!ReceiverTable,!IdTable)
disposeElementIds :: !SystemId !(TimerStateHandle .pst) !*TimerTable !*ReceiverTable !*IdTable
-> (!*TimerTable,!*ReceiverTable,!*IdTable)
disposeElementIds pid (TimerLSHandle {tHandle={tId,tItems}}) tt rt it
# (tt,rt,it) = unbindTimerElementIds pid tItems (tt,rt,it)
= (snd (removeTimerFromTimerTable teLoc tt),rt,snd (removeIdFromIdTable tId it))
......@@ -162,7 +171,7 @@ enableTimer :: !Id !(IOSt .l) -> IOSt .l
enableTimer id ioState
= changeTimer id enabletimer ioState
where
enabletimer :: TimerLoc !TimerTable !(TimerStateHandle .pst) -> (!TimerTable, !TimerStateHandle .pst)
enabletimer :: TimerLoc !*TimerTable !(TimerStateHandle .pst) -> (!*TimerTable, !TimerStateHandle .pst)
enabletimer teLoc tt tlsH=:(TimerLSHandle tsH=:{tHandle=tH=:{tSelect,tPeriod}})
| tSelect
= (tt,tlsH)
......@@ -174,7 +183,7 @@ disableTimer :: !Id !(IOSt .l) -> IOSt .l
disableTimer id ioState
= changeTimer id disabletimer ioState
where
disabletimer :: TimerLoc !TimerTable !(TimerStateHandle .pst) -> (!TimerTable, !TimerStateHandle .pst)
disabletimer :: TimerLoc !*TimerTable !(TimerStateHandle .pst) -> (!*TimerTable, !TimerStateHandle .pst)
disabletimer teLoc tt tlsH=:(TimerLSHandle tsH=:{tHandle=tH=:{tSelect}})
| not tSelect
= (tt,tlsH)
......@@ -213,7 +222,7 @@ setTimerInterval :: !Id !TimerInterval !(IOSt .l) -> IOSt .l
setTimerInterval id interval ioState
= changeTimer id (settimerinterval interval) ioState
where
settimerinterval :: !TimerInterval !TimerLoc !TimerTable !(TimerStateHandle .pst) -> (!TimerTable, !TimerStateHandle .pst)
settimerinterval :: !TimerInterval !TimerLoc !*TimerTable !(TimerStateHandle .pst) -> (!*TimerTable, !TimerStateHandle .pst)
settimerinterval period teLoc tt tlsH=:(TimerLSHandle tsH=:{tHandle=tH=:{tSelect,tPeriod}})
# period = max 0 period
| period==tPeriod
......@@ -261,7 +270,7 @@ IOStGetTimerHandles ioState
// General TimerHandle changing function:
:: DeltaTimerStateHandle pst
:== TimerLoc TimerTable (TimerStateHandle pst) -> (TimerTable,TimerStateHandle pst)
:== TimerLoc -> *TimerTable -> *((TimerStateHandle pst) -> (*TimerTable,TimerStateHandle pst))
changeTimer :: !Id !(DeltaTimerStateHandle (PSt .l)) !(IOSt .l) -> IOSt .l
changeTimer id f ioState
......@@ -276,14 +285,14 @@ changeTimer id f ioState
# ioState = IOStSetTimerTable tt ioState
= ioState
where
changetimerdevice :: SystemId !Id (DeltaTimerStateHandle .pst) !TimerTable !(TimerHandles .pst)
-> (!TimerTable, !TimerHandles .pst)
changetimerdevice :: SystemId !Id (DeltaTimerStateHandle .pst) !*TimerTable !(TimerHandles .pst)
-> (!*TimerTable, !TimerHandles .pst)
changetimerdevice ioid id f tt timers=:{tTimers=tsHs}
# (tt,tsHs) = changetimerstatehandles ioid id f tt tsHs
= (tt,{timers & tTimers=tsHs})
where
changetimerstatehandles :: SystemId !Id (DeltaTimerStateHandle .pst) !TimerTable ![TimerStateHandle .pst]
-> (!TimerTable,![TimerStateHandle .pst])
changetimerstatehandles :: SystemId !Id (DeltaTimerStateHandle .pst) !*TimerTable ![TimerStateHandle .pst]
-> (!*TimerTable,![TimerStateHandle .pst])
changetimerstatehandles ioid id f tt [tsH=:(TimerLSHandle {tHandle={tId}}):tsHs]
| id==tId
= (tt1,[tsH1:tsHs])
......@@ -294,5 +303,5 @@ where
= (tt1,[tsH:tsHs1])
with
(tt1,tsHs1) = changetimerstatehandles ioid id f tt tsHs
changetimerstatehandles _ _ _ tt tsHs
= (tt,tsHs)
changetimerstatehandles _ _ _ tt []
= (tt,[])
This diff is collapsed.
......@@ -110,6 +110,7 @@ incBound :: !Bound -> Bound // Finite i -> Finite (max 1 (i+1)); Infini
:: Cond x :== x -> Bool
:: UCond x :== x -> *(Bool,x)
u_isEmpty :: !v:[u:x] -> (!Bool,!v:[u:x]), [v<=u]
IsSingleton :: ![.x] -> Bool
HdTl :: !u:[.x] -> (!.x, !u:[.x])
InitLast :: ![.x] -> (![.x],!.x)
......@@ -118,17 +119,18 @@ Split :: !Int !u:[.x] -> (![.x],!u:[.x])
CondMap :: (Cond x) !(IdFun x) ![x] -> (!Bool, ![x])
Uspan :: !(UCond .x) !u:[.x] -> (![.x],!u:[.x]) // Same as span (StdList), but preserving uniqueness
FilterMap :: !(.x -> *(Bool,.y)) ![.x] -> [.y]
StateMap :: !(.x -> .s -> *(.y,.s)) ![.x] !.s -> (![.y], !.s)
StateMap2 :: !(.x -> .s -> .s) ![.x] !.s -> .s
StateMap :: !(u:x -> v:(.s -> (.y,.s))) ![u:x] !.s -> (![.y],!.s), [v<=u]
StateMap2 :: !(u:x -> v:(.s -> .s)) ![u:x] !.s -> .s, [v<=u]
StrictSeq :: ![.(.s -> .s)] !.s -> .s // Same as seq (StdFunc), but with strict state argument
StrictSeqList :: !.[.St .s .x] !.s -> (![.x],!.s) // Same as seqList (StdFunc), but with strict state argument
Contains :: !(Cond x) ![ x] -> Bool
UContains :: !(UCond .x) !u:[.x] -> (!Bool, !u:[.x])
Select :: !(Cond x) x ![ x] -> (!Bool, x)
USelect :: !(Cond x) x !u:[ x] -> (!Bool, x,!u:[x])
Access :: !(St .x *(Bool,.y)) .y !u:[.x] -> (!Bool,.y,!u:[.x])
AccessList :: !(St .x .y) ![.x] -> (![.y], ![.x])
Remove :: !(Cond x) x ![ x] -> (!Bool, x, ![ x])
Remove :: !(Cond x) x !u:[x] -> (!Bool, x, !u:[x])
URemove :: !(UCond .x) .x !u:[.x] -> (!Bool,.x, !u:[.x])
Replace :: !(Cond x) x ![ x] -> (!Bool, ![ x])
UReplace :: !(UCond .x) .x !u:[.x] -> (!Bool, !u:[.x])
......
......@@ -271,39 +271,15 @@ incBound (Finite i)
incBound bound = bound
/* PA: code changed and moved to oswindow.
/* Standard Scroll Bar settings:
Internally, scrollbars always have the following internal range:
* if the SliderState is not empty (sliderMin<>sliderMax): (StdSliderMin,StdSliderMax)
* if the SliderState is empty (sliderMin==sliderMax): (StdSliderMin,StdSliderMin).
The thumb is always set proportionally (see toSliderRange).
Its value can be recalculated by fromSliderRange given the actual SliderState range.
*/
StdSliderMin :== 0 // 0
StdSliderMax :== 32767 // MaxSigned2ByteInt