CoreTasks.icl 6.13 KB
Newer Older
1 2
implementation module CoreTasks

3
import StdList, StdBool, StdInt, StdTuple,StdMisc, Util, HtmlUtil, Time, Error, OSError, Map, Tuple, List
4
import qualified StdList
5
import iTaskClass, Task, TaskState, TaskEval, TaskStore, UIDefinition, LayoutCombinators, Shared
6
from SharedDataSource		import qualified read, readRegister, write, writeFilterMsg
7
from StdFunc				import o, id
8
from IWorld					import :: IWorld(..)
9 10
from SystemData				import topLevelTasks
from Map					import qualified get
11 12

return :: !a -> (Task a) | iTask a
Bas Lijnse's avatar
Bas Lijnse committed
13
return a  = mkInstantTask (\taskId iworld-> (Ok a, iworld))
14

15
throw :: !e -> Task a | iTask a & iTask, toString e
Bas Lijnse's avatar
Bas Lijnse committed
16
throw e = mkInstantTask (\taskId iworld -> (Error (dynamic e,toString e), iworld))
17

18
get :: !(ReadWriteShared a w) -> Task a | iTask a
19
get shared = mkInstantTask eval
Steffen Michels's avatar
Steffen Michels committed
20
where
Bas Lijnse's avatar
Bas Lijnse committed
21
	eval taskId iworld=:{taskTime}
22
		# (val,iworld) = 'SharedDataSource'.read shared iworld
Bas Lijnse's avatar
Bas Lijnse committed
23 24 25 26
		= case val of
			Ok val		= (Ok val,iworld)
			Error e		= (Error (dynamic (SharedException e), e), iworld)
	
Bas Lijnse's avatar
Bas Lijnse committed
27
set :: !a !(ReadWriteShared r a)  -> Task a | iTask a
28
set val shared = mkInstantTask eval
Steffen Michels's avatar
Steffen Michels committed
29
where
30
	eval taskId iworld=:{taskTime,currentInstance}
31 32
		//# (res,iworld)	='SharedDataSource'.writeFilterMsg val ((<>) currentInstance) shared iworld
		# (res,iworld)	='SharedDataSource'.write val shared iworld
Bas Lijnse's avatar
Bas Lijnse committed
33 34 35
		= case res of
			Ok _	= (Ok val,iworld)
			Error e	= (Error (dynamic (SharedException e), e), iworld)
Steffen Michels's avatar
Steffen Michels committed
36

37
update :: !(r -> w) !(ReadWriteShared r w) -> Task w | iTask r & iTask w
38
update fun shared = mkInstantTask eval
Steffen Michels's avatar
Steffen Michels committed
39
where
40
	eval taskId iworld=:{taskTime,currentInstance}
Steffen Michels's avatar
Steffen Michels committed
41
		# (er, iworld)	= 'SharedDataSource'.read shared iworld
Bas Lijnse's avatar
Bas Lijnse committed
42 43 44 45
		= case er of
			Error e		= (Error (dynamic (SharedException e), e), iworld)
			Ok r	
				# w				= fun r
46 47
				//# (er, iworld)	=  'SharedDataSource'.writeFilterMsg w ((<>) currentInstance) shared iworld
				# (er, iworld)	=  'SharedDataSource'.write w shared iworld
Bas Lijnse's avatar
Bas Lijnse committed
48 49 50 51
				= case er of
					Ok _	= (Ok w, iworld)
					Error e = (Error (dynamic (SharedException e), e), iworld)
					
52
watch :: !(ReadWriteShared r w) -> Task r | iTask r
53
watch shared = Task eval
54
where
Bas Lijnse's avatar
Bas Lijnse committed
55
	eval event repOpts (TCInit taskId=:(TaskId instanceNo _) ts) iworld
56
		# (val,iworld)	= 'SharedDataSource'.readRegister instanceNo shared iworld
57
		# res = case val of
58 59
			Ok val		= ValueResult (Value val False) {TaskInfo|lastEvent=ts,refreshSensitive=True}
				(finalizeRep repOpts (TaskRep (UIControlSequence {UIControlSequence|attributes=newMap,controls=[],direction=Vertical}) [])) (TCInit taskId ts)
Bas Lijnse's avatar
Bas Lijnse committed
60
			Error e		= exception (SharedException e)
61
		= (res,iworld)
Bas Lijnse's avatar
Bas Lijnse committed
62
	eval event repAs (TCDestroy _) iworld = (DestroyedResult,iworld)
63

64

65
interact :: !d !(ReadOnlyShared r) (r -> (l,v,InteractionMask)) (l r v InteractionMask Bool -> (l,v,InteractionMask))
66
			-> Task l | descr d & iTask l & iTask r & iTask v
67
interact desc shared initFun refreshFun = Task eval
68
where
Bas Lijnse's avatar
Bas Lijnse committed
69
	eval event repOpts (TCInit taskId=:(TaskId instanceNo _) ts) iworld
70
		# (mbr,iworld) 			= 'SharedDataSource'.readRegister instanceNo shared iworld
71
		= case mbr of
72
			Error e		= (exception e, iworld)
Steffen Michels's avatar
Steffen Michels committed
73
			Ok r
