Task.icl 6.2 KB
Newer Older
1
implementation module iTasks.Internal.Task
Steffen Michels's avatar
Steffen Michels committed
2

3
from StdFunc import const, id
Steffen Michels's avatar
Steffen Michels committed
4
import StdClass, StdArray, StdTuple, StdInt, StdList, StdBool, StdMisc, Data.Func
5 6
from Data.Map import :: Map
import qualified Data.Map as DM
7
import Text.HTML, Internet.HTTP, Data.Error, Data.Functor, Text.GenJSON
8
import iTasks.Internal.IWorld, iTasks.UI.Definition, iTasks.Internal.Util, iTasks.Internal.DynamicUtil
9
from System.OSError import :: MaybeOSError, :: OSError, :: OSErrorCode, :: OSErrorMessage
Bas Lijnse's avatar
Bas Lijnse committed
10

11
import iTasks.WF.Definition
12
import iTasks.WF.Tasks.IO
13
import iTasks.WF.Tasks.Core
14
from   iTasks.WF.Combinators.Core import :: AttachmentStatus
15
import iTasks.UI.Editor, iTasks.UI.Editor.Common
16
import iTasks.Internal.SDS
17
from iTasks.UI.Layout import :: LUI, :: LUIMoves, :: LUIMoveID, :: LUIEffectStage, :: LUINo
18

Mart Lubbers's avatar
Mart Lubbers committed
19
from iTasks.Internal.TaskState		import :: DeferredJSON(..), :: TIMeta(..) , :: TIType(..), :: AsyncAction
20
import iTasks.Internal.TaskEval
21
from iTasks.SDS.Combinators.Common import toDynamic
22
from iTasks.Internal.Serialization    import JSONEncode, JSONDecode, dynamicJSONEncode, dynamicJSONDecode
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
23

24 25 26 27 28 29 30 31 32 33
fromJSONOfDeferredJSON :: !DeferredJSON -> Maybe a | TC a & JSONDecode{|*|} a
fromJSONOfDeferredJSON (DeferredJSON v)
	= case make_dynamic v of
		(v :: a^)
			-> Just v
fromJSONOfDeferredJSON (DeferredJSONNode json)
	= fromJSON json

make_dynamic v = dynamic v

34
JSONEncode{|Task|} _ _ tt = [dynamicJSONEncode tt]
35 36
JSONDecode{|Task|} _ _ [tt:c] = (dynamicJSONDecode tt,c)
JSONDecode{|Task|} _ _ c = (Nothing,c)
37

38
gText{|Task|} _ _ _ = ["<Task>"]
Steffen Michels's avatar
Steffen Michels committed
39 40 41
gEditor{|Task|} _ _ tj fj =
	emptyEditorWithErrorInEnterMode_  (JSONEncode{|* -> *|} tj) (JSONDecode{|* -> *|} fj) "Tasks cannot be entered."

42
gEq{|Task|} _ _ _			= True // tasks are always equal??
Steffen Michels's avatar
Steffen Michels committed
43

44
gDefault{|Task|} gDefx = Task (\_ -> abort error)
45 46
where
	error = "Creating default task functions is impossible"
47

48
wrapConnectionTask :: (ConnectionHandlers l r w) (sds () r w) -> ConnectionTask | TC l & TC r & TC w & RWShared sds
49 50
wrapConnectionTask ch=:{ConnectionHandlers|onConnect,onData,onShareChange,onDisconnect,onDestroy} sds
	= ConnectionTask {ConnectionHandlersIWorld|onConnect=onConnect`,onData=onData`,onShareChange=onShareChange`,onTick=onTick`,onDisconnect=onDisconnect`,onDestroy=onDestroy`} (toDynamic sds)
