Commit 7e942348 authored by Steffen Michels's avatar Steffen Michels

Merge branch '384-possible-memory-leak' into 'master'

Resolve "Possible memory leak"

Closes #384

See merge request !437
parents ab973f41 0d110ed4
Pipeline #47847 passed with stages
in 16 minutes and 31 seconds
...@@ -88,6 +88,7 @@ Tests/Interactive/GenericEditors/TestReal ...@@ -88,6 +88,7 @@ Tests/Interactive/GenericEditors/TestReal
Tests/Interactive/GenericEditors/TestRecordWithADT Tests/Interactive/GenericEditors/TestRecordWithADT
Tests/Interactive/GenericEditors/TestSingleRecord Tests/Interactive/GenericEditors/TestSingleRecord
Tests/Interactive/GenericEditors/TestString Tests/Interactive/GenericEditors/TestString
Tests/MemoryLeaks
Tests/TestAsyncTask Tests/TestAsyncTask
Tests/Unit/iTasks.Extensions.FileCollection.UnitTests Tests/Unit/iTasks.Extensions.FileCollection.UnitTests
Tests/Unit/iTasks.Extensions.Process.UnitTests Tests/Unit/iTasks.Extensions.Process.UnitTests
......
...@@ -299,7 +299,7 @@ determineAppVersion appPath world ...@@ -299,7 +299,7 @@ determineAppVersion appPath world
determineTimeout :: !(?Timeout) !*IWorld -> (!?Timeout,!*IWorld) determineTimeout :: !(?Timeout) !*IWorld -> (!?Timeout,!*IWorld)
determineTimeout mt iworld = case read taskEvents EmptyContext iworld of determineTimeout mt iworld = case read taskEvents EmptyContext iworld of
//No events //No events
(Ok (ReadingDone (Queue [] [])),iworld=:{sdsNotifyRequests,world}) (Ok (ReadingDone (Queue [|] [|])),iworld=:{sdsNotifyRequests,world})
# (ts, world) = nsTime world # (ts, world) = nsTime world
= =
( minListBy lesser [mt:flatten (map (getTimeoutFromClock ts) ('DM'.elems sdsNotifyRequests))] ( minListBy lesser [mt:flatten (map (getTimeoutFromClock ts) ('DM'.elems sdsNotifyRequests))]
......
...@@ -20,6 +20,7 @@ gText{|TaskWrapper|} tf ma = maybe [] (\_->["TaskWrapper"]) ma ...@@ -20,6 +20,7 @@ gText{|TaskWrapper|} tf ma = maybe [] (\_->["TaskWrapper"]) ma
derive JSONEncode AsyncTaskResult derive JSONEncode AsyncTaskResult
derive JSONDecode AsyncTaskResult derive JSONDecode AsyncTaskResult
derive class iTask Queue, Event, AsyncQueueItem derive class iTask Queue, Event, AsyncQueueItem
derive class iTask \ JSONEncode, JSONDecode [!!]
asyncITasksQueue :: SDSLens () () AsyncQueueItem asyncITasksQueue :: SDSLens () () AsyncQueueItem
asyncITasksQueue = mapReadWrite (\_->(), \task queue -> ?Just (enqueue task queue)) ?None asyncITasksQueueInt asyncITasksQueue = mapReadWrite (\_->(), \task queue -> ?Just (enqueue task queue)) ?None asyncITasksQueueInt
......
...@@ -71,7 +71,7 @@ where ...@@ -71,7 +71,7 @@ where
flushWritesWhenIdle:: Task () flushWritesWhenIdle:: Task ()
flushWritesWhenIdle = everyTick \iworld->case read taskEvents EmptyContext iworld of flushWritesWhenIdle = everyTick \iworld->case read taskEvents EmptyContext iworld of
(Error e,iworld) = (Error e,iworld) (Error e,iworld) = (Error e,iworld)
(Ok (ReadingDone (Queue [] [])),iworld) = flushDeferredSDSWrites iworld (Ok (ReadingDone (Queue [|] [|])),iworld) = flushDeferredSDSWrites iworld
(Ok _,iworld) = (Ok (),iworld) (Ok _,iworld) = (Ok (),iworld)
//When we don't run the built-in HTTP server we don't want to loop forever so we stop the loop //When we don't run the built-in HTTP server we don't want to loop forever so we stop the loop
......
...@@ -27,8 +27,14 @@ mkEvalOpts :: TaskEvalOpts ...@@ -27,8 +27,14 @@ mkEvalOpts :: TaskEvalOpts
//* External information passed from the task //* External information passed from the task
:: TaskEvalInfo = :: TaskEvalInfo =
{ lastEvent :: !TaskTime //When was the last event in this task { lastEvent :: !TaskTime //* When was the last event in this task
, removedTasks :: ![(TaskId,TaskId)] //Which embedded parallel tasks were removed (listId,taskId) , removedTasks :: ![#RemovedTask!] //* Which embedded parallel tasks were removed
}
//* A task removed from a list. This type is used in `TaskEvalInfo`.
:: RemovedTask =
{ removedTaskId :: !TaskId //* The ID of the removed task.
, removedTaskListId :: !TaskId //* The list the task was removed from.
} }
:: TaskTime :== Int :: TaskTime :== Int
......
implementation module iTasks.Internal.TaskEval implementation module iTasks.Internal.TaskEval
import StdList, StdBool, StdTuple, StdMisc, StdString import StdList, StdBool, StdTuple, StdMisc, StdString
import Data.Error, Data.Func, Data.Tuple, Data.Either, Data.Functor, Data.List, Text, Text.GenJSON import Data.Error, Data.Func, Data.Tuple, Data.Either, Data.Functor, Data.List, Text, Text.GenJSON
import iTasks.Internal.IWorld, iTasks.Internal.Task, iTasks.Internal.TaskState, iTasks.Internal.SDS, iTasks.Internal.AsyncSDS import iTasks.Internal.IWorld, iTasks.Internal.Task, iTasks.Internal.TaskState, iTasks.Internal.SDS, iTasks.Internal.AsyncSDS
...@@ -43,7 +42,7 @@ processEvents max iworld ...@@ -43,7 +42,7 @@ processEvents max iworld
= case dequeueEvent iworld of = case dequeueEvent iworld of
(Error e, iworld) = (Error e, iworld) (Error e, iworld) = (Error e, iworld)
(Ok ?None, iworld) = (Ok (), iworld) (Ok ?None, iworld) = (Ok (), iworld)
(Ok (?Just (instanceNo,event)), iworld) (Ok (?Just {instanceNo,event}), iworld)
= case evalTaskInstance instanceNo event iworld of = case evalTaskInstance instanceNo event iworld of
(Ok taskValue,iworld) (Ok taskValue,iworld)
= processEvents (max - 1) iworld = processEvents (max - 1) iworld
...@@ -136,14 +135,20 @@ where ...@@ -136,14 +135,20 @@ where
# (mbErr,iworld) = modify (updateProgress clock newResult nextTaskNo nextTaskTime) (sdsFocus (instanceNo,False,True) taskInstance) EmptyContext iworld # (mbErr,iworld) = modify (updateProgress clock newResult nextTaskNo nextTaskTime) (sdsFocus (instanceNo,False,True) taskInstance) EmptyContext iworld
| mbErr =: (Error _) = (liftError mbErr, iworld) | mbErr =: (Error _) = (liftError mbErr, iworld)
//Store reduct //Store reduct
# (mbErr,iworld) = write newTask (sdsFocus instanceNo taskInstanceTask) EmptyContext iworld # (mbErr,iworld) = write (?Just newTask) (sdsFocus instanceNo taskInstanceTask) EmptyContext iworld
| mbErr =: (Error _) = (liftError mbErr, iworld) | mbErr =: (Error _) = (liftError mbErr, iworld)
//Store value //Store value
# (mbErr,iworld) = write newValue (sdsFocus instanceNo taskInstanceValue) EmptyContext iworld # (mbErr,iworld) = write (?Just newValue) (sdsFocus instanceNo taskInstanceValue) EmptyContext iworld
| mbErr =: (Error _) = (liftError mbErr, iworld) | mbErr =: (Error _) = (liftError mbErr, iworld)
= (Ok (),iworld) = (Ok (),iworld)
cleanupTaskState instanceNo iworld cleanupTaskState instanceNo iworld
//Remove value
# (mbErr,iworld) = write ?None (sdsFocus instanceNo taskInstanceValue) EmptyContext iworld
| mbErr =: (Error _) = (liftError mbErr, iworld)
//Remove reduct
# (mbErr,iworld) = write ?None (sdsFocus instanceNo taskInstanceTask) EmptyContext iworld
| mbErr =: (Error _) = (liftError mbErr, iworld)
//Remove local shares //Remove local shares
# (mbErr,iworld) = write ?None (sdsFocus instanceNo taskInstanceShares) EmptyContext iworld # (mbErr,iworld) = write ?None (sdsFocus instanceNo taskInstanceShares) EmptyContext iworld
| mbErr =: (Error _) = (liftError mbErr, iworld) | mbErr =: (Error _) = (liftError mbErr, iworld)
......
...@@ -15,8 +15,13 @@ from Data.Queue import :: Queue ...@@ -15,8 +15,13 @@ from Data.Queue import :: Queue
from Data.Set import :: Set from Data.Set import :: Set
from Text.GenJSON import generic JSONEncode, generic JSONDecode, :: JSONNode from Text.GenJSON import generic JSONEncode, generic JSONDecode, :: JSONNode
//When events are placed in this queue, the engine will re-evaluate the corresponding task instances. //* When events are placed in this queue, the engine will re-evaluate the corresponding task instances.
:: TaskInput :== Queue (InstanceNo,Event) :: TaskInput :== Queue QueuedEvent
:: QueuedEvent =
{ instanceNo :: !InstanceNo
, event :: !Event
}
taskEvents :: SimpleSDSLens TaskInput taskEvents :: SimpleSDSLens TaskInput
...@@ -35,15 +40,14 @@ taskEvents :: SimpleSDSLens TaskInput ...@@ -35,15 +40,14 @@ taskEvents :: SimpleSDSLens TaskInput
taskOutput :: SimpleSDSLens (Map InstanceNo TaskOutput) taskOutput :: SimpleSDSLens (Map InstanceNo TaskOutput)
taskInstanceOutput :: SDSLens InstanceNo TaskOutput TaskOutput taskInstanceOutput :: SDSLens InstanceNo TaskOutput TaskOutput
/** /**
* Writing in this share queues an event for a task instance * Writing in this share queues an event for a task instance.
* events are applied in FIFO order when the task instance is evaluated * Events are applied in FIFO order when the task instance is evaluated.
* *
* By splitting up event queuing and instance evaluation, events can come in asynchronously without * By splitting up event queuing and instance evaluation, events can come in
* the need to directly processing them. * asynchronously without the need to directly processing them.
*/ */
queueEventShare :: SDSLens () () (InstanceNo, Event) queueEventShare :: SDSLens () () QueuedEvent
//* Queue an event for a task instance by writing in {{queueEventShare}} //* Queue an event for a task instance by writing in {{queueEventShare}}
queueEvent :: !InstanceNo !Event !*IWorld -> *IWorld queueEvent :: !InstanceNo !Event !*IWorld -> *IWorld
...@@ -54,16 +58,17 @@ queueRefresh :: !TaskId !*IWorld -> *IWorld ...@@ -54,16 +58,17 @@ queueRefresh :: !TaskId !*IWorld -> *IWorld
//* Convenience function for queueing multiple refresh multiple refresh events at once. //* Convenience function for queueing multiple refresh multiple refresh events at once.
queueRefreshes :: !(Set TaskId) !*IWorld -> *IWorld queueRefreshes :: !(Set TaskId) !*IWorld -> *IWorld
/** //* Dequeue a task event.
* Dequeue a task event dequeueEvent :: !*IWorld -> (!MaybeError TaskException (?QueuedEvent),!*IWorld)
*/
dequeueEvent :: !*IWorld -> (!MaybeError TaskException (?(InstanceNo,Event)),!*IWorld)
/** /**
* Remove all events for a given instance * Remove all events for a given instance
*/ */
clearEvents :: !InstanceNo !*IWorld -> *IWorld clearEvents :: !InstanceNo !*IWorld -> *IWorld
//* Remove all events for a given task.
clearEventsFor :: !TaskId !*IWorld -> *IWorld
/** /**
* Queue different types of output at once * Queue different types of output at once
*/ */
......
...@@ -28,8 +28,8 @@ import iTasks.SDS.Combinators.Core, iTasks.SDS.Combinators.Common ...@@ -28,8 +28,8 @@ import iTasks.SDS.Combinators.Core, iTasks.SDS.Combinators.Common
import iTasks.SDS.Sources.Store import iTasks.SDS.Sources.Store
import iTasks.WF.Derives import iTasks.WF.Derives
derive JSONEncode TaskOutputMessage, Queue, Event derive JSONEncode TaskOutputMessage, QueuedEvent, Queue, Event
derive JSONDecode TaskOutputMessage, Queue, Event derive JSONDecode TaskOutputMessage, QueuedEvent, Queue, Event
rawInstanceEvents = storeShare NS_TASK_INSTANCES False InMemory (?Just 'DQ'.newQueue) rawInstanceEvents = storeShare NS_TASK_INSTANCES False InMemory (?Just 'DQ'.newQueue)
rawInstanceOutput = storeShare NS_TASK_INSTANCES False InMemory (?Just 'DM'.newMap) rawInstanceOutput = storeShare NS_TASK_INSTANCES False InMemory (?Just 'DM'.newMap)
...@@ -50,28 +50,28 @@ where ...@@ -50,28 +50,28 @@ where
reducer p ws = Ok (fromMaybe 'DQ'.newQueue ('DM'.get p ws)) reducer p ws = Ok (fromMaybe 'DQ'.newQueue ('DM'.get p ws))
queueEvent :: !InstanceNo !Event !*IWorld -> *IWorld queueEvent :: !InstanceNo !Event !*IWorld -> *IWorld
queueEvent ino event iworld = snd (write (ino, event) queueEventShare EmptyContext iworld) queueEvent ino event iworld = snd (write {instanceNo=ino, event=event} queueEventShare EmptyContext iworld)
queueEventShare :: SDSLens () () (InstanceNo, Event) queueEventShare :: SDSLens () () QueuedEvent
queueEventShare = mapReadWrite (const (), writer) ?None taskEvents queueEventShare =: mapReadWrite (const (), writer) ?None taskEvents
where where
writer :: (InstanceNo, Event) TaskInput -> ?TaskInput writer :: !QueuedEvent !TaskInput -> ?TaskInput
writer (instanceNo, event) q = ?Just (fromMaybe ('DQ'.enqueue (instanceNo,event) q) (queueWithMergedRefreshEvent q)) writer qe=:{instanceNo,event} q = ?Just (fromMaybe ('DQ'.enqueue qe q) (queueWithMergedRefreshEvent q))
where where
// merge multiple refresh events for same instance // merge multiple refresh events for same instance
queueWithMergedRefreshEvent :: !(Queue (!InstanceNo, !Event)) -> ?(Queue (!InstanceNo, !Event)) queueWithMergedRefreshEvent :: !(Queue QueuedEvent) -> ?(Queue QueuedEvent)
queueWithMergedRefreshEvent ('DQ'.Queue front back) = case event of queueWithMergedRefreshEvent ('DQ'.Queue front back) = case event of
RefreshEvent refreshTasks = RefreshEvent refreshTasks =
((\front` -> ('DQ'.Queue front` back)) <$> queueWithMergedRefreshEventList front) <|> ((\front` -> ('DQ'.Queue front` back)) <$> queueWithMergedRefreshEventList front) <|>
((\back` -> ('DQ'.Queue front back`)) <$> queueWithMergedRefreshEventList back) ((\back` -> ('DQ'.Queue front back`)) <$> queueWithMergedRefreshEventList back)
where where
queueWithMergedRefreshEventList :: [(InstanceNo, Event)] -> ?[(InstanceNo, Event)] queueWithMergedRefreshEventList :: [!QueuedEvent!] -> ?[!QueuedEvent!]
queueWithMergedRefreshEventList [] = ?None queueWithMergedRefreshEventList [|] = ?None
queueWithMergedRefreshEventList [hd=:(instanceNo`, event`) : tl] = case event` of queueWithMergedRefreshEventList [|hd=:{instanceNo=ino`, event=ev`}:tl] = case ev` of
RefreshEvent refreshTasks` | instanceNo` == instanceNo = RefreshEvent refreshTasks` | ino` == instanceNo =
?Just [(instanceNo, RefreshEvent ('DS'.union refreshTasks refreshTasks`)) : tl] ?Just [|{instanceNo=instanceNo, event=RefreshEvent ('DS'.union refreshTasks refreshTasks`)}:tl]
_ = _ =
(\tl` -> [hd : tl`]) <$> queueWithMergedRefreshEventList tl (\tl` -> [|hd : tl`]) <$> queueWithMergedRefreshEventList tl
_ = ?None _ = ?None
queueRefresh :: !TaskId !*IWorld -> *IWorld queueRefresh :: !TaskId !*IWorld -> *IWorld
...@@ -84,9 +84,8 @@ queueRefreshes tasks iworld ...@@ -84,9 +84,8 @@ queueRefreshes tasks iworld
# iworld = 'Foldable'.foldl (\w t -> queueEvent (toInstanceNo t) (RefreshEvent ('DS'.singleton t)) w) iworld tasks # iworld = 'Foldable'.foldl (\w t -> queueEvent (toInstanceNo t) (RefreshEvent ('DS'.singleton t)) w) iworld tasks
= iworld = iworld
dequeueEvent :: !*IWorld -> (!MaybeError TaskException (?(InstanceNo,Event)),!*IWorld) dequeueEvent :: !*IWorld -> (!MaybeError TaskException (?QueuedEvent),!*IWorld)
dequeueEvent iworld dequeueEvent iworld = case 'SDS'.read taskEvents 'SDS'.EmptyContext iworld of
= case 'SDS'.read taskEvents 'SDS'.EmptyContext iworld of
(Error e, iworld) = (Error e, iworld) (Error e, iworld) = (Error e, iworld)
(Ok ('SDS'.ReadingDone queue), iworld) (Ok ('SDS'.ReadingDone queue), iworld)
# (val, queue) = 'DQ'.dequeue queue # (val, queue) = 'DQ'.dequeue queue
...@@ -99,7 +98,33 @@ clearEvents instanceNo iworld ...@@ -99,7 +98,33 @@ clearEvents instanceNo iworld
# (_,iworld) = 'SDS'.modify clear taskEvents 'SDS'.EmptyContext iworld # (_,iworld) = 'SDS'.modify clear taskEvents 'SDS'.EmptyContext iworld
= iworld = iworld
where where
clear (Queue fs bs) = Queue [f \\ f=:(i,_) <- fs | i <> instanceNo] [b \\ b=:(i,_) <- bs | i <> instanceNo] clear (Queue fs bs) = Queue
[|f \\ f=:{QueuedEvent | instanceNo=i} <|- fs | i <> instanceNo]
[|b \\ b=:{QueuedEvent | instanceNo=i} <|- bs | i <> instanceNo]
clearEventsFor :: !TaskId !*IWorld -> *IWorld
clearEventsFor taskId=:(TaskId ino _) iworld = snd (modify clear taskEvents EmptyContext iworld)
where
clear :: !TaskInput -> TaskInput
clear (Queue front rear) = Queue (upd front) (upd rear)
where
upd [|]
= [|]
upd [|qe=:{instanceNo,event}:rest] | instanceNo <> ino
= [|qe:upd rest]
upd [|qe=:{event=RefreshEvent ids}:rest]
= case 'DS'.delete taskId ids of
'DS'.Tip = upd rest
ids = [|{qe & event=RefreshEvent ids}:upd rest]
upd [|qe=:{event=EditEvent id _ _}:rest]
| id == taskId
= upd rest
= [|qe:upd rest]
upd [|qe=:{event=ActionEvent id _}:rest]
| id == taskId
= upd rest
= [|qe:upd rest]
upd [|qe:rest] = [|qe:upd rest]
queueOutput :: !InstanceNo ![TaskOutputMessage] !*IWorld -> *IWorld queueOutput :: !InstanceNo ![TaskOutputMessage] !*IWorld -> *IWorld
queueOutput instanceNo messages iworld queueOutput instanceNo messages iworld
......
...@@ -566,7 +566,7 @@ halt :: !Int !*IWorld -> *IWorld ...@@ -566,7 +566,7 @@ halt :: !Int !*IWorld -> *IWorld
halt exitCode iworld halt exitCode iworld
# (merr, iworld) = read allTaskInstances EmptyContext iworld # (merr, iworld) = read allTaskInstances EmptyContext iworld
| isError merr = iShowErr [snd (fromError merr)] (closeChannels iworld) | isError merr = iShowErr [snd (fromError merr)] (closeChannels iworld)
# iworld = foldr destroy iworld [i.instanceNo\\i<-directResult (fromOk merr)] # iworld = foldr destroy iworld [i.TaskInstance.instanceNo \\ i <- directResult (fromOk merr)]
= closeChannels iworld = closeChannels iworld
where where
destroy :: !InstanceNo !*IWorld -> *IWorld destroy :: !InstanceNo !*IWorld -> *IWorld
......
...@@ -119,7 +119,6 @@ newInstanceKey :: !*IWorld -> (!InstanceKey,!*IWorld) ...@@ -119,7 +119,6 @@ newInstanceKey :: !*IWorld -> (!InstanceKey,!*IWorld)
nextInstanceNo :: SimpleSDSLens Int nextInstanceNo :: SimpleSDSLens Int
//All Task state is accessible as shared data sources //All Task state is accessible as shared data sources
//taskListData :: SDSLens (!TaskId,!TaskId,!TaskListFilter,!ExtendedTaskListFilter) (!TaskId, [TaskMeta], Map TaskId (TaskValue a), Task a) | iTask a
taskListMetaData :: SDSLens (!TaskId,!TaskId,!TaskListFilter,!ExtendedTaskListFilter) (!TaskId,![TaskMeta]) [TaskMeta] taskListMetaData :: SDSLens (!TaskId,!TaskId,!TaskListFilter,!ExtendedTaskListFilter) (!TaskId,![TaskMeta]) [TaskMeta]
taskListDynamicValueData :: SDSLens (!TaskId,!TaskId,!TaskListFilter,!ExtendedTaskListFilter) (Map TaskId (TaskValue DeferredJSON)) (Map TaskId (TaskValue DeferredJSON)) taskListDynamicValueData :: SDSLens (!TaskId,!TaskId,!TaskListFilter,!ExtendedTaskListFilter) (Map TaskId (TaskValue DeferredJSON)) (Map TaskId (TaskValue DeferredJSON))
...@@ -142,8 +141,8 @@ taskInstanceParallelTaskListTask :: SDSLens (TaskId,TaskId) (Task DeferredJSO ...@@ -142,8 +141,8 @@ taskInstanceParallelTaskListTask :: SDSLens (TaskId,TaskId) (Task DeferredJSO
//Interface used during the evalation of toplevel tasks //Interface used during the evalation of toplevel tasks
//Filtered views on the instance index //Filtered views on the instance index
taskInstance :: SDSLens (InstanceNo,Bool,Bool) TaskMeta TaskMeta taskInstance :: SDSLens (InstanceNo,Bool,Bool) TaskMeta TaskMeta
taskInstanceValue :: SDSLens InstanceNo (TaskValue DeferredJSON) (TaskValue DeferredJSON) taskInstanceValue :: SDSLens InstanceNo (TaskValue DeferredJSON) (?(TaskValue DeferredJSON))
taskInstanceTask :: SDSLens InstanceNo (Task DeferredJSON) (Task DeferredJSON) taskInstanceTask :: SDSLens InstanceNo (Task DeferredJSON) (?(Task DeferredJSON))
//Locally shared data //Locally shared data
taskInstanceShares :: SDSLens InstanceNo (?(Map TaskId DeferredJSON)) (?(Map TaskId DeferredJSON)) taskInstanceShares :: SDSLens InstanceNo (?(Map TaskId DeferredJSON)) (?(Map TaskId DeferredJSON))
......
...@@ -50,8 +50,8 @@ from Control.Applicative import class Alternative(<|>) ...@@ -50,8 +50,8 @@ from Control.Applicative import class Alternative(<|>)
import Data.GenEq import Data.GenEq
import qualified Control.Monad import qualified Control.Monad
derive JSONEncode TaskMeta, InstanceType, TaskChange, TaskResult, TaskEvalInfo, ExtendedTaskListFilter derive JSONEncode TaskMeta, InstanceType, TaskChange, TaskResult, TaskEvalInfo, ExtendedTaskListFilter, RemovedTask
derive JSONDecode TaskMeta, InstanceType, TaskChange, TaskResult, TaskEvalInfo, ExtendedTaskListFilter derive JSONDecode TaskMeta, InstanceType, TaskChange, TaskResult, TaskEvalInfo, ExtendedTaskListFilter, RemovedTask
derive gDefault InstanceType, TaskId, TaskListFilter derive gDefault InstanceType, TaskId, TaskListFilter
...@@ -154,8 +154,8 @@ createClientTaskInstance task sessionId instanceNo iworld=:{options={appVersion} ...@@ -154,8 +154,8 @@ createClientTaskInstance task sessionId instanceNo iworld=:{options={appVersion}
//Create the initial instance data in the store //Create the initial instance data in the store
# meta = {defaultValue & taskId= TaskId instanceNo 0, instanceType=SessionInstance,build=appVersion,createdAt=clock} # meta = {defaultValue & taskId= TaskId instanceNo 0, instanceType=SessionInstance,build=appVersion,createdAt=clock}
= 'SDS'.write meta (sdsFocus (instanceNo,False,False) taskInstance) 'SDS'.EmptyContext iworld = 'SDS'.write meta (sdsFocus (instanceNo,False,False) taskInstance) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write NoValue (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld `b` \iworld -> 'SDS'.write (?Just NoValue) (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld `b` \iworld -> 'SDS'.write (?Just $ task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> (Ok (TaskId instanceNo 0), iworld) `b` \iworld -> (Ok (TaskId instanceNo 0), iworld)
createSessionTaskInstance :: !(Task a) !Cookies !*IWorld -> (!MaybeError TaskException (!InstanceNo,InstanceKey),!*IWorld) | iTask a createSessionTaskInstance :: !(Task a) !Cookies !*IWorld -> (!MaybeError TaskException (!InstanceNo,InstanceKey),!*IWorld) | iTask a
...@@ -166,8 +166,8 @@ createSessionTaskInstance task cookies iworld=:{options={appVersion,autoLayout}, ...@@ -166,8 +166,8 @@ createSessionTaskInstance task cookies iworld=:{options={appVersion,autoLayout},
# meta = {defaultValue & taskId= TaskId instanceNo 0,instanceType=SessionInstance # meta = {defaultValue & taskId= TaskId instanceNo 0,instanceType=SessionInstance
,instanceKey = ?Just instanceKey,build=appVersion,createdAt=clock, cookies = cookies} ,instanceKey = ?Just instanceKey,build=appVersion,createdAt=clock, cookies = cookies}
= 'SDS'.write meta (sdsFocus (instanceNo,False,False) taskInstance) 'SDS'.EmptyContext iworld = 'SDS'.write meta (sdsFocus (instanceNo,False,False) taskInstance) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write NoValue (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld `b` \iworld -> 'SDS'.write (?Just NoValue) (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld `b` \iworld -> 'SDS'.write (?Just $ task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> (Ok (instanceNo,instanceKey), iworld) `b` \iworld -> (Ok (instanceNo,instanceKey), iworld)
createStartupTaskInstance :: !(Task a) !TaskAttributes !*IWorld -> (!MaybeError TaskException InstanceNo, !*IWorld) | iTask a createStartupTaskInstance :: !(Task a) !TaskAttributes !*IWorld -> (!MaybeError TaskException InstanceNo, !*IWorld) | iTask a
...@@ -175,8 +175,8 @@ createStartupTaskInstance task attributes iworld=:{options={appVersion,autoLayou ...@@ -175,8 +175,8 @@ createStartupTaskInstance task attributes iworld=:{options={appVersion,autoLayou
# (Ok instanceNo,iworld) = newInstanceNo iworld # (Ok instanceNo,iworld) = newInstanceNo iworld
# meta = {defaultValue & taskId= TaskId instanceNo 0,instanceType=StartupInstance,build=appVersion,createdAt=clock,taskAttributes=attributes} # meta = {defaultValue & taskId= TaskId instanceNo 0,instanceType=StartupInstance,build=appVersion,createdAt=clock,taskAttributes=attributes}
= 'SDS'.write meta (sdsFocus (instanceNo,False,False) taskInstance) 'SDS'.EmptyContext iworld = 'SDS'.write meta (sdsFocus (instanceNo,False,False) taskInstance) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write NoValue (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld `b` \iworld -> 'SDS'.write (?Just NoValue) (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld `b` \iworld -> 'SDS'.write (?Just $ task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> (Ok instanceNo, queueEvent instanceNo ResetEvent iworld) `b` \iworld -> (Ok instanceNo, queueEvent instanceNo ResetEvent iworld)
createDetachedTaskInstance :: !(Task a) !TaskEvalOpts !InstanceNo !TaskAttributes !TaskId !Bool !*IWorld -> (!MaybeError TaskException TaskMeta, !*IWorld) | iTask a createDetachedTaskInstance :: !(Task a) !TaskEvalOpts !InstanceNo !TaskAttributes !TaskId !Bool !*IWorld -> (!MaybeError TaskException TaskMeta, !*IWorld) | iTask a
...@@ -187,8 +187,8 @@ createDetachedTaskInstance task evalOpts instanceNo attributes listId refreshImm ...@@ -187,8 +187,8 @@ createDetachedTaskInstance task evalOpts instanceNo attributes listId refreshImm
# meta = {defaultValue & taskId = TaskId instanceNo 0, instanceType=PersistentInstance,build=appVersion # meta = {defaultValue & taskId = TaskId instanceNo 0, instanceType=PersistentInstance,build=appVersion
,createdAt=clock,managementAttributes=attributes, instanceKey= ?Just instanceKey} ,createdAt=clock,managementAttributes=attributes, instanceKey= ?Just instanceKey}
= 'SDS'.write meta (sdsFocus (instanceNo,False,False) taskInstance) 'SDS'.EmptyContext iworld = 'SDS'.write meta (sdsFocus (instanceNo,False,False) taskInstance) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write NoValue (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld `b` \iworld -> 'SDS'.write (?Just NoValue) (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld `b` \iworld -> 'SDS'.write (?Just $ task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> ( Ok meta, if refreshImmediate (queueEvent instanceNo ResetEvent iworld) iworld) `b` \iworld -> ( Ok meta, if refreshImmediate (queueEvent instanceNo ResetEvent iworld) iworld)
replaceTaskInstance :: !InstanceNo !(Task a) *IWorld -> (!MaybeError TaskException (), !*IWorld) | iTask a replaceTaskInstance :: !InstanceNo !(Task a) *IWorld -> (!MaybeError TaskException (), !*IWorld) | iTask a
...@@ -196,8 +196,8 @@ replaceTaskInstance instanceNo task iworld=:{options={appVersion},current={taskT ...@@ -196,8 +196,8 @@ replaceTaskInstance instanceNo task iworld=:{options={appVersion},current={taskT
# (meta, iworld) = 'SDS'.read (sdsFocus (instanceNo,False,False) taskInstance) 'SDS'.EmptyContext iworld # (meta, iworld) = 'SDS'.read (sdsFocus (instanceNo,False,False) taskInstance) 'SDS'.EmptyContext iworld
| isError meta = (liftError meta, iworld) | isError meta = (liftError meta, iworld)
# meta ='SDS'.directResult (fromOk meta) # meta ='SDS'.directResult (fromOk meta)
= 'SDS'.write NoValue (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld = 'SDS'.write (?Just NoValue) (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld `b` \iworld -> 'SDS'.write (?Just $ task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> let in 'SDS'.write {TaskMeta|meta & build=appVersion} (sdsFocus (instanceNo,True,True) taskInstance) 'SDS'.EmptyContext iworld `b` \iworld -> let in 'SDS'.write {TaskMeta|meta & build=appVersion} (sdsFocus (instanceNo,True,True) taskInstance) 'SDS'.EmptyContext iworld
`b` \iworld -> (Ok (), iworld) `b` \iworld -> (Ok (), iworld)
...@@ -380,22 +380,35 @@ where ...@@ -380,22 +380,35 @@ where
notify _ _ _ _ = True notify _ _ _ _ = True
//Last computed value for task instance //Last computed value for task instance
taskInstanceValue :: SDSLens InstanceNo (TaskValue DeferredJSON) (TaskValue DeferredJSON) taskInstanceValue :: SDSLens InstanceNo (TaskValue DeferredJSON) (?(TaskValue DeferredJSON))
taskInstanceValue =: sdsLens "taskInstanceValue" param (SDSRead read) (SDSWrite write) (SDSNotifyConst notify) ?None taskListDynamicValueData taskInstanceValue =: sdsLens "taskInstanceValue" param (SDSRead read) (SDSWrite write) (SDSNotifyConst notify) ?None taskListDynamicValueData
where where
param no = (TaskId 0 0, TaskId no 0, {TaskListFilter|defaultValue & onlyTaskId = ?Just [TaskId no 0]}, defaultValue) param no = (TaskId 0 0, TaskId no 0, {TaskListFilter|defaultValue & onlyTaskId = ?Just [TaskId no 0]}, defaultValue)
read no values = maybe (Error $ exception ("Could not find value for task instance "<+++ no)) Ok ('DM'.get (TaskId no 0) values) read no values =
write no values value = Ok $ ?Just $ 'DM'.put (TaskId no 0) value values maybe (Error $ exception ("Could not find value for task instance "<+++ no)) Ok ('DM'.get (TaskId no 0) values)
write ::
!Int !(Map TaskId (TaskValue DeferredJSON)) !(?(TaskValue DeferredJSON))
-> MaybeError TaskException (?(Map TaskId (TaskValue DeferredJSON)))
write no values ?None = Ok $ ?Just $ 'DM'.del (TaskId no 0) values
write no values (?Just value) = Ok $ ?Just $ 'DM'.put (TaskId no 0) value values
notify _ _ _ _ = True notify _ _ _ _ = True
taskInstanceTask :: SDSLens InstanceNo (Task DeferredJSON) (Task DeferredJSON) taskInstanceTask :: SDSLens InstanceNo (Task DeferredJSON) (?(Task DeferredJSON))
taskInstanceTask =: sdsLens "taskInstanceTask" param (SDSRead read) (SDSWrite write) (SDSNotifyConst notify) ?None taskListDynamicTaskData taskInstanceTask =: sdsLens "taskInstanceTask" param (SDSRead read) (SDSWrite write) (SDSNotifyConst notify) ?None taskListDynamicTaskData
where where
param no = (TaskId 0 0, TaskId no 0, {TaskListFilter|defaultValue & onlyTaskId = ?Just [TaskId no 0]}, defaultValue) param no = (TaskId 0 0, TaskId no 0, {TaskListFilter|defaultValue & onlyTaskId = ?Just [TaskId no 0]}, defaultValue)
read no tasks = maybe (Error $ exception ("Could not find task for task instance "<+++ no)) Ok ('DM'.get (TaskId no 0) tasks) read no tasks = maybe (Error $ exception ("Could not find task for task instance "<+++ no)) Ok ('DM'.get (TaskId no 0) tasks)
write no tasks task = Ok $ ?Just $ 'DM'.put (TaskId no 0) task tasks
write ::
!Int !(Map TaskId (Task DeferredJSON)) !(?(Task DeferredJSON))
-> MaybeError TaskException (?(Map TaskId (Task DeferredJSON)))
write no tasks ?None = Ok $ ?Just $ 'DM'.del (TaskId