Skip to content

GitLab

Commit 570796b7 authored by Mart Lubbers's avatar Mart Lubbers
Browse files

change to rewriting semantics 

remove tonic
update step
update many basic tasks

parallel and interact are still stubs
parent dd12dc2d
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 909 additions and 4794 deletions
Libraries/iTasks/Engine.icl
View file @ 570796b7
......@@ -25,6 +25,7 @@ import iTasks.WF.Combinators.Common
import iTasks.WF.Definition
import iTasks.WF.Tasks.SDS
import iTasks.WF.Tasks.System
import iTasks.WF.Derives
import qualified Data.Map as DM
......
Libraries/iTasks/Extensions/Admin/TonicAdmin.dcl deleted 100644 → 0
View file @ dd12dc2d
definition module iTasks.Extensions.Admin.TonicAdmin
import iTasks
from iTasks.Internal.Tonic.Images import :: TaskAppRenderer, :: ModelTy, :: ClickMeta, :: TonicImageState, :: ActionState, :: TClickAction
from iTasks.Internal.Tonic.Types import :: AllBlueprints, :: TonicModule, :: TonicFunc, :: FuncName, :: ModuleName, :: NavStack, :: BlueprintIdent, :: ExprId
from Graphics.Scalable.Image import :: TagSource, :: TagRef, :: Image, :: ImageTag
from Graphics.Scalable.Internal.Image` import :: Image`
import iTasks.SDS.Definition
tonicDashboard :: [TaskAppRenderer] -> Task ()
tonic :: Task ()
tonicStaticBrowser :: [TaskAppRenderer] -> Task ()
tonicBrowseWithModule :: AllBlueprints [TaskAppRenderer] (Shared sds NavStack) TonicModule -> Task () | RWShared sds
tonicStaticWorkflow :: [TaskAppRenderer] -> Workflow
tonicDynamicBrowser :: [TaskAppRenderer] -> Task ()
tonicDynamicWorkflow :: [TaskAppRenderer] -> Workflow
viewStaticTask :: !AllBlueprints ![TaskAppRenderer] !(Shared sds NavStack) !BlueprintIdent !TonicModule !TonicFunc !Int !Bool -> Task () | RWShared sds
Libraries/iTasks/Extensions/Admin/TonicAdmin.icl deleted 100644 → 0
View file @ dd12dc2d
This diff is collapsed.
Libraries/iTasks/Internal/AsyncSDS.icl
View file @ 570796b7
......@@ -12,6 +12,8 @@ import iTasks.Internal.SDS
import iTasks.Internal.Task
import iTasks.SDS.Definition
import iTasks.WF.Tasks.IO
import iTasks.WF.Derives
import iTasks.Internal.Serialization
import iTasks.Extensions.Distributed._Formatter
......
Libraries/iTasks/Internal/Distributed/Symbols.icl
View file @ 570796b7
......@@ -38,7 +38,11 @@ readSymbols shareValue = fst (copy_from_string (base64Decode shareValue))
withSymbols :: ({#Symbol} -> Task a) -> Task a | iTask a
withSymbols taskfun = Task eval
where
eval event evalOpts state iworld
# (val, iworld) = read symbolsShare EmptyContext iworld
= case val of
Ok (ReadingDone val) = let (Task eval`) = taskfun (fst (copy_from_string (base64Decode val))) in eval` event evalOpts state iworld
eval event evalOpts iworld
# (mval, iworld) = read symbolsShare EmptyContext iworld
= case mval of
(Error e) = (ExceptionResult e, iworld)
(Ok (ReadingDone val))
# (Task task) = taskfun (readSymbols val)
= task event evalOpts iworld
(Ok _) = (ExceptionResult (exception "Async symbol share unsupported"), iworld)
Libraries/iTasks/Internal/EngineTasks.icl
View file @ 570796b7
......@@ -19,9 +19,9 @@ from Data.Map import newMap, member
everyTick :: (*IWorld -> *(!MaybeError TaskException (), !*IWorld)) -> Task ()
everyTick f = Task eval
where
eval DestroyEvent evalOpts tree iworld
eval DestroyEvent evalOpts iworld
= (DestroyedResult, iworld)
eval event evalOpts tree=:(TCInit taskId ts) iworld
eval event {TaskEvalOpts|taskId,ts} iworld
# (merr, iworld) = f iworld
| isError merr = (ExceptionResult (fromError merr), iworld)
# (merr, iworld) = readRegister taskId tick iworld
......@@ -30,7 +30,7 @@ where
NoValue
{TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes=newMap}
NoChange
(TCInit taskId ts)
(Task eval)
, iworld)
//When we run the built-in HTTP server we need to do active garbage collection of instances that were created for sessions
......
Libraries/iTasks/Internal/IWorld.icl
View file @ 570796b7
implementation module iTasks.Internal.IWorld
from System.FilePath import :: FilePath
from Data.Map import :: Map
from Data.Maybe import :: Maybe
from Data.Error import :: MaybeError(..), :: MaybeErrorString(..)
from System.Time import :: Timestamp, time, :: Timespec
from Text.GenJSON import :: JSONNode
from iTasks.WF.Definition import :: TaskId, :: InstanceNo, :: TaskNo
from iTasks.WF.Combinators.Core import :: TaskListItem, :: ParallelTaskType
from iTasks.Extensions.DateTime import :: Time, :: Date, :: DateTime, toTime, toDate
from iTasks.Internal.TaskEval import :: TaskTime
from iTasks.Engine import :: EngineOptions(..)
import Data.Integer
import iTasks.SDS.Combinators.Common
import StdEnv
from StdFunc import seqList, :: St
from StdFile import class FileSystem(..), class FileEnv(..), :: Files
from StdFile import instance FileSystem World, instance FileEnv World
from StdFunc import const, o, seqList, :: St
from StdMisc import abort
from StdOrdList import sortBy
from ABC.Interpreter import prepare_prelinked_interpretation
from ABC.Interpreter import prepare_prelinked_interpretation, :: PrelinkedInterpretationEnvironment
from TCPIP import :: TCP_Listener, :: TCP_Listener_, :: TCP_RChannel_, :: TCP_SChannel_, :: TCP_DuplexChannel, :: DuplexChannel, :: IPAddress, :: ByteSeq
import System.Time, StdList, Text.Encodings.Base64, _SystemArray, StdBool, StdTuple, Text.GenJSON, Data.Error, Math.Random
import System.Signal
import iTasks.Internal.TaskStore, iTasks.Internal.Util
import iTasks.Internal.Serialization
import iTasks.Internal.SDS
import Data.Func
import Data.Integer
from Data.Map import :: Map
import qualified Data.Map as DM
import Data.Func, Data.Tuple, Data.List, iTasks.SDS.Definition
import System.Time, System.CommandLine, System.Environment, System.OSError, System.File, System.FilePath, System.Directory
from Data.Set import :: Set, newSet
from iTasks.SDS.Definition import :: SDSParallel
from iTasks.SDS.Combinators.Common import toReadOnly
import Data.Maybe
import Math.Random
import System.CommandLine
import System.Directory
import System.File
import System.FilePath
import System.Signal
from ABC.Interpreter import :: PrelinkedInterpretationEnvironment
import iTasks.Engine
import iTasks.Extensions.DateTime
import iTasks.Internal.Task
import iTasks.Internal.TaskEval
import iTasks.Internal.Util
import iTasks.SDS.Combinators.Common
import iTasks.WF.Definition
import iTasks.WF.Derives
createIWorld :: !EngineOptions !*World -> Either (!String, !*World) *IWorld
createIWorld options world
......
Libraries/iTasks/Internal/SDSService.icl
View file @ 570796b7
......@@ -31,7 +31,7 @@ import Text
:: SDSEvaluations :== Map ConnectionId (Bool, String, String)
sdsServiceTask :: Int -> Task ()
sdsServiceTask port = Task eval
sdsServiceTask port = Task (wrapOldStyleTask eval)
where
share :: SimpleSDSLens SDSEvaluations
share = sharedStore "sdsServiceTaskShare" 'Map'.newMap
......@@ -42,10 +42,10 @@ where
# (mbError, iworld) = addListener taskId port True (wrapIWorldConnectionTask (handlers symbols taskId) share) iworld
| mbError=:(Error _) = showException "initialization" (fromError mbError) iworld
# iworld = iShow ["SDS server listening on " +++ toString port] iworld
= (ValueResult (Value () False) {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes='Map'.newMap} (ReplaceUI (ui UIEmpty)) (TCBasic taskId ts (DeferredJSONNode JSONNull) False), iworld)
= (ValueResult` (Value () False) {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes='Map'.newMap} (ReplaceUI (ui UIEmpty)) (TCBasic taskId ts (DeferredJSONNode JSONNull) False), iworld)
eval (RefreshEvent taskIds cause) evalOpts tree=:(TCBasic taskId ts data bla) iworld
| not ('Set'.member taskId taskIds) = (ValueResult (Value () False) {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes='Map'.newMap} NoChange (TCBasic taskId ts data bla), iworld)
| not ('Set'.member taskId taskIds) = (ValueResult` (Value () False) {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes='Map'.newMap} NoChange (TCBasic taskId ts data bla), iworld)
# (symbols, iworld) = case read symbolsShare EmptyContext iworld of
(Ok (ReadingDone symbols), iworld) = (readSymbols symbols, iworld)
# (readResult, iworld) = read share EmptyContext iworld
......@@ -55,11 +55,11 @@ where
| results=:(Error _) = showException "re-evaluating share values" (exception (fromError results)) iworld
# (writeResult, iworld) = write ('Map'.fromList (fromOk results)) share EmptyContext iworld
| writeResult=:(Error _) = showException "writing result share values" (fromError writeResult) iworld
= (ValueResult (Value () False) {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes='Map'.newMap} NoChange tree, iworld)
= (ValueResult` (Value () False) {TaskEvalInfo|lastEvent=ts,removedTasks=[],attributes='Map'.newMap} NoChange tree, iworld)
showException base taskException=:(_, str) iworld
# iworld = iShow ["SDSService exception during " +++ base +++ ": " +++ str] iworld
= (ExceptionResult taskException, iworld)
= (ExceptionResult` taskException, iworld)
handlers symbols taskId = {ConnectionHandlersIWorld|onConnect = onConnect
, onData = onData symbols taskId
......
Libraries/iTasks/Internal/Task.dcl
View file @ 570796b7
......@@ -4,7 +4,6 @@ definition module iTasks.Internal.Task
*/
import iTasks.WF.Definition
from iTasks.Internal.Tonic.AbsSyn import :: ExprId (..)
from iTasks.WF.Tasks.IO import :: ConnectionHandlers
from iTasks.Internal.TaskState import :: TaskTree
......@@ -48,3 +47,5 @@ wrapIWorldConnectionTask :: (ConnectionHandlersIWorld l r w) (sds () r w) -> Con
*/
mkInstantTask :: (TaskId *IWorld -> (!MaybeError (Dynamic,String) a,!*IWorld)) -> Task a | iTask a
wrapOldStyleTask :: (Event -> TaskEvalOpts -> TaskTree -> *IWorld -> *(TaskResult` a, *IWorld))
-> (Event -> TaskEvalOpts -> *IWorld -> *(TaskResult a, *IWorld)) | iTask a
Libraries/iTasks/Internal/Task.icl
View file @ 570796b7
......@@ -122,3 +122,21 @@ where
rep ResetEvent = ReplaceUI (ui UIEmpty)
rep _ = NoChange
wrapOldStyleTask :: (Event -> TaskEvalOpts -> TaskTree -> *IWorld -> *(TaskResult` a, *IWorld))
-> (Event -> TaskEvalOpts -> *IWorld -> *(TaskResult a, *IWorld)) | iTask a
wrapOldStyleTask eval = evalinit
where
//This first pass is required to get the taskid and the timestamp
evalinit event eo=:{TaskEvalOpts|taskId,ts} iworld
= evalactual (TCInit taskId ts) event eo iworld
//The actual evaluation
evalactual tree event eo=:{TaskEvalOpts|taskId,ts} iworld
# (res, iworld) = eval event eo tree iworld
# res = case res of
ValueResult` tv tei ui tree = ValueResult tv tei ui (Task (evalactual tree))
ExceptionResult` exc = ExceptionResult exc
DestroyedResult` = DestroyedResult
= (res, iworld)
Libraries/iTasks/Internal/TaskEval.dcl
View file @ 570796b7
......@@ -7,7 +7,6 @@ from iTasks.WF.Definition import :: Task, :: TaskResult, :: TaskExcept
from iTasks.WF.Combinators.Core import :: TaskListItem
from iTasks.Internal.IWorld import :: IWorld
import iTasks.Internal.SDS
from iTasks.Internal.Tonic import :: ExprId
from iTasks.Internal.TaskState import :: DeferredJSON
from Text.GenJSON import :: JSONNode
from Data.Maybe import :: Maybe
......@@ -20,24 +19,11 @@ from Data.CircularStack import :: CircularStack
//Additional options to pass down the tree when evaluating a task
:: TaskEvalOpts =
{ noUI :: Bool
, tonicOpts :: TonicOpts
, taskId :: TaskId
, ts :: TaskTime
}
:: TonicOpts =
{ inAssignNode :: Maybe ExprId
, inParallel :: Maybe TaskId
, captureParallel :: Bool
, currBlueprintModuleName :: String
, currBlueprintFuncName :: String
, currBlueprintTaskId :: TaskId
, currBlueprintExprId :: ExprId
, callTrace :: CircularStack TaskId
}
mkEvalOpts :: TaskEvalOpts
defaultTonicOpts :: TonicOpts
//Additional information passed up from the tree when evaluating a task
:: TaskEvalInfo =
......@@ -48,11 +34,6 @@ defaultTonicOpts :: TonicOpts
:: TaskTime :== Int
/**
* Extend the call trace with the current task number
*/
extendCallTrace :: !TaskId !TaskEvalOpts -> TaskEvalOpts
/**
* Get the next TaskId
*/
......
Libraries/iTasks/Internal/TaskEval.icl
View file @ 570796b7
......@@ -10,6 +10,7 @@ import iTasks.Internal.Util
import iTasks.Internal.EngineTasks
from iTasks.WF.Combinators.Core import :: SharedTaskList
import iTasks.WF.Derives
from iTasks.WF.Combinators.Core import :: ParallelTaskType(..), :: ParallelTask(..)
from Data.Map as DM import qualified newMap, fromList, toList, get, put, del
from Data.Queue import :: Queue (..)
......@@ -27,28 +28,10 @@ mkEvalOpts :: TaskEvalOpts
mkEvalOpts =
{ TaskEvalOpts
| noUI = False
, tonicOpts = defaultTonicOpts
, taskId = TaskId 0 0
, ts = 0
}
defaultTonicOpts :: TonicOpts
defaultTonicOpts = { TonicOpts
| inAssignNode = Nothing
, inParallel = Nothing
, captureParallel = False
, currBlueprintModuleName = ""
, currBlueprintFuncName = ""
, currBlueprintTaskId = TaskId 0 0
, currBlueprintExprId = []
, callTrace = 'DCS'.newStack 1024
}
extendCallTrace :: !TaskId !TaskEvalOpts -> TaskEvalOpts
extendCallTrace taskId repOpts=:{TaskEvalOpts|tonicOpts = {callTrace = xs}}
= case 'DCS'.peek xs of
Just topTaskId
| taskId == topTaskId = repOpts
_ = {repOpts & tonicOpts = {repOpts.tonicOpts & callTrace = 'DCS'.push taskId repOpts.tonicOpts.callTrace}}
getNextTaskId :: *IWorld -> (!TaskId,!*IWorld)
getNextTaskId iworld=:{current=current=:{TaskEvalState|taskInstance,nextTaskNo}}
= (TaskId taskInstance nextTaskNo, {IWorld|iworld & current = {TaskEvalState|current & nextTaskNo = nextTaskNo + 1}})
......@@ -80,7 +63,7 @@ where
| isError curReduct = exitWithException instanceNo ((\(Error (e,msg)) -> msg) curReduct) iworld
# curReduct = directResult (fromOk curReduct)
| curReduct =: Nothing = exitWithException instanceNo ("Task instance does not exist" <+++ instanceNo) iworld
# curReduct=:{TIReduct|task=Task eval,tree,nextTaskNo=curNextTaskNo,nextTaskTime,tasks,tonicRedOpts} = fromJust curReduct
# curReduct=:{TIReduct|task=(Task eval),nextTaskNo=curNextTaskNo,nextTaskTime,tasks} = fromJust curReduct
// Determine the task type (startup,session,local)
# (type,iworld) = determineInstanceType instanceNo iworld
// Determine the progress of the instance
......@@ -105,10 +88,10 @@ where
, nextTaskNo = curReduct.TIReduct.nextTaskNo
}}
//Apply task's eval function and take updated nextTaskId from iworld
# (newResult,iworld=:{current}) = eval event {mkEvalOpts & tonicOpts = tonicRedOpts} tree iworld
# tree = case newResult of
(ValueResult _ _ _ newTree) = newTree
_ = tree
# (newResult,iworld=:{current}) = eval event {mkEvalOpts & ts=curReduct.TIReduct.nextTaskTime, taskId = taskId} iworld
# newTask = case newResult of
(ValueResult _ _ _ newTask) = newTask
_ = Task eval
# destroyed = newResult =: DestroyedResult
//Reset necessary 'current' values in iworld
# iworld = {IWorld|iworld & current = {TaskEvalState|current & taskInstance = 0}}
......@@ -124,7 +107,7 @@ where
//Store or remove reduct
# (nextTaskNo,iworld) = getNextTaskNo iworld
# (_,iworld) =
(modify (maybe Nothing (\r -> if destroyed Nothing (Just {TIReduct|r & tree = tree, nextTaskNo = nextTaskNo, nextTaskTime = nextTaskTime + 1})))
(modify (maybe Nothing (\r -> if destroyed Nothing (Just {TIReduct|r & task = newTask, nextTaskNo = nextTaskNo, nextTaskTime = nextTaskTime + 1})))
(sdsFocus instanceNo taskInstanceReduct) EmptyContext iworld)
//FIXME: Don't write the full reduct (all parallel shares are triggered then!)
//Store or delete value
......
Libraries/iTasks/Internal/TaskServer.icl
View file @ 570796b7
......@@ -18,6 +18,7 @@ import iTasks.Internal.Util
import iTasks.SDS.Combinators.Common
import iTasks.SDS.Definition
import iTasks.WF.Definition
import iTasks.WF.Derives
//Helper type that holds the mainloop instances during a select call
//in these mainloop instances the unique listeners and read channels
......
Libraries/iTasks/Internal/TaskState.dcl
View file @ 570796b7
definition module iTasks.Internal.TaskState
from iTasks.Internal.TaskEval import :: TonicOpts, :: TaskTime
from iTasks.Internal.TaskEval import :: TaskTime
from iTasks.WF.Definition import :: Task, :: TaskResult, :: TaskValue, :: TaskException, :: TaskNo, :: TaskId, :: TaskAttributes, :: Event
from iTasks.WF.Definition import :: InstanceNo, :: InstanceKey, :: InstanceProgress
......@@ -45,8 +45,6 @@ derive gDefault TIMeta
:: TIReduct =
{ task :: !Task DeferredJSON //Main task definition
, tree :: !TaskTree //Main task state
, tonicRedOpts :: !TonicOpts //Tonic data
, nextTaskNo :: !TaskNo //Local task number counter
, nextTaskTime :: !TaskTime //Local task time (incremented at every evaluation)
// TODO Remove from reduct!
......
Libraries/iTasks/Internal/TaskState.icl
View file @ 570796b7
......@@ -6,14 +6,14 @@ import iTasks.WF.Definition
from iTasks.WF.Combinators.Core import :: AttachmentStatus
from iTasks.Internal.Task import exception
from iTasks.Internal.TaskEval import :: TaskTime, :: TaskEvalInfo(..), :: TonicOpts(..)
from iTasks.Internal.Tonic.AbsSyn import :: ExprId (..)
from iTasks.Internal.TaskEval import :: TaskTime, :: TaskEvalInfo(..)
import iTasks.Internal.Serialization, iTasks.Internal.Generic.Visualization
import Data.CircularStack
import Data.Error, Data.Either
import iTasks.WF.Derives
derive JSONEncode TIMeta, TIType, TIValue, TIReduct, TaskTree, ParallelTaskState, ParallelTaskChange, TaskResult, TaskEvalInfo, TonicOpts, CircularStack, AsyncAction
derive JSONDecode TIMeta, TIType, TIValue, TIReduct, TaskTree, ParallelTaskState, ParallelTaskChange, TaskResult, TaskEvalInfo, TonicOpts, CircularStack, AsyncAction
derive JSONEncode TIMeta, TIType, TIValue, TIReduct, TaskTree, ParallelTaskState, ParallelTaskChange, TaskResult, TaskEvalInfo, CircularStack, AsyncAction
derive JSONDecode TIMeta, TIType, TIValue, TIReduct, TaskTree, ParallelTaskState, ParallelTaskChange, TaskResult, TaskEvalInfo, CircularStack, AsyncAction
derive gDefault TIMeta, InstanceProgress, TIType, TaskId, ValueStatus
......
Libraries/iTasks/Internal/TaskStore.icl
View file @ 570796b7
......@@ -20,6 +20,7 @@ import iTasks.Internal.DynamicUtil
import iTasks.Internal.SDSService
import iTasks.WF.Combinators.Core
import iTasks.WF.Combinators.Tune
import iTasks.WF.Derives
import iTasks.Extensions.Document
import qualified Data.Map as DM
......@@ -138,7 +139,7 @@ createClientTaskInstance task sessionId instanceNo iworld=:{options={appVersion}
# progress = {InstanceProgress|value=Unstable,instanceKey=Nothing,attachedTo=[],firstEvent=Nothing,lastEvent=Nothing}
# constants = {InstanceConstants|type=SessionInstance,build=appVersion,issuedAt=clock}
= 'SDS'.write (instanceNo, Just constants,Just progress,Just defaultValue) (sdsFocus instanceNo taskInstance) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (Just (createReduct defaultTonicOpts instanceNo task taskTime)) (sdsFocus instanceNo taskInstanceReduct) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (Just (createReduct instanceNo task taskTime)) (sdsFocus instanceNo taskInstanceReduct) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (Just (TIValue NoValue)) (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> (Ok (TaskId instanceNo 0), iworld)
......@@ -151,7 +152,7 @@ createSessionTaskInstance task attributes iworld=:{options={appVersion,autoLayou
# progress = {InstanceProgress|value=Unstable,instanceKey=Just instanceKey,attachedTo=[],firstEvent=Nothing,lastEvent=Nothing}
# constants = {InstanceConstants|type=SessionInstance,build=appVersion,issuedAt=clock}
= 'SDS'.write (instanceNo, Just constants,Just progress,Just attributes) (sdsFocus instanceNo taskInstance) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (Just (createReduct defaultTonicOpts instanceNo task taskTime)) (sdsFocus instanceNo taskInstanceReduct) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (Just (createReduct instanceNo task taskTime)) (sdsFocus instanceNo taskInstanceReduct) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (Just (TIValue NoValue)) (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> (Ok (instanceNo,instanceKey), iworld)
......@@ -161,7 +162,7 @@ createStartupTaskInstance task attributes iworld=:{options={appVersion,autoLayou
# progress = {InstanceProgress|value=Unstable,instanceKey=Nothing,attachedTo=[],firstEvent=Nothing,lastEvent=Nothing}
# constants = {InstanceConstants|type=StartupInstance,build=appVersion,issuedAt=clock}
= 'SDS'.write (instanceNo, Just constants,Just progress,Just attributes) (sdsFocus instanceNo taskInstance) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (Just (createReduct defaultTonicOpts instanceNo task taskTime)) (sdsFocus instanceNo taskInstanceReduct) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (Just (createReduct instanceNo task taskTime)) (sdsFocus instanceNo taskInstanceReduct) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (Just (TIValue NoValue)) (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> (Ok instanceNo, queueEvent instanceNo ResetEvent iworld)
......@@ -177,36 +178,34 @@ createDetachedTaskInstance task isTopLevel evalOpts instanceNo attributes listId
# progress = {InstanceProgress|value=Unstable,instanceKey=Just instanceKey,attachedTo=[],firstEvent=Nothing,lastEvent=Nothing}
# constants = {InstanceConstants|type=PersistentInstance mbListId,build=appVersion,issuedAt=clock}
= 'SDS'.write (instanceNo,Just constants,Just progress,Just attributes) (sdsFocus instanceNo taskInstance) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (Just (createReduct (if isTopLevel defaultTonicOpts evalOpts.tonicOpts) instanceNo task taskTime)) (sdsFocus instanceNo taskInstanceReduct) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (Just (createReduct instanceNo task taskTime)) (sdsFocus instanceNo taskInstanceReduct) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (Just (TIValue NoValue)) (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> ( Ok (TaskId instanceNo 0)
, if refreshImmediate
(queueEvent instanceNo ResetEvent iworld)
iworld)
createReduct :: !TonicOpts !InstanceNo !(Task a) !TaskTime -> TIReduct | iTask a
createReduct tonicOpts instanceNo task taskTime
createReduct :: !InstanceNo !(Task a) !TaskTime -> TIReduct | iTask a
createReduct instanceNo task taskTime
= { TIReduct
| task = toJSONTask task
, tree = TCInit (TaskId instanceNo 0) 1
, nextTaskNo = 1
, nextTaskTime = 1
, tasks = 'DM'.newMap
, tonicRedOpts = tonicOpts
}
where
toJSONTask (Task eval) = Task eval`
where
eval` event repOpts tree iworld = case eval event repOpts tree iworld of
(ValueResult val ts rep tree,iworld) = (ValueResult (fmap DeferredJSON val) ts rep tree, iworld)
(ExceptionResult e,iworld) = (ExceptionResult e,iworld)
(DestroyedResult,iworld) = (DestroyedResult,iworld)
toJSONTask :: (Task a) -> Task DeferredJSON | iTask a
toJSONTask (Task eval) = Task \event repOpts iworld->case eval event repOpts iworld of
(ExceptionResult e, iworld) = (ExceptionResult e, iworld)
(DestroyedResult, iworld) = (DestroyedResult, iworld)
(ValueResult val ts rep eval, iworld)
= (ValueResult (fmap DeferredJSON val) ts rep (toJSONTask eval), iworld)
replaceTaskInstance :: !InstanceNo !(Task a) *IWorld -> (!MaybeError TaskException (), !*IWorld) | iTask a
replaceTaskInstance instanceNo task iworld=:{options={appVersion},current={taskTime}}
# (meta, iworld) = 'SDS'.read (sdsFocus instanceNo taskInstance) 'SDS'.EmptyContext iworld
| isError meta = (liftError meta, iworld)
= 'SDS'.write (Just (createReduct defaultTonicOpts instanceNo task taskTime)) (sdsFocus instanceNo taskInstanceReduct) 'SDS'.EmptyContext iworld
= 'SDS'.write (Just (createReduct instanceNo task taskTime)) (sdsFocus instanceNo taskInstanceReduct) 'SDS'.EmptyContext iworld
`b` \iworld -> 'SDS'.write (Just (TIValue NoValue)) (sdsFocus instanceNo taskInstanceValue) 'SDS'.EmptyContext iworld
`b` \iworld -> let (_,Just constants,progress,attributes) ='SDS'.directResult (fromOk meta)
in 'SDS'.write (instanceNo,Just {InstanceConstants|constants & build=appVersion},progress,attributes) (sdsFocus instanceNo taskInstance) 'SDS'.EmptyContext iworld
......
Libraries/iTasks/Internal/Tonic.dcl deleted 100644 → 0
View file @ dd12dc2d
definition module iTasks.Internal.Tonic
from iTasks.Internal.IWorld import :: IWorld
from iTasks.Internal.Task import :: TaskEvalOpts, :: TaskResult
from iTasks.WF.Definition import :: Task, :: InstanceNo, class iTask
from iTasks.WF.Combinators.Tune import class tune
import iTasks.SDS.Definition
import iTasks.Internal.Tonic.AbsSyn
import iTasks.Internal.Tonic.Images
from System.Time import :: Timestamp
from Data.Map import :: Map
from Data.Set import :: Set
from Data.Either import :: Either
from Graphics.Scalable.Image import :: Image, :: TagSource, :: TagRef, :: ImageTag
from Graphics.Scalable.Internal.Image` import :: Image`
from iTasks.WF.Combinators.Overloaded import class TMonad, class TApplicative
import Data.Functor
from System.IO import :: IO
// For all of these classes goes that the iTask context restriction shouldn't
// be there. Ideally, we would have something like associated type families
// and constraintkinds to determine the context restriction per monad.
class TonicTopLevelBlueprint m | TonicBlueprintPart m where
tonicWrapBody :: !ModuleName !FuncName [(VarName, Int, m ())] [(ExprId, Int) ] (m a) -> m a | iTask a
tonicWrapArg :: !VarName !Int a -> m () | iTask a
class TonicBlueprintPart m | TMonad m where
tonicWrapApp :: !ModuleName !FuncName !ExprId [(ExprId, a -> Int)] (m a) -> m a | iTask a
instance TonicTopLevelBlueprint Task
instance TonicBlueprintPart Task
instance TonicTopLevelBlueprint Maybe
instance TonicBlueprintPart Maybe
instance TonicTopLevelBlueprint (Either e)
instance TonicBlueprintPart (Either e)
instance TonicTopLevelBlueprint IO
instance TonicBlueprintPart IO
instance TApplicative IO
instance TMonad IO
tonicExtWrapArg :: !VarName !Int !a -> m () | iTask a & TonicTopLevelBlueprint m
tonicExtWrapBody :: !ModuleName !FuncName