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
Tests/Interactive/GenericEditors/TestRecordWithADT
Tests/Interactive/GenericEditors/TestSingleRecord
Tests/Interactive/GenericEditors/TestString
Tests/MemoryLeaks
Tests/TestAsyncTask
Tests/Unit/iTasks.Extensions.FileCollection.UnitTests
Tests/Unit/iTasks.Extensions.Process.UnitTests
......
......@@ -299,7 +299,7 @@ determineAppVersion appPath world
determineTimeout :: !(?Timeout) !*IWorld -> (!?Timeout,!*IWorld)
determineTimeout mt iworld = case read taskEvents EmptyContext iworld of
//No events
(Ok (ReadingDone (Queue [] [])),iworld=:{sdsNotifyRequests,world})
(Ok (ReadingDone (Queue [|] [|])),iworld=:{sdsNotifyRequests,world})
# (ts, world) = nsTime world
=
( minListBy lesser [mt:flatten (map (getTimeoutFromClock ts) ('DM'.elems sdsNotifyRequests))]
......
......@@ -20,6 +20,7 @@ gText{|TaskWrapper|} tf ma = maybe [] (\_->["TaskWrapper"]) ma
derive JSONEncode AsyncTaskResult
derive JSONDecode AsyncTaskResult
derive class iTask Queue, Event, AsyncQueueItem
derive class iTask \ JSONEncode, JSONDecode [!!]
asyncITasksQueue :: SDSLens () () AsyncQueueItem
asyncITasksQueue = mapReadWrite (\_->(), \task queue -> ?Just (enqueue task queue)) ?None asyncITasksQueueInt
......
......@@ -71,7 +71,7 @@ where
flushWritesWhenIdle:: Task ()
flushWritesWhenIdle = everyTick \iworld->case read taskEvents EmptyContext iworld of
(Error e,iworld) = (Error e,iworld)
(Ok (ReadingDone (Queue [] [])),iworld) = flushDeferredSDSWrites iworld
(Ok (ReadingDone (Queue [|] [|])),iworld) = flushDeferredSDSWrites 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
......
......@@ -27,8 +27,14 @@ mkEvalOpts :: TaskEvalOpts
//* External information passed from the task
:: TaskEvalInfo =
{ lastEvent :: !TaskTime //When was the last event in this task
, removedTasks :: ![(TaskId,TaskId)] //Which embedded parallel tasks were removed (listId,taskId)
{ lastEvent :: !TaskTime //* When was the last event in this task
, 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
......
implementation module iTasks.Internal.TaskEval
import StdList, StdBool, StdTuple, StdMisc, StdString
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
......@@ -43,7 +42,7 @@ processEvents max iworld
= case dequeueEvent iworld of
(Error e, iworld) = (Error e, iworld)
(Ok ?None, iworld) = (Ok (), iworld)
(Ok (?Just (instanceNo,event)), iworld)
(Ok (?Just {instanceNo,event}), iworld)
= case evalTaskInstance instanceNo event iworld of
(Ok taskValue,iworld)
= processEvents (max - 1) iworld
......@@ -136,14 +135,20 @@ where
# (mbErr,iworld) = modify (updateProgress clock newResult nextTaskNo nextTaskTime) (sdsFocus (instanceNo,False,True) taskInstance) EmptyContext iworld
| mbErr =: (Error _) = (liftError mbErr, iworld)
//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)
//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)
= (Ok (),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
# (mbErr,iworld) = write ?None (sdsFocus instanceNo taskInstanceShares) EmptyContext iworld
| mbErr =: (Error _) = (liftError mbErr, iworld)
......
......@@ -15,8 +15,13 @@ from Data.Queue import :: Queue
from Data.Set import :: Set
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.
:: TaskInput :== Queue (InstanceNo,Event)
//* When events are placed in this queue, the engine will re-evaluate the corresponding task instances.
:: TaskInput :== Queue QueuedEvent
:: QueuedEvent =
{ instanceNo :: !InstanceNo
, event :: !Event
}
taskEvents :: SimpleSDSLens TaskInput
......@@ -35,15 +40,14 @@ taskEvents :: SimpleSDSLens TaskInput
taskOutput :: SimpleSDSLens (Map InstanceNo TaskOutput)
taskInstanceOutput :: SDSLens InstanceNo TaskOutput TaskOutput
/**
* Writing in this share queues an event for a task instance
* 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
* the need to directly processing them.
*/
queueEventShare :: SDSLens () () (InstanceNo, Event)
* Writing in this share queues an event for a task instance.
* 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 the need to directly processing them.
*/
queueEventShare :: SDSLens () () QueuedEvent
//* Queue an event for a task instance by writing in {{queueEventShare}}
queueEvent :: !InstanceNo !Event !*IWorld -> *IWorld
......@@ -54,16 +58,17 @@ queueRefresh :: !TaskId !*IWorld -> *IWorld
//* Convenience function for queueing multiple refresh multiple refresh events at once.
queueRefreshes :: !(Set TaskId) !*IWorld -> *IWorld
/**
* Dequeue a task event
*/
dequeueEvent :: !*IWorld -> (!MaybeError TaskException (?(InstanceNo,Event)),!*IWorld)
//* Dequeue a task event.
dequeueEvent :: !*IWorld -> (!MaybeError TaskException (?QueuedEvent),!*IWorld)
/**
* Remove all events for a given instance
*/
clearEvents :: !InstanceNo !*IWorld -> *IWorld
//* Remove all events for a given task.
clearEventsFor :: !TaskId !*IWorld -> *IWorld
/**
* Queue different types of output at once
*/
......
......@@ -28,8 +28,8 @@ import iTasks.SDS.Combinators.Core, iTasks.SDS.Combinators.Common
import iTasks.SDS.Sources.Store
import iTasks.WF.Derives
derive JSONEncode TaskOutputMessage, Queue, Event
derive JSONDecode TaskOutputMessage, Queue, Event
derive JSONEncode TaskOutputMessage, QueuedEvent, Queue, Event
derive JSONDecode TaskOutputMessage, QueuedEvent, Queue, Event
rawInstanceEvents = storeShare NS_TASK_INSTANCES False InMemory (?Just 'DQ'.newQueue)
rawInstanceOutput = storeShare NS_TASK_INSTANCES False InMemory (?Just 'DM'.newMap)
......@@ -50,28 +50,28 @@ where
reducer p ws = Ok (fromMaybe 'DQ'.newQueue ('DM'.get p ws))
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 = mapReadWrite (const (), writer) ?None taskEvents
queueEventShare :: SDSLens () () QueuedEvent
queueEventShare =: mapReadWrite (const (), writer) ?None taskEvents
where
writer :: (InstanceNo, Event) TaskInput -> ?TaskInput
writer (instanceNo, event) q = ?Just (fromMaybe ('DQ'.enqueue (instanceNo,event) q) (queueWithMergedRefreshEvent q))
writer :: !QueuedEvent !TaskInput -> ?TaskInput
writer qe=:{instanceNo,event} q = ?Just (fromMaybe ('DQ'.enqueue qe q) (queueWithMergedRefreshEvent q))
where
// 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
RefreshEvent refreshTasks =
((\front` -> ('DQ'.Queue front` back)) <$> queueWithMergedRefreshEventList front) <|>
((\back` -> ('DQ'.Queue front back`)) <$> queueWithMergedRefreshEventList back)
where
queueWithMergedRefreshEventList :: [(InstanceNo, Event)] -> ?[(InstanceNo, Event)]
queueWithMergedRefreshEventList [] = ?None
queueWithMergedRefreshEventList [hd=:(instanceNo`, event`) : tl] = case event` of
RefreshEvent refreshTasks` | instanceNo` == instanceNo =
?Just [(instanceNo, RefreshEvent ('DS'.union refreshTasks refreshTasks`)) : tl]
queueWithMergedRefreshEventList :: [!QueuedEvent!] -> ?[!QueuedEvent!]
queueWithMergedRefreshEventList [|] = ?None
queueWithMergedRefreshEventList [|hd=:{instanceNo=ino`, event=ev`}:tl] = case ev` of
RefreshEvent refreshTasks` | ino` == instanceNo =
?Just [|{instanceNo=instanceNo, event=RefreshEvent ('DS'.union refreshTasks refreshTasks`)}:tl]
_ =
(\tl` -> [hd : tl`]) <$> queueWithMergedRefreshEventList tl
(\tl` -> [|hd : tl`]) <$> queueWithMergedRefreshEventList tl
_ = ?None
queueRefresh :: !TaskId !*IWorld -> *IWorld
......@@ -84,9 +84,8 @@ queueRefreshes tasks iworld
# iworld = 'Foldable'.foldl (\w t -> queueEvent (toInstanceNo t) (RefreshEvent ('DS'.singleton t)) w) iworld tasks
= iworld
dequeueEvent :: !*IWorld -> (!MaybeError TaskException (?(InstanceNo,Event)),!*IWorld)
dequeueEvent iworld
= case 'SDS'.read taskEvents 'SDS'.EmptyContext iworld of
dequeueEvent :: !*IWorld -> (!MaybeError TaskException (?QueuedEvent),!*IWorld)
dequeueEvent iworld = case 'SDS'.read taskEvents 'SDS'.EmptyContext iworld of
(Error e, iworld) = (Error e, iworld)
(Ok ('SDS'.ReadingDone queue), iworld)
# (val, queue) = 'DQ'.dequeue queue
......@@ -99,7 +98,33 @@ clearEvents instanceNo iworld
# (_,iworld) = 'SDS'.modify clear taskEvents 'SDS'.EmptyContext iworld
= iworld
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 messages iworld
......
......@@ -566,7 +566,7 @@ halt :: !Int !*IWorld -> *IWorld
halt exitCode iworld
# (merr, iworld) = read allTaskInstances EmptyContext 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
where
destroy :: !InstanceNo !*IWorld -> *IWorld
......
......@@ -119,7 +119,6 @@ newInstanceKey :: !*IWorld -> (!InstanceKey,!*IWorld)
nextInstanceNo :: SimpleSDSLens Int
//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]
taskListDynamicValueData :: SDSLens (!TaskId,!TaskId,!TaskListFilter,!ExtendedTaskListFilter) (Map TaskId (TaskValue DeferredJSON)) (Map TaskId (TaskValue DeferredJSON))
......@@ -142,8 +141,8 @@ taskInstanceParallelTaskListTask :: SDSLens (TaskId,TaskId) (Task DeferredJSO
//Interface used during the evalation of toplevel tasks
//Filtered views on the instance index
taskInstance :: SDSLens (InstanceNo,Bool,Bool) TaskMeta TaskMeta
taskInstanceValue :: SDSLens InstanceNo (TaskValue DeferredJSON) (TaskValue DeferredJSON)
taskInstanceTask :: SDSLens InstanceNo (Task DeferredJSON) (Task DeferredJSON)
taskInstanceValue :: SDSLens InstanceNo (TaskValue DeferredJSON) (?(TaskValue DeferredJSON))
taskInstanceTask :: SDSLens InstanceNo (Task DeferredJSON) (?(Task DeferredJSON))
//Locally shared data
taskInstanceShares :: SDSLens InstanceNo (?(Map TaskId DeferredJSON)) (?(Map TaskId DeferredJSON))
......
......@@ -50,8 +50,8 @@ from Control.Applicative import class Alternative(<|>)
import Data.GenEq
import qualified Control.Monad
derive JSONEncode TaskMeta, InstanceType, TaskChange, TaskResult, TaskEvalInfo, ExtendedTaskListFilter
derive JSONDecode TaskMeta, InstanceType, TaskChange, TaskResult, TaskEvalInfo, ExtendedTaskListFilter
derive JSONEncode TaskMeta, InstanceType, TaskChange, TaskResult, TaskEvalInfo, ExtendedTaskListFilter, RemovedTask
derive JSONDecode TaskMeta, InstanceType, TaskChange, TaskResult, TaskEvalInfo, ExtendedTaskListFilter, RemovedTask
derive gDefault InstanceType, TaskId, TaskListFilter
......@@ -154,8 +154,8 @@ createClientTaskInstance task sessionId instanceNo iworld=:{options={appVersion}
//Create the initial instance data in the store
# meta = {defaultValue & taskId= TaskId instanceNo 0, instanceType=SessionInstance,build=appVersion,createdAt=clock}
= '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 (task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (?Just NoValue) (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (?Just $ task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> (Ok (TaskId instanceNo 0), iworld)
createSessionTaskInstance :: !(Task a) !Cookies !*IWorld -> (!MaybeError TaskException (!InstanceNo,InstanceKey),!*IWorld) | iTask a
......@@ -166,8 +166,8 @@ createSessionTaskInstance task cookies iworld=:{options={appVersion,autoLayout},
# meta = {defaultValue & taskId= TaskId instanceNo 0,instanceType=SessionInstance
,instanceKey = ?Just instanceKey,build=appVersion,createdAt=clock, cookies = cookies}
= '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 (task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (?Just NoValue) (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (?Just $ task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> (Ok (instanceNo,instanceKey), iworld)
createStartupTaskInstance :: !(Task a) !TaskAttributes !*IWorld -> (!MaybeError TaskException InstanceNo, !*IWorld) | iTask a
......@@ -175,8 +175,8 @@ createStartupTaskInstance task attributes iworld=:{options={appVersion,autoLayou
# (Ok instanceNo,iworld) = newInstanceNo iworld
# 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
`b` \iworld -> 'SDS'.write NoValue (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (?Just NoValue) (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (?Just $ task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> (Ok instanceNo, queueEvent instanceNo ResetEvent iworld)
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
# meta = {defaultValue & taskId = TaskId instanceNo 0, instanceType=PersistentInstance,build=appVersion
,createdAt=clock,managementAttributes=attributes, instanceKey= ?Just instanceKey}
= '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 (task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (?Just NoValue) (sdsFocus instanceNo taskInstanceValue) '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)
replaceTaskInstance :: !InstanceNo !(Task a) *IWorld -> (!MaybeError TaskException (), !*IWorld) | iTask a
......@@ -196,8 +196,8 @@ replaceTaskInstance instanceNo task iworld=:{options={appVersion},current={taskT
# (meta, iworld) = 'SDS'.read (sdsFocus (instanceNo,False,False) taskInstance) 'SDS'.EmptyContext iworld
| isError meta = (liftError meta, iworld)
# meta ='SDS'.directResult (fromOk meta)
= 'SDS'.write NoValue (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (task @ DeferredJSON) (sdsFocus instanceNo taskInstanceTask) 'SDS'.EmptyContext iworld
= 'SDS'.write (?Just NoValue) (sdsFocus instanceNo taskInstanceValue) '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 -> (Ok (), iworld)
......@@ -380,22 +380,35 @@ where
notify _ _ _ _ = True
//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
where
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)
write no values value = Ok $ ?Just $ 'DM'.put (TaskId no 0) value values
read no 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
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
where
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)
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 no 0) tasks
write no tasks (?Just task) = Ok $ ?Just $ 'DM'.put (TaskId no 0) task tasks
notify _ _ _ _ = True
parallelTaskList :: SDSLens (!TaskId,!TaskId,!TaskListFilter) (!TaskId,![TaskListItem a]) [(TaskId,TaskAttributes)] | iTask a
......
implementation module iTasks.Internal.Util
import StdBool, StdChar, StdList, StdFile, StdMisc, StdArray, StdString, StdTuple, StdFunc, StdGeneric, StdOrdList
import StdEnv
import Data.Tuple, Data.Func, System.Time, System.OS, Text, System.FilePath, System.Directory, Text.GenJSON, Data.Error, Data.GenEq
import Data.Error, System.OSError, System.File
import iTasks.Engine
......@@ -96,7 +96,7 @@ isDestroyOrInterrupt ServerInterruptedEvent = True
isDestroyOrInterrupt _ = False
mkTaskEvalInfo :: !TaskTime -> TaskEvalInfo
mkTaskEvalInfo ts = {TaskEvalInfo|lastEvent=ts,removedTasks=[]}
mkTaskEvalInfo ts = {TaskEvalInfo|lastEvent=ts,removedTasks=[|]}
mkUIIfReset :: !Event !UI -> UIChange
mkUIIfReset ResetEvent ui = ReplaceUI ui
......
......@@ -48,9 +48,7 @@ from iTasks.UI.Tune import class tune
:: TestProperty
= Name !String //* Gives a name to a task so that it can be found with `ByTestName`.
derive gEditor TestEvent
derive gEq TestEvent
derive gText TestEvent
derive class iTask \ JSONEncode, JSONDecode TestEvent
instance tune TestProperty (Task a)
......
......@@ -32,11 +32,10 @@ JSONDecode{|PrelinkedInterpretationEnvironment|} _ j = (?None,j)
gEq{|PrelinkedInterpretationEnvironment|} _ _ = False
derive class iTask EndEventType, Expression
derive gEditor TestEvent, StartEvent, EndEvent, TestLocation, FailReason, CounterExample, FailedAssertion, Relation
derive gText TestEvent, StartEvent, EndEvent, TestLocation, FailReason, CounterExample, FailedAssertion, Relation
derive gEq TestEvent, StartEvent, EndEvent, TestLocation, FailReason, CounterExample, FailedAssertion, Relation
derive class iTask \ JSONEncode, JSONDecode TestEvent, StartEvent, EndEvent, TestLocation, FailReason, CounterExample, FailedAssertion, Relation
derive class iTask Queue, Event
derive class iTask Queue, Event, QueuedEvent
derive class iTask \ JSONEncode, JSONDecode [!!]
:: TestStatus =
{ tcpQueue :: !String
......@@ -152,8 +151,8 @@ where
handleResponses :: (SimpleSDSLens TestStatus) -> Task ()
handleResponses share = watch share >>*
[ OnValue $ ifValue (\s -> s.waitRequested=:[_:_]) \{waitRequested} ->
get (taskEvents |*| allTaskInstances) >>- \(Queue ea eb,timeta) ->
let active_instance_nos = [i \\ (i,_) <- ea ++ eb] in
get (taskEvents |*| allTaskInstances) >>- \(queue,timeta) ->
let active_instance_nos = [instanceNo \\ {QueuedEvent|instanceNo} <- toList queue] in
allTasks
[checkInstanceNo no timeta
@! if (isMember no active_instance_nos) ?None (?Just no)
......@@ -173,7 +172,7 @@ where
]
where
checkInstanceNo :: !InstanceNo ![TaskInstance] -> Task InstanceNo
checkInstanceNo no instances = case [i \\ {instanceNo=i} <- instances | i == no] of
checkInstanceNo no instances = case [i \\ {TaskInstance|instanceNo=i} <- instances | i == no] of
[m] -> return m
[] -> throw ("No active task with InstanceNo '"+++toString no+++"' found")
_ -> throw ("More than one active task with InstanceNo '"+++toString no+++"' found")
......@@ -198,8 +197,8 @@ runTestSuite options [TestedTask task spec:specs] w
// Run test and print events coming in while running
(runTest options spec queue -|| watchEventQueue queue) >>- \events ->
// Print any remaining events and crash events for started tests without EndEvent
get queue >>- \(Queue front rear) ->
printEvents (front ++ reverse rear ++ getCrashedEvents [] events) >-|
get queue >>- \q ->
printEvents (toList q ++ getCrashedEvents [] events) >-|
shutDown 0
)
, {engineOptions & verboseOperation=False}
......
......@@ -4,6 +4,7 @@ import StdEnv
import Data.Either
import qualified Data.Map as Map
import qualified Data.Queue as Queue
from Data.Queue import :: Queue(..)
import System.CommandLine
import System.Options
......@@ -94,7 +95,10 @@ where
//Empty the store to make sure that we get a reliable task instance no 1
# iworld = emptyStore iworld
//Create an instance with autolayouting disabled at the top level
# (res,iworld) = createSessionTaskInstance (task >>- \r -> shutDown 0 @! r) 'Map'.newMap iworld
# resultShare = sharedStore "iTasks.Testing.Unit:resultShare" ?None
# (res,iworld) = createSessionTaskInstance
(task >>- \r -> set (?Just r) resultShare >-| shutDown 0)
'Map'.newMap iworld
= case res of
(Ok (instanceNo,instanceKey))
//Apply all events
......@@ -104,7 +108,7 @@ where
//Collect output
# iworld = loop (determineTimeout ?None) iworld
# (mbOutput,iworld) = 'SDS'.read (sdsFocus instanceNo taskInstanceOutput) 'SDS'.EmptyContext iworld
# (mbValue,iworld) = 'SDS'.read (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
# (mbValue,iworld) = 'SDS'.read resultShare 'SDS'.EmptyContext iworld
# world = destroyIWorld iworld
# verdict = check` mbOutput mbValue
= (verdict,world)
......@@ -142,13 +146,9 @@ where
}
check` (Ok ('SDS'.ReadingDone queue)) (Ok ('SDS'.ReadingDone val))
# val = decodeTaskValue val
= case val of
Value val True -> check (toList queue) val
?Just val -> check ('Queue'.toList queue) val
_ -> Failed (?Just (CustomFailReason "no stable task value"))
where
//SHOULD BE IN Data.Queue
toList (Queue front rear) = front ++ reverse rear
check` _ _
= Failed (?Just (CustomFailReason "failed to read output or task value"))
......
implementation module iTasks.WF.Combinators.Core
import StdEnv
import StdOverloadedList
import iTasks.SDS.Combinators.Common
import iTasks.SDS.Definition
......@@ -131,7 +132,7 @@ where
//No match
?None = (Left (ExceptionResult e), iworld)
//A match
?Just rewrite = (Right (rewrite, lastEval, []), iworld)
?Just rewrite = (Right (rewrite, lastEval, [|]), iworld)
= case mbCont of
//No match, just pass through
Left res = (res, iworld)
......@@ -141,7 +142,7 @@ where
# (resb, iworld) = rhs ResetEvent evalOpts iworld
= case resb of
ValueResult val info change=:(ReplaceUI _) (Task rhs)
# info = {TaskEvalInfo|info & lastEvent = max lastEvent info.TaskEvalInfo.lastEvent, removedTasks = removedTasks ++ info.TaskEvalInfo.removedTasks}
# info = {TaskEvalInfo|info & lastEvent = max lastEvent info.TaskEvalInfo.lastEvent, removedTasks = removedTasks ++| info.TaskEvalInfo.removedTasks}
= (ValueResult
val