Commit 33af83af authored by Bas Lijnse's avatar Bas Lijnse

Merge branch 'master' into...

Merge branch 'master' into 292-open-action-in-basicapiexamples-opens-new-tab-when-task-is-already-open
parents 7a2c51ae 81322d4c
......@@ -2,6 +2,7 @@ definition module C2.Apps.ShipAdventure.Images
import C2.Framework.MapEnvironment
import C2.Apps.ShipAdventure.Types
from Graphics.Scalable.Image import :: Image, :: TagSource, :: Image`, :: ImageTag, :: TagRef
:: RenderMode
= PickRoomMode
......
......@@ -125,6 +125,8 @@ from C2.Apps.ShipAdventure.Images import :: RenderMode
:: CapabilityToDeviceKindMap :== Map Capability CapabilityExpr
derive gEditor IntMap
derive gText IntMap
derive class iTask PPDevice, PPDeviceType, CommandAim, Capability, CapabilityExpr
derive gLexOrd CableType, Capability
derive class iTask ObjectType, ActorStatus, Availability, ActorHealth, ActorEnergy, DeviceType, SectionStatus
......
......@@ -2,8 +2,6 @@ implementation module C2.Apps.ShipAdventure.Types
//import iTasks
import iTasks.Internal.Tonic
import iTasks.Extensions.Admin.TonicAdmin
from iTasks.Extensions.SVG.SVGEditor import :: SVGEditor(..), :: TagSource, fromSVGEditor
import qualified Data.List as DL
from Data.Func import mapSt
......@@ -14,6 +12,7 @@ import qualified Data.Map as DM
import Data.Map.GenJSON
import qualified Data.Set as DS
import Text.HTML
import Data.Functor
import C2.Framework.MapEnvironment
from C2.Framework.Logging import addLog
......@@ -484,3 +483,5 @@ isDetector HeatSensor = True
isDetector WaterSensor = True
isDetector _ = False
derive gEditor IntMap
derive gText IntMap
......@@ -5,6 +5,7 @@ import iTasks
from Data.IntMap.Strict import :: IntMap
import qualified Data.IntMap.Strict as DIS
import C2.Framework.Core
import C2.Apps.ShipAdventure.Types
import C2.Framework.Util
import C2.Framework.Entity
import C2.Framework.ContactPosition
......
......@@ -2,8 +2,6 @@ definition module C2.Framework.MapEnvironment
import iTasks
import iTasks.Internal.Tonic
import iTasks.Extensions.Admin.TonicAdmin
from Data.IntMap.Strict import :: IntMap
import qualified Data.Map as DM
from Data.Map import :: Map
......
......@@ -4,8 +4,6 @@ import StdArray
import iTasks
import iTasks.UI.Definition
import iTasks.Internal.Tonic
import iTasks.Extensions.Admin.TonicAdmin
import iTasks.Extensions.DateTime
import qualified Data.Map as DM
from Data.Map import :: Map, instance Functor (Map k)
......@@ -16,6 +14,7 @@ import qualified Data.Heap as DH
from Data.Heap import :: Heap
import Data.GenLexOrd
from C2.Framework.Logging import addLog
import C2.Apps.ShipAdventure.Types
import Data.List
import Data.Eq
import Data.Maybe
......
implementation module C2.Navy.Roles.Commander
import iTasks
import iTasks.Extensions.Admin.TonicAdmin, iTasks.Internal.Tonic
import Text, C2.Framework.Core, C2.Framework.Util, C2.Framework.Entity
import iTasks.Extensions.Document
from Data.IntMap.Strict import :: IntMap, instance Functor IntMap
......
......@@ -8,7 +8,9 @@ import qualified Data.Set as DS
from Data.IntMap.Strict import instance Functor IntMap
import qualified Data.IntMap.Strict as DIS
import C2.Apps.ShipAdventure.Editor
import C2.Apps.ShipAdventure.Types
import Data.Map.GenJSON
import Data.Functor
dOffRegisterEntity :: [User -> Task Entity]
dOffRegisterEntity = []
......
module main
import iTasks.Extensions.Admin.TonicAdmin, iTasks.Internal.Tonic
import iTasks
import qualified Data.List as DL
import C2.Navy.Roles.DOff, C2.Navy.Roles.Commander, C2.Navy.Roles.Suspect, C2.Navy.Roles.HVU, C2.Navy.Roles.Simulator, C2.Navy.Roles.Sailor
......@@ -15,7 +14,6 @@ Start world = doTasks
,onStartup importDemoUsersFlow
,onStartup (installWorkflows myTasks)
,onRequest "/" (ccMain registerTasks continuousTasks alwaysOnTasks optionalTasks <<@ (Title "C2 System"))
,onRequest "/tonic" (tonicDashboard [])
,onRequest "/debug" showDebug
,onRequest "/adventure" (loginAndManageWork "Adventure" Nothing Nothing False)
,onRequest "/alarm" (setSectionDetectors)
......
......@@ -77,6 +77,7 @@ instance Startable (a,b) | Startable a & Startable b
, tempDirPath :: FilePath // Location for temporary files used in tasks
, byteCodePath :: FilePath // Location of the application's bytecode
}
derive class iTask EngineOptions
/**
* Executes the task framework with a collection of startable task definitions.
......
......@@ -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
......
implementation module iTasks.Extensions.Admin.StoreAdmin
import iTasks
import qualified iTasks.Internal.Store
import qualified iTasks.Internal.Task
......
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
This diff is collapsed.
......@@ -73,7 +73,7 @@ doAuthenticatedWith :: !(Credentials -> Task (Maybe User)) (Task a) -> Task a |
doAuthenticatedWith verifyCredentials task
= Title "Log in" @>> Hint "Please enter your credentials" @>> enterInformation []
>>! verifyCredentials
>>= \mbUser -> case mbUser of
>>- \mbUser -> case mbUser of
Nothing = throw "Authentication failed"
Just user = workAs user task
......@@ -81,7 +81,7 @@ createUser :: !UserAccount -> Task StoredUserAccount
createUser account
= createStoredAccount >>~ \storedAccount ->
get (userAccount (identifyUserAccount storedAccount))
>>= \mbExisting -> case mbExisting of
>>- \mbExisting -> case mbExisting of
Nothing
= upd (\accounts -> accounts ++ [storedAccount]) userAccounts @ const storedAccount
_
......@@ -114,23 +114,23 @@ createUserFlow =
Title "Create user" @>> Hint "Enter user information" @>> enterInformation []
>>* [ OnAction ActionCancel (always (return ()))
, OnAction ActionOk (hasValue (\user ->
createUser user
>>| Title "User created" @>> viewInformation [] "Successfully added new user"
createUser user
>-| Title "User created" @>> viewInformation [] "Successfully added new user"
>>| return ()
))
))
]
updateUserFlow :: UserId -> Task StoredUserAccount
updateUserFlow userId
= get (userAccount userId)
>>= \mbAccount -> case mbAccount of
>>- \mbAccount -> case mbAccount of
(Just account)
= (Title ("Editing " +++ fromMaybe "Untitled" account.StoredUserAccount.title) @>> Hint "Please make your changes" @>> updateInformation [] account
>>* [ OnAction ActionCancel (always (return account))
, OnAction ActionOk (hasValue (\newAccount ->
set (Just newAccount) (userAccount userId)
>>= \storedAccount -> Title "User updated"
@>> viewInformation [ViewAs (\(Just {StoredUserAccount|title}) -> "Successfully updated " +++ fromMaybe "Untitled" title)] storedAccount
set (Just newAccount) (userAccount userId)
>>- \storedAccount -> Title "User updated"
@>> viewInformation [ViewAs (\(Just {StoredUserAccount|title}) -> "Successfully updated " +++ fromMaybe "Untitled" title)] storedAccount
>>| return newAccount
))
])
......@@ -152,9 +152,9 @@ changePasswordFlow userId =
where
updatePassword :: !StoredUserAccount !Password -> Task StoredUserAccount
updatePassword account password =
createStoredCredentials account.StoredUserAccount.credentials.StoredCredentials.username password >>= \creds ->
createStoredCredentials account.StoredUserAccount.credentials.StoredCredentials.username password >>- \creds ->
let account` = {StoredUserAccount| account & credentials = creds} in
set (Just account`) (userAccount userId) >>= \account`` ->
set (Just account`) (userAccount userId) >>- \account`` ->
Hint "Password updated" @>> viewInformation
[ ViewAs \(Just {StoredUserAccount|title}) ->
"Successfully changed password for " +++ fromMaybe "Untitled" title
......@@ -164,12 +164,12 @@ where
deleteUserFlow :: UserId -> Task StoredUserAccount
deleteUserFlow userId
= get (userAccount userId)
>>= \mbAccount -> case mbAccount of
>>- \mbAccount -> case mbAccount of
(Just account)
= Title "Delete user" @>> viewInformation [] ("Are you sure you want to delete " +++ accountTitle account +++ "? This cannot be undone.")
>>* [ OnAction ActionNo (always (return account))
, OnAction ActionYes (always (deleteUser userId
>>| Hint "User deleted" @>> viewInformation [ViewAs (\account -> "Successfully deleted " +++ accountTitle account +++ ".")] account
>-| Hint "User deleted" @>> viewInformation [ViewAs (\account -> "Successfully deleted " +++ accountTitle account +++ ".")] account
>>| return account
))
]
......@@ -180,9 +180,9 @@ importUserFileFlow = Hint "Not implemented" @>> viewInformation [] ()
exportUserFileFlow :: Task Document
exportUserFileFlow
= get userAccounts -&&- get applicationName
>>= \(list,app) ->
>>- \(list,app) ->
createCSVFile (app +++ "-users.csv") (map toRow list)
>>= \file ->
>>- \file ->
Title "Export users file" @>>
Hint "A CSV file containing the users of this application has been created for you to download." @>>
viewInformation [] file
......
......@@ -133,7 +133,7 @@ loginAndManageWork applicationName loginMessage welcomeMessage allowGuests
where
browse (Just {Credentials|username,password})
= authenticateUser username password
>>= \mbUser -> case mbUser of
>>- \mbUser -> case mbUser of
Just user = workAs user (manageWorkOfCurrentUser welcomeMessage)
Nothing = (Title "Login failed" @>> viewInformation [] "Your username or password is incorrect" >>| return ()) <<@ ApplyLayout frameCompact
browse Nothing
......@@ -144,11 +144,11 @@ where
html = DivTag [ClassAttr cssClass] [H1Tag [] [Text name]:maybe [] (\msg -> [msg]) welcomeMessage]
cssClass = "welcome-" +++ (toLowerCase $ replaceSubString " " "-" name)
layout = sequenceLayouts [layoutSubUIs (SelectByType UIAction) (setActionIcon ('DM'.fromList [("Login","login")])) ,frameCompact]
layout = sequenceLayouts [layoutSubUIs (SelectByType UIAction) (setActionIcon ('DM'.fromList [("Login","login")])), frameCompact]
manageWorkOfCurrentUser :: !(Maybe HtmlTag) -> Task ()
manageWorkOfCurrentUser welcomeMessage
= ((manageSession -||
= ((manageSession -||
(chooseWhatToDo welcomeMessage >&> withSelection
(viewInformation [] "Welcome!")
(\wf -> unwrapWorkflowTask wf.Workflow.task)
......@@ -269,20 +269,20 @@ where
startWorkflow :: !(SharedTaskList ()) !Workflow -> Task Workflow
startWorkflow list wf
= get currentUser -&&- get currentDateTime
>>= \(user,now) ->
appendTopLevelTask ('DM'.fromList [ ("title", toJSON (workflowTitle wf))
, ("catalogId", toJSON wf.Workflow.path)
, ("createdBy", toJSON (toUserConstraint user))
, ("createdAt", toJSON now)
, ("createdFor", toJSON (toUserConstraint user))
, ("priority", toJSON 5):userAttr user]) False (unwrapWorkflowTask wf.Workflow.task)
= get currentUser -&&- get currentDateTime
>>- \(user,now) ->
appendTopLevelTask ('DM'.fromList [ ("title", toJSON (workflowTitle wf))
, ("catalogId", toJSON wf.Workflow.path)
, ("createdBy", toJSON (toUserConstraint user))
, ("createdAt", toJSON now)
, ("createdFor", toJSON (toUserConstraint user))
, ("priority", toJSON 5):userAttr user]) False (unwrapWorkflowTask wf.Workflow.task)
>>= \procId ->
openTask list procId
@ const wf
openTask list procId
@ const wf
where
userAttr (AuthenticatedUser uid _ _) = [("user", JSONString uid)]
userAttr _ = []
userAttr (AuthenticatedUser uid _ _) = [("user", JSONString uid)]
userAttr _ = []
unwrapWorkflowTask (WorkflowTask t) = t @! ()
unwrapWorkflowTask (ParamWorkflowTask tf) = (Hint "Enter parameters" @>> enterInformation [] >>= tf @! ())
......@@ -315,7 +315,7 @@ where
>>| return ()
Just replacement
= replaceTask taskId (const (unwrapWorkflowTask replacement.Workflow.task)) topLevelTasks
>>| workOnTask taskId
>-| workOnTask taskId
//Look in the catalog for an entry that has the same path as
//the 'catalogId' that is stored in the incompatible task instance's properties
......
......@@ -58,19 +58,19 @@ addItem :: (Shared sds [c]) (c -> i) -> Task (Maybe i) | iTask i & iTask c & RWS
addItem collection identify
= enterInformation []
>>* [OnAction ActionCancel (always (return Nothing))
,OnAction ActionOk (hasValue (\item -> upd (\l -> l ++ [item]) collection >>| return (Just (identify item))))
,OnAction ActionOk (hasValue (\item -> upd (\l -> l ++ [item]) collection >-| return (Just (identify item))))
]
editItem :: (Shared sdsc [c]) ((Shared sdsc [c]) i -> Shared sdss (Maybe c)) (c -> i) i -> Task (Maybe i) | iTask c & iTask i & RWShared sdsc & RWShared sdss
editItem collection itemShare identify i
= get (itemShare collection i)
>>= \mbItem -> case mbItem of
>>- \mbItem -> case mbItem of
Nothing = (return Nothing)
(Just item) = updateInformation [] item
>>* [OnAction ActionCancel (always (return Nothing))
,OnAction ActionOk (hasValue (\item` ->
upd (\l -> [if (identify c === i) item` c \\ c <- l ]) collection
>>| return (Just i)
>-| return (Just i)
))
]
......@@ -78,7 +78,7 @@ deleteItem :: (Shared sdsc [c]) ((Shared sdsc [c]) i -> Shared sdss (Maybe c)) (
deleteItem collection itemShare identify i
= viewSharedInformation [] (itemShare collection i)
>>* [OnAction ActionNo (always (return Nothing))
,OnAction ActionYes (always (upd (\l -> [c \\ c <- l | identify c =!= i]) collection >>| return Nothing))
,OnAction ActionYes (always (upd (\l -> [c \\ c <- l | identify c =!= i]) collection >-| return Nothing))
]
......@@ -14,14 +14,14 @@ dbWriteAll :: ![a] -> Task [a] | iTask, DB a
dbWriteAll all = set all databaseId
dbModify :: ([a] -> [a]) -> Task [a] | iTask, DB a
dbModify f = dbReadAll >>= \items -> dbWriteAll (f items)
dbModify f = dbReadAll >>- \items -> dbWriteAll (f items)
// C(reate)R(ead)U(pdate)D(elete) operations:
dbCreateItem :: a -> Task a | iTask, DB a
dbCreateItem new
= get databaseId >>= \items ->
= get databaseId >>- \items ->
let newitem = (setItemId (newDBRef items) new) in
dbWriteAll (items ++ [newitem]) >>| return newitem
dbWriteAll (items ++ [newitem]) >-| return newitem
where
newDBRef :: [a] -> DBRef a | DB a
newDBRef [] = DBRef 1
......@@ -29,20 +29,20 @@ where
dbReadItem :: !(DBRef a) -> Task (Maybe a) | iTask, DB a
dbReadItem itemid
= get databaseId >>= \items ->
= get databaseId >>- \items ->
case filter (\item -> itemid == getItemId item) items of
[found:_] = return (Just found)
nothing = return Nothing
dbUpdateItem :: a -> Task a | iTask, DB a
dbUpdateItem new
= dbModify (replaceInList eqItemId new) >>| return new
= dbModify (replaceInList eqItemId new) >-| return new
dbDeleteItem :: !(DBRef a) -> Task (Maybe a) | iTask, DB a
dbDeleteItem itemid
= get databaseId >>= \items ->
= get databaseId >>- \items ->
let (match, nomatch) = partition (\i -> getItemId i == itemid) items in
dbWriteAll nomatch >>| case match of
dbWriteAll nomatch >-| case match of
[] = return Nothing
[item:_] = return (Just item)
......
......@@ -236,4 +236,3 @@ waitForTimer interval =
get currentTimestamp >>- \(Timestamp now) ->
timestampToLocalDateTime (Timestamp (now + interval)) >>- \endTime ->
waitForDateTime endTime
......@@ -18,7 +18,7 @@ import System.Directory, System.File
chooseFile :: [FilePath] [FileExtension] -> Task (FilePath,FilePath)
chooseFile paths extensions
= accWorld (getFilesInDir paths extensions)
>>= \tree -> enterChoice [Att (Title "Select File"), Att IconEdit] [ChooseWith (ChooseFromTree (\list _ -> toChoiceTree list))] (treeToList tree [])
>>- \tree -> enterChoice [Att (Title "Select File"), Att IconEdit] [ChooseWith (ChooseFromTree (\list _ -> toChoiceTree list))] (treeToList tree [])
@? adjust
where
toChoiceTree :: [(Int,(FilePath,[FilePath],FilePath))] -> [ChoiceTree FilePath]
......
......@@ -8,7 +8,7 @@ import qualified Text as T
takePicture :: Task (Maybe JPEGPicture)
takePicture
= catchAll (deviceRequest "takepicture" (\_ -> True)) (\_ -> return "")
>>= \result -> unpack ('T'.split " " result)
>>- \result -> unpack ('T'.split " " result)
where
unpack :: [String] -> Task (Maybe JPEGPicture)
unpack ["OK", image] = return (Just (JPEGPicture image))
......
......@@ -10,7 +10,7 @@ derive class iTask Coordinates
getLocation :: Task (Maybe Coordinates)
getLocation
= catchAll (deviceRequest "location" (\_ -> True)) (\_ -> return "")
>>= \result -> unpack ('T'.split " " result)
>>- \result -> unpack ('T'.split " " result)
where
unpack :: [String] -> Task (Maybe Coordinates)
unpack ["OK", lat, lon] = return (Just (LatLon (toReal lat) (toReal lon)))
......
......@@ -17,7 +17,7 @@ deviceRequest request close
, onDisconnect = onDisconnect
, onDestroy= \s->(Ok s, [])
}
>>= \{DeviceRequestState|result} -> return result
>>- \{DeviceRequestState|result} -> return result
where
onConnect :: ConnectionId String () -> (MaybeErrorString DeviceRequestState, Maybe (), [String], Bool)
onConnect connId host _
......
......@@ -75,39 +75,39 @@ where
changed :: Task Bool
changed
= get share
>>= \{AuthShare|clients} -> processClients clients
>>= \newClients -> upd (\s -> {AuthShare| s & clients = newClients}) share
>>| return True
>>- \{AuthShare|clients} -> processClients clients
>>- \newClients -> upd (\s -> {AuthShare| s & clients = newClients}) share
>-| return True
processClients :: [Communication] -> Task [Communication]
processClients [] = return []
processClients [c=:{Communication|id, requests}:rest]
= case requests of
[] = processClients rest >>= \rest -> return [c:rest]
data = processClients rest >>= \rest -> appendTopLevelTask ('DM'.fromList []) True (handleClient id data) >>| return [{Communication| c & requests = []}:rest]
[] = processClients rest >>- \rest -> return [c:rest]
data = processClients rest >>- \rest -> appendTopLevelTask ('DM'.fromList []) True (handleClient id data) >-| return [{Communication| c & requests = []}:rest]
handleClient :: Int [String] -> Task ()
handleClient id requests
= handleClientRequests id requests
>>= \responses -> upd (\s -> {AuthShare| s & clients = [if (clientid == id) ({Communication| c & responses=responses}) c \\ c=:{Communication|id=clientid} <- s.clients]}) share @! ()
>>- \responses -> upd (\s -> {AuthShare| s & clients = [if (clientid == id) ({Communication| c & responses=responses}) c \\ c=:{Communication|id=clientid} <- s.clients]}) share @! ()
handleClientRequests :: Int [String] -> Task [String]
handleClientRequests id []
= return []
handleClientRequests id [request:rest]
= handleClientRequest id ('T'.split " " request)
>>= \responses -> handleClientRequests id rest
>>= \other -> return (responses ++ other)
>>- \responses -> handleClientRequests id rest
>>- \other -> return (responses ++ other)
handleClientRequest :: Int [String] -> Task [String]
handleClientRequest id ["auth", username, password]
# username = base64Decode username
# password = base64Decode password
= authenticateUser (Username username) (Password password)
>>= \user -> return [(base64Encode (toString (toJSON user)))]
>>- \user -> return [(base64Encode (toString (toJSON user)))]
handleClientRequest id ["users"]
= get users
>>= \users -> return [(base64Encode (toString (toJSON users)))]
>>- \users -> return [(base64Encode (toString (toJSON users)))]
handleClientRequest _ _ = return []
remoteAuthenticateUser :: !Username !Password -> Task (Maybe User)
......@@ -121,7 +121,7 @@ remoteAuthenticateUser (Username username) (Password password)
getUsers :: String Int -> Task [User]
getUsers host port
= request host port "users"
>>= \users -> return (fromMaybe [] users)
>>- \users -> return (fromMaybe [] users)
request :: String Int String -> Task (Maybe a) | iTask a
request host port request
......
implementation module iTasks.Extensions.Distributed._Evaluation
from iTasks.WF.Definition import :: Task(..), :: Event(ResetEvent,DestroyEvent), :: TaskEvalOpts, class iTask, :: TaskResult(..), :: TaskException, :: TaskValue(..), :: Stability, :: InstanceNo, :: TaskId
from iTasks.Internal.TaskState import :: TaskTree(TCInit)
import iTasks.Internal.TaskEval
import iTasks.UI.Definition
from iTasks.WF.Combinators.Common import @!, @?, whileUnchanged, ||-
from iTasks.UI.Definition import :: UIType(UIEmpty)
from iTasks.Internal.IWorld import :: IWorld
import iTasks.SDS.Definition
import iTasks.Internal.SDS
from iTasks.SDS.Sources.System import currentTaskInstanceNo
from iTasks.UI.Definition import :: UIChange(..), :: UIChildChange(..), ui
from iTasks.Internal.Store import memoryStore, :: StoreName, :: StoreNamespace
from iTasks.WF.Tasks.SDS import get
from iTasks.SDS.Combinators.Common import sdsFocus
from iTasks.UI.Editor import :: Editor
from iTasks.UI.Editor.Generic import generic gEditor
from iTasks.Internal.Generic.Visualization import generic gText, :: TextFormat
from Text.GenJSON import generic JSONEncode, generic JSONDecode, :: JSONNode
from Data.GenEq import generic gEq
import Data.Error
from iTasks.WF.Combinators.Overloaded import class TMonad(..), instance TMonad Task, instance Functor Task, instance TApplicative Task, class TApplicative
from Data.Functor import class Functor
import iTasks.Internal.SDS
import iTasks.Internal.TaskEval
import iTasks.Internal.Util
from Data.Map import :: Map, newMap
from Data.Maybe import :: Maybe(..)
from Data.Error import :: MaybeError(..)
from StdFunc import const
from StdString import instance toString Int, instance +++ {#Char}
import StdOverloaded
import iTasks.SDS.Combinators.Common
import iTasks.SDS.Definition
import iTasks.SDS.Sources.Store
import iTasks.SDS.Sources.System
import iTasks.UI.Definition
import iTasks.WF.Combinators.Common
import iTasks.WF.Definition
import iTasks.WF.Tasks.SDS
evalRemoteTask :: (Task a) ((TaskValue a) -> Task ()) -> Task a | iTask a
evalRemoteTask task handleValue
= get currentTaskInstanceNo
>>= \taskid -> let share = taskValueShare taskid in
>>- \taskid -> let share = taskValueShare taskid in
(customEval share task ||- whileUnchanged share (changeTask handleValue))
where
changeTask :: ((TaskValue a) -> Task ()) (TaskValue a) -> Task a | iTask a
changeTask handleValue value=:(Value v True)
= handleValue value @! v
changeTask handleValue value
= handleValue value @? const NoValue
= handleValue value @? \_->NoValue
proxyTask :: (Shared sds (TaskValue a)) (*IWorld -> *IWorld) -> (Task a) | iTask a & RWShared sds
proxyTask value_share onDestroy = Task (eval value_share)
proxyTask value_share onDestroy = Task eval
where
eval :: (Shared sds (TaskValue a)) Event TaskEvalOpts TaskTree *IWorld -> *(!TaskResult a, !*IWorld) | iTask a & RWShared sds
eval value_share DestroyEvent repAs _ iworld
# iworld = onDestroy iworld
= (DestroyedResult,iworld)
eval value_share event evalOpts tree=:(TCInit taskId ts) iworld
# (val,iworld) = readRegister taskId value_share iworld