Commit f2aa2162 authored by Bas Lijnse's avatar Bas Lijnse

Major refactoring of task evaluation. There are still some small issues, but...

Major refactoring of task evaluation. There are still some small issues, but almost everything is working again. (And a lot faster :))

git-svn-id: https://svn.cs.ru.nl/repos/iTask-system/trunk@1638 63da3aa8-80fd-4f01-9db8-e6ea747a3da2
parent 1ee5c536
......@@ -159,13 +159,13 @@ chooseProcess :: String -> Task ProcessId
chooseProcess question
= getProcessesWithStatus [Running] [Active]
>>= \procs -> enterChoiceA question id
[ ( proc.Process.taskId
[ ( proc.Process.properties.ProcessProperties.systemProperties.SystemProperties.taskId
, proc.Process.properties.ProcessProperties.taskProperties.taskDescription.TaskDescription.title
, proc.Process.properties.ProcessProperties.managerProperties.ManagerProperties.priority
, proc.Process.properties.ProcessProperties.managerProperties.ManagerProperties.worker)
\\ proc <- procs]
>?* [ (ActionCancel, Always (throw "choosing a process has been cancelled"))
, (ActionOk, IfValid (\(pid,_,_,_) -> return pid))
, (ActionOk, IfValid (\(pid,_,_,_) -> return (toInt pid)))
]
......
implementation module Client
import iTasks, TSt, Text
import iTasks, Text
from UserDB import qualified class UserDB(..)
from UserDB import qualified instance UserDB TSt
from ProcessDB import qualified class ProcessDB(..)
from ProcessDB import qualified instance ProcessDB IWorld
from Shared import makeReadOnlyShared
from StdFunc import o, seq
from Util import mb2list
import StdMisc
derive bimap Maybe, (,)
clientExample :: [Workflow]
......@@ -46,17 +47,15 @@ processTable =
get currentUser
>>= \user. updateSharedInformationA "process table" (Table o map toView,\_ _ -> Void) (currentProcessesForUser user) noActions
where
toView {Process|properties=p=:{taskProperties,managerProperties,systemProperties,progress}} =
toView {Process|properties=p=:{taskProperties,managerProperties,systemProperties}} =
{ title = Display taskProperties.taskDescription.TaskDescription.title
, priority = formatPriority managerProperties.ManagerProperties.priority
, progress = formatProgress progress
, date = Display systemProperties.issuedAt
, deadline = Display managerProperties.ManagerProperties.deadline
}
:: ProcessTableView = { title :: !Display String
, priority :: !HtmlDisplay
, progress :: !HtmlDisplay
, date :: !Display Timestamp
, deadline :: !Display (Maybe DateTime)
}
......@@ -117,12 +116,12 @@ processTableLayout {editorParts} =
}
getWorkflowTreeNodes :: Task [TreeNode (!String,!Hidden String,!Hidden Int)]
getWorkflowTreeNodes = mkInstantTask "get a tree of workflows" getWorkflowTree`
getWorkflowTreeNodes = abort "TODO" //mkInstantTask "get a tree of workflows" getWorkflowTree`
/*
where
getWorkflowTree` tst
# (workflows,tst) = ([],tst)//get workflows tst
= (TaskFinished (mkFlowTree workflows),tst)
getWorkflowTree` iworld
# (workflows,iworld) = getAllowedWorkflows iworld
= (TaskFinished (mkFlowTree workflows),iworld)
mkFlowTree workflows = seq (map insertWorkflow (zip2 workflows (indexList workflows))) []
where
insertWorkflow ({Workflow|path,description},idx) nodeList = insertWorkflow` (split "/" path) nodeList
......@@ -134,10 +133,32 @@ where
| otherwise = [node:insertWorkflow` path nodesR]
insertWorkflow` path [leaf=:(Leaf _):nodesR] = [leaf:insertWorkflow` path nodesR]
insertWorkflow` [nodeP:pathR] [] = [Node nodeP (insertWorkflow` pathR [])]
*/
startWorkflow :: !Workflow -> Task Void
startWorkflow {thread,managerProperties,menu} = mkInstantTask "create new task" (startWorkflow` thread managerProperties menu)
startWorkflow` thread managerProperties menu tst
# (_,_,_,tst) = createTaskInstance thread True True managerProperties menu tst
= (TaskFinished Void,tst)
\ No newline at end of file
startWorkflow {thread,managerProperties,menu} = abort "TODO"
startWorkflowByIndex :: !Int -> Task Void
startWorkflowByIndex idx = abort "TODO"
/*
= mkInstantTask "create new task by index in workflow list" startWorkflowByIndex`
where
startWorkflowByIndex` tst
# (workflows,tst) = getAllowedWorkflows tst
# {thread,managerProperties,menu} = workflows !! idx
= startWorkflow` thread managerProperties menu tst
getAllowedWorkflows tst
# (session,tst) = getCurrentSession tst
# (mbDetails,tst) = 'UserDB'.getUserDetails session.Session.user tst
# (workflows,tst) = getWorkflows tst
# workflows = filter (isAllowed (session.Session.user,mbDetails)) workflows
= (workflows,tst)
where
//Allow the root user
isAllowed (RootUser,_) _ = True
//Allow workflows for which the user has permission
isAllowed (_,Just details) wf = or [isMember role (mb2list details.UserDetails.roles) \\ role <- wf.Workflow.roles] || isEmpty wf.Workflow.roles
//Allow workflows without required roles
isAllowed _ wf = isEmpty wf.Workflow.roles
*/
......@@ -5,7 +5,7 @@ import StdFile
import GenEq
import Text
import iTasks, TSt
import iTasks
import GinAbstractSyntax
import GinConfig
......@@ -300,6 +300,3 @@ tryRender gMod config printOption world
showAbout :: EditorState -> Task EditorState
showAbout state = showMessage ("Gin workflow editor", "version 0.1") state
accIWorld :: !(*IWorld -> *(!a,!*IWorld)) -> Task a | iTask a
accIWorld fun = mkInstantTask ("Run Iworld function", "Run a IWorld function and get result.") (mkTaskFunction (accIWorldTSt fun))
......@@ -7,6 +7,9 @@ import iTasks
:: NegativeValueException = NegativeValueException String
:: TooLargeValueException = TooLargeValueException String
derive bimap Maybe,(,)
derive class iTask NegativeValueException, TooLargeValueException
instance toString NegativeValueException
where
toString (NegativeValueException err) = err
......
......@@ -3,15 +3,15 @@ implementation module CommonCombinators
* This module contains a collection of useful iTasks combinators defined in terms of the basic iTask combinators
* with Thanks to Erik Zuurbier for suggesting some of the advanced combinators
*/
import StdBool, StdList,StdOrdList, StdTuple, StdGeneric, StdMisc, StdInt, StdClass, GenRecord, Text
import Util, Either, TSt, GenVisualize, GenUpdate
import StdBool, StdList,StdOrdList, StdTuple, StdGeneric, StdMisc, StdInt, StdClass, GenRecord, Text, Time
import Util, Either, GenVisualize, GenUpdate
from StdFunc import id, const, o
from Types import :: ProcessId, :: User(..), :: Note(..)
from Store import :: Store
from SessionDB import :: Session
from TaskTree import :: TaskTree
from TaskContext import :: TaskContext(..), :: TopTaskContext, :: SubTaskContext, :: ParallelMeta
from Shared import mapShared, :: SymmetricShared
from SystemData import randomInt
from Map import qualified newMap
import CoreTasks, CoreCombinators, ExceptionCombinators, TuningCombinators, ProcessDBTasks, InteractionTasks
// use string instances of generic function for Tag values
......@@ -57,8 +57,10 @@ accu accufun task pstate pcontrol
(return result)
transform :: !(a -> b) !a -> Task b | iTask b
transform f x = mkInstantTask ("Value transformation", "Value transformation with a custom function") (\tst -> (TaskFinished (f x),tst))
transform f x = mkInstantTask ("Value transformation", "Value transformation with a custom function") eval
where
eval taskNr iworld = (TaskFinished (f x), iworld)
/*
* When a task is assigned to a user a synchronous task instance process is created.
* It is created once and loaded and evaluated on later runs.
......@@ -69,14 +71,13 @@ assign props actionMenu task = parallel ("Assign","Manage a task assigned to ano
where
processControl :: state !(Shared [ParallelTaskInfo] [Control c]) -> Task Void | iTask c
processControl _ control =
ControlTask @>> updateSharedInformationA (taskTitle task,"Waiting for " +++ taskTitle task) (toView,fromView) control (const [])
updateSharedInformationA (taskTitle task,"Waiting for " +++ taskTitle task) (toView,fromView) control (const [])
accJust r _ = (Just r,True)
toView [_,{ParallelTaskInfo|properties=Right {progress,systemProperties=s=:{issuedAt,firstEvent,latestEvent},managerProperties=m=:{worker}}}]=
toView [_,{ParallelTaskInfo|properties=Right {systemProperties=s=:{issuedAt,firstEvent,latestEvent},managerProperties=m=:{worker}}}]=
{ mapRecord m
& assignedTo = worker
, progress = formatProgress progress
, issuedAt = Display issuedAt
, firstWorkedOn = Display firstEvent
, lastWorkedOn = Display latestEvent
......@@ -85,7 +86,6 @@ where
{ assignedTo = NamedUser "root"
, priority = NormalPriority
, status = Suspended
, progress = HtmlDisplay "Why??"
, issuedAt = Display (Timestamp 0)
, firstWorkedOn = Display Nothing
, lastWorkedOn = Display Nothing
......@@ -98,7 +98,6 @@ where
:: ProcessControlView = { assignedTo :: !User
, priority :: !TaskPriority
, status :: !RunningTaskStatus
, progress :: !HtmlDisplay
, issuedAt :: !Display Timestamp
, firstWorkedOn :: !Display (Maybe Timestamp)
, lastWorkedOn :: !Display (Maybe Timestamp)
......
implementation module ExportTasks
import StdBool, FilePath, TSt, CSV, File, DocumentDB, ExceptionCombinators
import StdBool, FilePath, CSV, File, Map, DocumentDB, Task, TaskContext, ExceptionCombinators
exportDocument :: !FilePath !Document -> Task Document
exportDocument filename document = mkInstantTask ("Document export", ("Export of document " +++ filename)) (writeDocument filename document)
exportDocument filename document = mkInstantTask ("Document export", ("Export of document " +++ filename)) eval
where
eval taskNr iworld = writeDocument filename document iworld
exportTextFile :: !FilePath !String -> Task String
exportTextFile filename content = mkInstantTask ("Text file export", ("Export of text file " +++ filename))(fileTask filename content writeAll)
exportTextFile filename content = mkInstantTask ("Text file export", ("Export of text file " +++ filename)) eval
where
eval taskNr iworld = fileTask filename content writeAll iworld
exportCSVFile :: !FilePath ![[String]] -> Task [[String]]
exportCSVFile filename content = mkInstantTask ("CSV file export", ("Export of CSV file " +++ filename)) (fileTask filename content writeCSVFile)
exportCSVFile filename content = mkInstantTask ("CSV file export", ("Export of CSV file " +++ filename)) eval
where
eval taskNr iworld = fileTask filename content writeCSVFile iworld
exportCSVFileWith :: !Char !Char !Char !FilePath ![[String]] -> Task [[String]]
exportCSVFileWith delimitChar quoteChar escapeChar filename content = mkInstantTask ("CSV file export", ("Export of CSV file " +++ filename)) (fileTask filename content (writeCSVFileWith delimitChar quoteChar escapeChar))
exportCSVFileWith delimitChar quoteChar escapeChar filename content = mkInstantTask ("CSV file export", ("Export of CSV file " +++ filename)) eval
where
eval taskNr iworld = fileTask filename content (writeCSVFileWith delimitChar quoteChar escapeChar) iworld
exportJSONFile :: !FilePath a -> Task a | JSONEncode{|*|} a
exportJSONFile filename content = exportJSONFileWith toJSON filename content
exportJSONFileWith :: !(a -> JSONNode) !FilePath a -> Task a
exportJSONFileWith encoder filename content = mkInstantTask ("JSON file export", ("Export of JSON file " +++ filename)) (fileTask filename content (writeJSON encoder))
exportJSONFileWith encoder filename content = mkInstantTask ("JSON file export", ("Export of JSON file " +++ filename)) eval
where
eval taskNr iworld = fileTask filename content (writeJSON encoder) iworld
fileTask filename content f tst=:{TSt|iworld=iworld=:{IWorld|world}}
fileTask filename content f iworld=:{IWorld|world}
# (ok,file,world) = fopen filename FWriteData world
| not ok = (openException filename,{TSt|tst & iworld={IWorld|iworld & world = world}})
| not ok = (openException filename,{IWorld|iworld & world = world})
# file = f content file
# (ok,world) = fclose file world
| not ok = (closeException filename,{TSt|tst & iworld={IWorld|iworld & world = world}})
= (TaskFinished content, {TSt|tst & iworld={IWorld|iworld & world = world}})
| not ok = (closeException filename,{IWorld|iworld & world = world})
= (TaskFinished content, {IWorld|iworld & world = world})
writeAll content file
= fwrites content file
......@@ -34,16 +44,16 @@ writeAll content file
writeJSON encoder content file
= fwrites (toString (encoder content)) file
writeDocument filename document tst
# (mbContent,tst=:{TSt|iworld=iworld=:{IWorld|world}})
= getDocumentContent document.Document.documentId tst
| isNothing mbContent = (ioException filename, {TSt|tst & iworld={IWorld|iworld & world = world}})
writeDocument filename document iworld
# (mbContent,iworld=:{IWorld|world})
= getDocumentContent document.Document.documentId iworld
| isNothing mbContent = (ioException filename, {IWorld|iworld & world = world})
# (ok,file,world) = fopen filename FWriteData world
| not ok = (openException filename,{TSt|tst & iworld={IWorld|iworld & world = world}})
| not ok = (openException filename,{IWorld|iworld & world = world})
# file = fwrites (fromJust mbContent) file
# (ok,world) = fclose file world
| not ok = (closeException filename,{TSt|tst & iworld={IWorld|iworld & world = world}})
= (TaskFinished document, {TSt|tst & iworld={IWorld|iworld & world = world}})
| not ok = (closeException filename,{IWorld|iworld & world = world})
= (TaskFinished document, {IWorld|iworld & world = world})
ioException s = taskException (FileException s IOError)
openException s = taskException (FileException s CannotOpen)
......
implementation module ImportTasks
import StdBool, _SystemArray, StdInt, TSt, DocumentDB, MIME, Text, Util, CSV, File, ExceptionCombinators
import StdBool, _SystemArray, StdInt, Task, TaskContext, DocumentDB, MIME, Text, Util, CSV, File, Map, ExceptionCombinators
from StdFunc import id
CHUNK_SIZE :== 1024
importDocument :: !FilePath -> Task Document
importDocument filename = mkInstantTask ("Document import", ("Import of document " +++ filename)) (readDocument filename)
importDocument filename = mkInstantTask ("Document import", ("Import of document " +++ filename)) eval
where
eval taskNr iworld = readDocument filename iworld
importTextFile :: !FilePath -> Task String
importTextFile filename = mkInstantTask ("Text file import", ("Import of text file " +++ filename)) (fileTask filename readAll)
importTextFile filename = mkInstantTask ("Text file import", ("Import of text file " +++ filename)) eval
where
eval taskNr iworld = fileTask filename readAll iworld
importCSVFile :: !FilePath -> Task [[String]]
importCSVFile filename = mkInstantTask ("CSV file import", ("Import of CSV file " +++ filename)) (fileTask filename readCSVFile)
importCSVFile filename = mkInstantTask ("CSV file import", ("Import of CSV file " +++ filename)) eval
where
eval taskNr iworld = fileTask filename readCSVFile iworld
importCSVFileWith :: !Char !Char !Char !FilePath -> Task [[String]]
importCSVFileWith delimitChar quoteChar escapeChar filename = mkInstantTask ("CSV file import", ("Import of CSV file " +++ filename)) (fileTask filename (readCSVFileWith delimitChar quoteChar escapeChar))
importCSVFileWith delimitChar quoteChar escapeChar filename = mkInstantTask ("CSV file import", ("Import of CSV file " +++ filename)) eval
where
eval taskNr iworld = fileTask filename (readCSVFileWith delimitChar quoteChar escapeChar) iworld
importJSONFile :: !FilePath -> Task a | JSONDecode{|*|} a
importJSONFile filename = mkInstantTask ("JSON file import", ("Import of JSON file " +++ filename)) (readJSON filename fromJSON)
importJSONFile filename = mkInstantTask ("JSON file import", ("Import of JSON file " +++ filename)) eval
where
eval taskNr iworld = readJSON filename fromJSON iworld
importJSONFileWith :: !(JSONNode -> Maybe a) !FilePath -> Task a
importJSONFileWith parsefun filename = mkInstantTask ("JSON file import", ("Import of JSON file " +++ filename)) (readJSON filename parsefun)
fileTask filename f tst=:{TSt|iworld=iworld=:{IWorld|world}}
importJSONFileWith parsefun filename = mkInstantTask ("JSON file import", ("Import of JSON file " +++ filename)) eval
where
eval taskNr iworld = readJSON filename parsefun iworld
fileTask filename f iworld=:{IWorld|world}
# (ok,file,world) = fopen filename FReadData world
| not ok = (openException filename,{TSt|tst & iworld={IWorld|iworld & world = world}})
| not ok = (openException filename,{IWorld|iworld & world = world})
# (res,file) = f file
# (ok,world) = fclose file world
| not ok = (closeException filename,{TSt|tst & iworld={IWorld|iworld & world = world}})
= (TaskFinished res, {TSt|tst & iworld={IWorld|iworld & world = world}})
| not ok = (closeException filename,{IWorld|iworld & world = world})
= (TaskFinished res, {IWorld|iworld & world = world})
readAll file
# (chunk,file) = freads file CHUNK_SIZE
......@@ -38,26 +51,26 @@ readAll file
# (rest,file) = readAll file
= (chunk +++ rest,file)
readJSON filename parsefun tst=:{TSt|iworld=iworld=:{IWorld|world}}
readJSON filename parsefun iworld=:{IWorld|world}
# (ok,file,world) = fopen filename FReadData world
| not ok = (openException filename,{TSt|tst & iworld={IWorld|iworld & world = world}})
| not ok = (openException filename,{IWorld|iworld & world = world})
# (content,file) = readAll file
# (ok,world) = fclose file world
| not ok = (closeException filename,{TSt|tst & iworld={IWorld|iworld & world = world}})
| not ok = (closeException filename,{IWorld|iworld & world = world})
= case (parsefun (fromString content)) of
Just a = (TaskFinished a, {TSt|tst & iworld={IWorld|iworld & world = world}})
Nothing = (parseException filename, {TSt|tst & iworld={IWorld|iworld & world = world}})
Just a = (TaskFinished a, {IWorld|iworld & world = world})
Nothing = (parseException filename, {IWorld|iworld & world = world})
readDocument filename tst=:{TSt|iworld=iworld=:{IWorld|world}}
readDocument filename iworld=:{IWorld|world}
# (ok,file,world) = fopen filename FReadData world
| not ok = (openException filename,{TSt|tst & iworld={IWorld|iworld & world = world}})
| not ok = (openException filename,{IWorld|iworld & world = world})
# (content,file) = readAll file
# (ok,world) = fclose file world
| not ok = (closeException filename,{TSt|tst & iworld={IWorld|iworld & world = world}})
| not ok = (closeException filename,{IWorld|iworld & world = world})
# name = dropDirectory filename
# mime = extensionToMimeType (takeExtension name)
# (document,tst) = createDocument name mime content {TSt|tst & iworld={IWorld|iworld & world = world}}
= (TaskFinished document, tst)
# (document,iworld) = createDocument name mime content {IWorld|iworld & world = world}
= (TaskFinished document, iworld)
openException s = taskException (FileException s CannotOpen)
closeException s = taskException (FileException s CannotClose)
......
......@@ -7,8 +7,9 @@ from Time import :: Timestamp
from TuningCombinators import :: Tag
from Shared import :: Shared, :: ReadOnlyShared, :: SymmetricShared
from ProcessDB import :: Process
import Task, ProcessDBTasks
import Task
import iTaskClass
derive class iTask ParallelTaskInfo
derive JSONEncode TaskContainer
derive JSONDecode TaskContainer
......@@ -48,7 +49,7 @@ derive gEq TaskContainer
* @param The list of tasks to run in parallel, each task is given a view on the status of all tasks in the set
* @return The resulting value
*/
parallel :: !d !s !(ResultFun s a) ![TaskContainer s] -> Task a | iTask s & iTask a & descr d
parallel :: !d !s (ResultFun s a) ![TaskContainer s] -> Task a | iTask s & iTask a & descr d
:: ResultFun s a :== TerminationStatus s -> a //ResultFun is called when the parallel task is stopped
//either because all tasks completed, or the set was stopped by a task
......@@ -71,7 +72,6 @@ parallel :: !d !s !(ResultFun s a) ![TaskContainer s] -> Task a | iTask s & iTas
| AppendTask !(TaskContainer s) // append and additional task to be run in parallel as well
| RemoveTask !TaskIndex // remove the task with indicated index from the set
| UpdateProperties !TaskIndex !ManagerProperties // update the properties of a task
| FocusTask !TaskIndex // set the window focus of indicated ordinary or control task
:: TaskIndex :== Int
......@@ -99,17 +99,3 @@ spawnProcess :: !Bool !ManagerProperties !ActionMenu !(Task a) -> Task ProcessId
* @return Void
*/
killProcess :: !ProcessId -> Task Void
/**
* Spawn a process at regular times
*
* @param A function that computes the next time a new instance to be spawned
* @param The task to spawn as process
*
* @return A reference to a control memory this contains a schedulerstate to control the scheduler and a list of active processes.
*/
scheduledSpawn :: !(DateTime -> DateTime) !(Task a) -> Task (ReadOnlyShared (!SchedulerState,![ProcessId])) | iTask a
:: SchedulerState = SSActive //Keep monitoring time and spawn new tasks
| SSFinish //Let the already running tasks finish, but don't start new ones anymore
| SSCancel //Stop immediately, cancel all active tasks.
This diff is collapsed.
......@@ -7,9 +7,9 @@ import iTaskClass
from Error import ::MaybeError(..)
from OSError import ::MaybeOSError, ::OSError, ::OSErrorCode, ::OSErrorMessage
from Shared import :: SymmetricShared, :: Shared
from Task import :: Task
from TSt import ::ChangeLifeTime, :: ChangeDyn
from Task import :: Task, ::ChangeLifeTime, :: ChangeDyn
:: SharedStoreId :== String
/**
* Lifts a value to the task domain. The return_V task finishes immediately and yields its parameter
......@@ -20,8 +20,6 @@ from TSt import ::ChangeLifeTime, :: ChangeDyn
*/
return :: !a -> Task a | iTask a
:: SharedStoreId :== String
/**
* Creates a reference to a store identified by a string identifier.
* If no data is store the default value given as second argument is given as result.
......@@ -140,4 +138,8 @@ accWorld :: !(*World -> *(!a,!*World)) -> Task a | iTask a
*/
accWorldError :: !(*World -> (!MaybeError e a, !*World)) !(e -> err) -> Task a | iTask a & TC, toString err
accWorldOSError :: !(*World -> (!MaybeOSError a, !*World)) -> Task a | iTask a
\ No newline at end of file
accWorldOSError :: !(*World -> (!MaybeOSError a, !*World)) -> Task a | iTask a
appIWorld :: !(*IWorld -> *IWorld) -> Task Void
accIWorld :: !(*IWorld -> *(!a,!*IWorld)) -> Task a | iTask a
implementation module CoreTasks
import TSt
import StdList, StdBool, StdInt, StdTuple, Util, HtmlUtil, Error, StdMisc, OSError
import iTaskClass, Task
import StdList, StdBool, StdInt, StdTuple,StdMisc, Util, HtmlUtil, Time, Error, OSError, Map
import iTaskClass, Task, TaskContext
from Shared import ::Shared(..), :: SymmetricShared, :: SharedGetTimestamp, :: SharedWrite, :: SharedRead
from Shared import qualified readShared, writeShared, isSharedChanged
from StdFunc import o
from StdFunc import o, id
from iTasks import dynamicJSONEncode, dynamicJSONDecode
from ExceptionCombinators import :: SharedException(..), instance toString SharedException, :: OSException(..), instance toString OSException
from WorkflowDB import qualified class WorkflowDB(..), instance WorkflowDB TSt
from WorkflowDB import qualified class WorkflowDB(..), instance WorkflowDB IWorld
VIEWS_STORE :== "views"
LOCAL_STORE :== "local"
......@@ -25,7 +24,7 @@ JSONDecode{|InteractionPart|} _ _ = (Nothing,[])
derive bimap Maybe,(,)
return :: !a -> (Task a) | iTask a
return a = mkInstantTask ("return", "Return a value") (\tst -> (TaskFinished a,tst))
return a = mkInstantTask ("return", "Return a value") (\_ iworld -> (TaskFinished a,iworld))
sharedStore :: !SharedStoreId !a -> SymmetricShared a | JSONEncode{|*|}, JSONDecode{|*|}, TC a
sharedStore storeId defaultV = Shared
......@@ -43,168 +42,184 @@ where
write v iworld = (Ok Void,storeValue storeId v iworld)
get :: !(Shared a w) -> Task a | iTask a
get shared
= mkInstantTask ("Read shared", "Reads a shared value") (accIWorldTSt readShared`)
get shared = mkInstantTask ("Read shared", "Reads a shared value") eval
where
readShared` iworld
eval taskNr iworld
# (val,iworld) = 'Shared'.readShared shared iworld
# res = case val of
Ok val = TaskFinished val
Error e = taskException (SharedException e)
= (res,iworld)
= (res, iworld)
//TODO: Mark (smartly) that a particular share has been updated
set :: !(Shared r a) !a -> Task a | iTask a
set shared val
= mkInstantTask ("Write shared", "Writes a shared value") writeShared`
set shared val = mkInstantTask ("Write shared", "Writes a shared value") eval
where
writeShared` tst
// set shared changed flag
# tst = {tst & sharedChanged = True}
# (res,tst) = accIWorldTSt ('Shared'.writeShared shared val) tst
eval taskNr iworld
# (res,iworld) ='Shared'.writeShared shared val iworld
# res = case res of
Ok _ = TaskFinished val
Error e = taskException (SharedException e)
= (res,tst)
= (res, iworld)
//TODO: Mark (smartly) that a particular share has been updated
update :: !(r -> w) !(Shared r w) -> Task w | iTask r & iTask w
update f shared
= mkInstantTask ("Update shared", "Updates a shared value") (\tst -> accIWorldTSt updateShared` {tst & sharedChanged = True})
update f shared = mkInstantTask ("Update shared", "Updates a shared value") eval
where
updateShared` iworld
eval taskNr iworld
# (val,iworld) = 'Shared'.readShared shared iworld
| isError val = (taskException (SharedException (fromError val)),iworld)
| isError val = (taskException (SharedException (fromError val)), iworld)
# val = f (fromOk val)
# (wres,iworld) = 'Shared'.writeShared shared val iworld
| isError wres = (taskException (SharedException (fromError wres)),iworld)
= (TaskFinished val,iworld)
| isError wres = (taskException (SharedException (fromError wres)), iworld)
= (TaskFinished val, iworld)
interact :: !d !(l r Bool -> [InteractionPart (!l,!