51
where
52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74
	onConnect` connId host (r :: r^) env
		# (mbl, mbw, out, close) = onConnect connId host r
		= (toDyn <$> mbl, toDyn <$> mbw, out, close, env)
	onConnect` _ _ val env = abort ("onConnect does not match with type " +++ toString (typeCodeOfDynamic val))

	onData` data (l :: l^) (r :: r^) env
		# (mbl, mbw, out, close) = onData data l r
		= (toDyn <$> mbl, toDyn <$> mbw, out, close, env)
	onData` _ _ val env = abort ("onData does not match with type " +++ toString (typeCodeOfDynamic val))

	onShareChange` (l :: l^) (r :: r^) env
		# (mbl, mbw, out, close) = onShareChange l r
		= (toDyn <$> mbl, toDyn <$> mbw, out, close, env)
	onShareChange` l r env = abort ("onShareChange does not match with type l=" +++ toString (typeCodeOfDynamic l) +++ ", r=" +++ toString (typeCodeOfDynamic r) +++ ". Expected l=" +++ toString (typeCodeOfDynamic (dynamic ch)))

	// do nothing
	onTick` l _ env
		= (Ok l, Nothing, [], False, env)

	onDisconnect` (l :: l^) (r :: r^) env
		# (mbl, mbw) = onDisconnect l r
		= (toDyn <$> mbl, toDyn <$> mbw, env)
	onDisconnect` l r env = abort ("onDisconnect does not match with type l=" +++ toString (typeCodeOfDynamic l) +++ ", r=" +++ toString (typeCodeOfDynamic r))
75 76 77 78
	onDestroy` (l :: l^) env
		# (mbl, out) = onDestroy l
		= (toDyn <$> mbl, out, env)
	onDestroy` l env = abort ("onDestroy does not match with type l=" +++ toString (typeCodeOfDynamic l))
79

80
wrapIWorldConnectionTask :: (ConnectionHandlersIWorld l r w) (sds () r w) -> ConnectionTask | TC l & TC r & TC w & RWShared sds
81 82
wrapIWorldConnectionTask {ConnectionHandlersIWorld|onConnect,onData,onShareChange,onTick,onDisconnect,onDestroy} sds
	= ConnectionTask {ConnectionHandlersIWorld|onConnect=onConnect`,onData=onData`,onShareChange=onShareChange`,onTick=onTick`,onDisconnect=onDisconnect`,onDestroy=onDestroy`} (toDynamic sds)
83
where
84 85 86
	onConnect` connId host (r :: r^) env
		# (mbl, mbw, out, close, env) = onConnect connId host r env
		= (toDyn <$> mbl, toDyn <$> mbw, out, close, env)
87

88
	onConnect` _ _ val env = abort ("onConnect does not match with type " +++ toString (typeCodeOfDynamic val))
89

90 91 92
	onData` data (l :: l^) (r :: r^) env
		# (mbl, mbw, out, close, env) = onData data l r env
		= (toDyn <$> mbl, toDyn <$> mbw, out, close, env)
93

94
	onData` _ _ val env = abort ("onData does not match with type " +++ toString (typeCodeOfDynamic val))
95

96 97 98 99
	onShareChange` (l :: l^) (r :: r^) env
		# (mbl, mbw, out, close, env) = onShareChange l r env
		= (toDyn <$> mbl, toDyn <$> mbw, out, close, env)
	onShareChange` l r env = abort ("onShareChange does not match with type l=" +++ toString (typeCodeOfDynamic l) +++ ", r=" +++ toString (typeCodeOfDynamic r))
100

101 102 103 104
	onTick` (l :: l^) (r :: r^) env
		# (mbl, mbw, out, close, env) = onTick l r env
		= (toDyn <$> mbl, toDyn <$> mbw, out, close, env)
	onTick` l r env = abort ("onTick does not match with type l=" +++ toString (typeCodeOfDynamic l) +++ ", r=" +++ toString (typeCodeOfDynamic r))
105

106 107 108 109
	onDisconnect` (l :: l^) (r :: r^) env
		# (mbl, mbw, env) = onDisconnect l r env
		= (toDyn <$> mbl, toDyn <$> mbw, env)
	onDisconnect` l r env = abort ("onDisconnect does not match with type l=" +++ toString (typeCodeOfDynamic l) +++ ", r=" +++ toString (typeCodeOfDynamic r))
110 111 112 113
	onDestroy` (l :: l^) env
		# (mbl, out, env) = onDestroy l env
		= (toDyn <$> mbl, out, env)
	onDestroy` l env = abort ("onDestroy does not match with type l=" +++ toString (typeCodeOfDynamic l))
114

Mart Lubbers's avatar
Mart Lubbers committed
115 116
mkInstantTask :: (TaskId *IWorld -> (MaybeError TaskException a,*IWorld)) -> Task a | iTask a
mkInstantTask iworldfun = Task eval
117
where
Mart Lubbers's avatar
Mart Lubbers committed
118
	eval DestroyEvent _ iworld = (DestroyedResult, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
119
	eval event {taskId,lastEval} iworld
Mart Lubbers's avatar
Mart Lubbers committed
120
		= case iworldfun taskId iworld of
Mart Lubbers's avatar
Mart Lubbers committed
121
			(Ok a,iworld)     = (ValueResult (Value a True) (mkTaskEvalInfo lastEval) (mkUIIfReset event (ui UIEmpty)) (treturn a), iworld)
Mart Lubbers's avatar
Mart Lubbers committed
122
			(Error e, iworld) = (ExceptionResult e, iworld)
123

Mart Lubbers's avatar
Mart Lubbers committed
124 125 126 127
nopTask :: Task a
nopTask = Task eval
where
	eval DestroyEvent _ iworld = (DestroyedResult, iworld)
Mart Lubbers's avatar
Mart Lubbers committed
128
	eval event {lastEval} iworld
Mart Lubbers's avatar
Mart Lubbers committed
129
		= (ValueResult NoValue (mkTaskEvalInfo lastEval) (mkUIIfReset event (ui UIEmpty)) (Task eval), iworld)