74
				# (l,v,mask)	= initFun r
Bas Lijnse's avatar
Bas Lijnse committed
75
				= eval event repOpts (TCInteract taskId ts (toJSON l) (toJSON r) (toJSON v) mask) iworld
76
				
Bas Lijnse's avatar
Bas Lijnse committed
77
	eval event repOpts (TCInteract taskId=:(TaskId instanceNo _) ts encl encr encv mask) iworld=:{taskTime}
78 79 80
		//Decode stored values
		# (l,r,v)				= (fromJust (fromJSON encl), fromJust (fromJSON encr), fromJust (fromJSON encv))
		//Determine next v by applying edit event if applicable 	
Bas Lijnse's avatar
Bas Lijnse committed
81
		# (nv,nmask,nts,iworld) = matchAndApplyEvent event taskId taskTime v mask ts iworld
82
		//Load next r from shared value
83
		# (mbr,iworld) 			= 'SharedDataSource'.readRegister instanceNo shared iworld
84
		| isError mbr			= (exception (fromError mbr),iworld)
85
		# nr					= fromOk mbr
86 87
		//Apply refresh function if r or v changed
		# changed				= (nts =!= ts) || (nr =!= r) 
88
		# valid					= isValidMask (verifyMaskedValue nv nmask)
89 90
		# (nl,nv,nmask) 		= if changed (refreshFun l nr nv nmask valid) (l,nv,mask)
		//Make visualization
91
		# validity				= verifyMaskedValue nv nmask
92
		# (rep,iworld) 			= visualizeView taskId repOpts nv validity desc (visualizeAsText AsLabel nl) iworld
Bas Lijnse's avatar
Bas Lijnse committed
93
		# value 				= if (isValidMask validity) (Value nl False) NoValue
94 95
		= (ValueResult value {TaskInfo|lastEvent=nts,refreshSensitive=True} (finalizeRep repOpts rep)
			(TCInteract taskId nts (toJSON nl) (toJSON nr) (toJSON nv) nmask), iworld)
96

Bas Lijnse's avatar
Bas Lijnse committed
97
	eval event repOpts (TCDestroy _) iworld = (DestroyedResult,iworld)
98

99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114
	matchAndApplyEvent (EditEvent taskId name value) matchId taskTime v mask ts iworld
		| taskId == matchId
			| otherwise
				# (nv,nmask)	= updateValueAndMask (s2dp name) value (v,mask)
				= (nv,nmask,taskTime,iworld)
		| otherwise	= (v,mask,ts,iworld)
	matchAndApplyEvent (FocusEvent taskId) matchId taskTime v mask ts iworld
		= (v,mask, if (taskId == matchId) taskTime ts, iworld)
	matchAndApplyEvent _ matchId taskTime v mask ts iworld
		= (v,mask,ts,iworld)

	visualizeView taskId repOpts v validity desc valueAttr iworld
		# layout	= repLayout repOpts
		# (controls,iworld) = visualizeAsEditor v validity taskId layout iworld
		# uidef		= (afterLayout repOpts) (UIControlSequence (layout.Layout.interact (toPrompt desc) {UIControlSequence|attributes=put VALUE_ATTRIBUTE valueAttr newMap,controls=controls,direction=Vertical}))
		= (TaskRep uidef [(toString taskId,toJSON v)], iworld)
115

Steffen Michels's avatar
Steffen Michels committed
116
appWorld :: !(*World -> *World) -> Task Void
117
appWorld fun = mkInstantTask eval
118
where
Bas Lijnse's avatar
Bas Lijnse committed
119 120
	eval taskId iworld=:{IWorld|world}
		= (Ok Void, {IWorld|iworld & world = fun world})
121
		
Steffen Michels's avatar
Steffen Michels committed
122
accWorld :: !(*World -> *(!a,!*World)) -> Task a | iTask a
123
accWorld fun = mkInstantTask eval
124
where
Bas Lijnse's avatar
Bas Lijnse committed
125
	eval taskId iworld=:{IWorld|world}
126
		# (res,world) = fun world
Bas Lijnse's avatar
Bas Lijnse committed
127
		= (Ok res, {IWorld|iworld & world = world})
128
	
Steffen Michels's avatar
Steffen Michels committed
129
accWorldError :: !(*World -> (!MaybeError e a, !*World)) !(e -> err) -> Task a | iTask a & TC, toString err
130
accWorldError fun errf = mkInstantTask eval
Steffen Michels's avatar
Steffen Michels committed
131
where
Bas Lijnse's avatar
Bas Lijnse committed
132
	eval taskId iworld=:{IWorld|taskTime,world}
133 134
		# (res,world)	= fun world
		= case res of
Bas Lijnse's avatar
Bas Lijnse committed
135 136 137 138 139
			Error e
				# err = errf e		
				= (Error (dynamic err,toString err), {IWorld|iworld & world = world})	
			Ok v
				= (Ok v, {IWorld|iworld & world = world})
140
	
Steffen Michels's avatar
Steffen Michels committed
141
accWorldOSError :: !(*World -> (!MaybeOSError a, !*World)) -> Task a | iTask a
142
accWorldOSError fun = accWorldError fun OSException