Skip to content

GitLab

I
iTasks-SDK
Commit 6f4f6f10 authored by Haye Böhm's avatar Haye Böhm
Browse files
Options

Remove MaybeSDSWrite construction 

It appears this whole change is unnecessary when a simple contract
is kept: Whenever you define a lens, the write lens should never yield
Nothing while there is a reducer for the lens.
parent 2d1922d9
Pipeline #13776 failed with stage
    in 1 minute and 35 seconds
    Expand all Hide whitespace changes
    Inline Side-by-side
    Showing with 299 additions and 328 deletions
    Examples/RemoteShareExamples/Makefile
    View file @ 6f4f6f10
    ......@@ -9,7 +9,7 @@ build: RemoteShareExamples $(foreach v,$(shell seq $(INSTANCES)),instances/$v/Re
    %.prj:
    cpm project $(basename $@) create
    cpm project $@ target iTasks-git
    cpm project $@ target iTasks-dist
    cpm project $@ set -h 2000M -s 20M -dynamics
    %/RemoteShareExamples: RemoteShareExamples
    ......
    Examples/RemoteShareExamples/RemoteShareExamples.icl
    View file @ 6f4f6f10
    ......@@ -27,8 +27,8 @@ parallelWithRightRemote = leftShare >*< (remoteShare rightShare {domain = "TEST"
    intShare = sharedStore "intShare" 15
    simpleShare = remoteShare intShare {domain="TEST", port=8080}
    projectedRemote = sdsProject (SDSLensRead (\r. Ok (r + 2))) (SDSLensWrite (\_ r. Ok (DoWrite (r - 2)))) (\_ ws. Ok (ws + 2)) simpleShare
    projectedLocal = sdsProject (SDSLensRead (\r. Ok (r + 2))) (SDSLensWrite (\_ r. Ok (DoWrite (r - 2)))) (\_ ws. Ok (ws + 2)) intShare
    projectedRemote = sdsProject (SDSLensRead (\r. Ok (r + 2))) (SDSLensWrite (\_ r. Ok (Just (r - 2)))) (Just \_ ws. Ok (ws + 2)) simpleShare
    projectedLocal = sdsProject (SDSLensRead (\r. Ok (r + 2))) (SDSLensWrite (\_ r. Ok (Just (r - 2)))) (Just \_ ws. Ok (ws + 2)) intShare
    selectShare = sdsSelect "testSelect" param (SDSNotifyConst (\_ _ _ _-> False)) (SDSNotifyConst (\_ _ _ _-> False))
    (remoteShare leftShare {domain="TEST", port=8080}) rightShare
    ......
    Libraries/iTasks/Engine.icl
    View file @ 6f4f6f10
    ......@@ -47,6 +47,7 @@ derive class iTask EngineOptions
    doTasks :: a !*World -> *World | Startable a
    doTasks startable world = doTasksWithOptions defaultEngineCLIOptions startable world
    import StdDebug,StdMisc
    doTasksWithOptions :: ([String] EngineOptions -> MaybeError [String] EngineOptions) a !*World -> *World | Startable a
    doTasksWithOptions initFun startable world
    # (cli,world) = getCommandLine world
    ......@@ -57,6 +58,8 @@ doTasksWithOptions initFun startable world
    # iworld = createIWorld options world
    # (res,iworld) = initJSCompilerState iworld
    | res =:(Error _) = show ["Fatal error: " +++ fromError res] (destroyIWorld iworld)
    # (symbolsResult, iworld) = initSymbolsShare options.distributed options.appName iworld
    | symbolsResult =: (Error _) = show ["Error reading symbols while required: " +++ fromError symbolsResult] (destroyIWorld iworld)
    # iworld = serve startupTasks (tcpTasks options.serverPort options.keepaliveTime)
    engineTasks (timeout options.timeout) iworld
    = destroyIWorld iworld
    ......@@ -65,6 +68,11 @@ where
    startupTasks = [t \\ StartupTask t <- toStartable startable]
    hasWebTasks = not (webTasks =: [])
    initSymbolsShare False _ iworld = (Ok (), iworld)
    initSymbolsShare True appName iworld = case storeSymbols appName iworld of
    (Error (e, s), iworld) = (Error s, iworld)
    (Ok symbols, iworld) = (Ok (), {iworld & world = show ["Read number of symbols: " +++ toString symbols] iworld.world})
    //Only run a webserver if there are tasks that are started through the web
    tcpTasks serverPort keepaliveTime
    | webTasks =: [] = []
    ......
    Libraries/iTasks/Extensions/Admin/TonicAdmin.icl
    View file @ 6f4f6f10
    ......@@ -289,8 +289,8 @@ where
    activeBlueprintInstances = editSharedChoiceWithSharedAs
    (Title "Active blueprint instances")
    [ChooseFromGrid customView]
    (mapRead (\(trt, q) -> filterActiveTasks q (flattenRTMap trt)) ((tonicSharedRT |*| queryShare) f))
    setTaskId selectedBlueprint f <<@ ArrangeWithSideBar 0 TopSide 175 True
    (mapRead (\(trt, q) -> filterActiveTasks q (flattenRTMap trt)) (tonicSharedRT |*| queryShare))
    setTaskId selectedBlueprint <<@ ArrangeWithSideBar 0 TopSide 175 True
    where
    setTaskId x = { click_origin_mbbpident = Nothing
    , click_origin_mbnodeId = Nothing
    ......@@ -300,9 +300,6 @@ where
    }
    }
    // TODO: Fix!!
    f p = undef
    flattenRTMap :: TonicRTMap -> [BlueprintInstance]
    flattenRTMap trt = 'DM'.elems ('DM'.foldrWithKey f 'DM'.newMap trt)
    where
    ......@@ -312,13 +309,13 @@ where
    g tid ((mn, fn), bpi) acc = 'DM'.put (tid, mn, fn) bpi acc
    blueprintViewer
    = whileUnchanged ((selectedBlueprint |*| navstack) id) (
    = whileUnchanged (selectedBlueprint |*| navstack) (
    \(bpmeta, ns) -> case bpmeta of
    Just meta=:{click_target_bpident = {bpident_compId = Just tid, bpident_moduleName, bpident_compName}}
    # focus = (sdsFocus (comp2TaskId tid, bpident_moduleName, bpident_compName) tonicInstances)
    = get focus
    >>~ \mbprnt -> get selectedDetail
    >>~ \selDetail -> whileUnchanged ((focus |*| dynamicDisplaySettings) f) (
    >>~ \selDetail -> whileUnchanged (focus |*| dynamicDisplaySettings) (
    \shareData ->
    case shareData of
    (Just bpinst, dynSett) -> viewInstance rs navstack dynSett bpinst selDetail meta
    ......
    Libraries/iTasks/Extensions/Admin/UserAdmin.icl
    View file @ 6f4f6f10
    ......@@ -16,7 +16,7 @@ userAccounts = sharedStore "UserAccounts" [ROOT_USER]
    users :: SDSLens () [User] ()
    users = mapReadWrite (\accounts -> [AuthenticatedUser (toString a.UserAccount.credentials.Credentials.username) a.UserAccount.roles a.UserAccount.title
    \\ a <- accounts]
    , \() accounts -> DoNotWrite accounts) (\_ _ -> Ok ()) userAccounts
    , \() _ -> Nothing) (Just \_ _ -> Ok ()) userAccounts
    usersWithRole :: !Role -> SDSLens () [User] ()
    usersWithRole role = mapRead (filter (hasRole role)) users
    ......@@ -25,7 +25,7 @@ where
    hasRole _ _ = False
    userAccount :: UserId -> SDSLens () (Maybe UserAccount) (Maybe UserAccount)
    userAccount userId = mapReadWrite (getAccount userId, \w r -> DoWrite (setAccount w r)) (\_ accounts -> Ok (getAccount userId accounts)) userAccounts
    userAccount userId = mapReadWrite (getAccount userId, \w r -> Just (setAccount w r)) (Just \_ accounts -> Ok (getAccount userId accounts)) userAccounts
    where
    getAccount :: UserId [UserAccount] -> Maybe UserAccount
    getAccount userId accounts = case [a \\ a <- accounts | identifyUserAccount a == userId] of
    ......
    Libraries/iTasks/Extensions/Admin/WorkflowAdmin.icl
    View file @ 6f4f6f10
    ......@@ -42,7 +42,7 @@ myWork = workList taskInstancesForCurrentUser
    allWork :: SDSLens () [(TaskId,WorklistRow)] ()
    allWork = workList allTaskInstances
    workList instances = mapRead projection ((instances |*| currentTopTask) f)
    workList instances = mapRead projection (instances |*| currentTopTask)
    where
    projection (instances,ownPid)
    = [(TaskId i.TaskInstance.instanceNo 0, mkRow i) \\ i <- instances | notSelf ownPid i && isActive i]
    ......@@ -64,7 +64,6 @@ where
    ,parentTask = if (listId == TaskId 0 0) Nothing (Just (toString listId))
    }
    f (l, r) = ((), ())
    // SHARES
    // Available workflows
    ......@@ -72,16 +71,16 @@ workflows :: SDSLens () [Workflow] [Workflow]
    workflows = sharedStore "Workflows" []
    workflowByPath :: !String -> SDSLens () Workflow Workflow
    workflowByPath path = mapReadWriteError (toPrj,fromPrj) (\_ flows -> toPrj flows) workflows
    workflowByPath path = mapReadWriteError (toPrj,fromPrj) (Just \_ flows -> toPrj flows) workflows
    where
    toPrj wfs = case [wf \\ wf <- wfs | wf.Workflow.path == path] of
    [wf:_] = Ok wf
    _ = Error (exception ("Workflow " +++ path +++ " could not be found"))
    fromPrj nwf wfs = Ok (DoWrite [if (wf.Workflow.path == path) nwf wf \\ wf <- wfs])
    fromPrj nwf wfs = Ok (Just [if (wf.Workflow.path == path) nwf wf \\ wf <- wfs])
    allowedWorkflows :: SDSLens () [Workflow] ()
    allowedWorkflows = mapRead filterAllowed ((workflows |*| currentUser) id)
    allowedWorkflows = mapRead filterAllowed (workflows |*| currentUser)
    where
    filterAllowed (workflows,user) = filter (isAllowedWorkflow user) workflows
    ......@@ -307,14 +306,12 @@ where
    //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
    findReplacement taskId
    = get (((sdsFocus taskId (taskListEntryMeta topLevelTasks)) |*| workflows) f)
    = get ((sdsFocus taskId (taskListEntryMeta topLevelTasks)) |*| workflows)
    @ \(taskListEntry,catalog) -> maybe Nothing (lookup catalog) ('DM'.get "catalogId" taskListEntry.TaskListItem.attributes)
    where
    lookup [wf=:{Workflow|path}:wfs] cid = if (path == cid) (Just wf) (lookup wfs cid)
    lookup [] _ = Nothing
    f ({TaskListItem|attributes}, r) = (attributes, r)
    appendOnce :: TaskId (Task a) (SharedTaskList a) -> Task () | iTask a
    appendOnce identity task slist
    = get (taskListMeta slist)
    ......
    Libraries/iTasks/Extensions/Distributed/Authentication.icl
    View file @ 6f4f6f10
    ......@@ -188,16 +188,15 @@ authServerInfoShare :: SDSLens () String String
    authServerInfoShare = sharedStore "authServer" ""
    currentDistributedUser :: SDSParallel () (User,Domain) (User,Domain)
    currentDistributedUser = sdsParallel "communicationDetailsByNo" param read (SDSWriteConst writel) (SDSWriteConst writer) reducer currentUser authServerInfoShare
    currentDistributedUser = sdsParallel "communicationDetailsByNo" param read (SDSWriteConst writel) (SDSWriteConst writer) currentUser authServerInfoShare
    where
    param p = (p,p)
    read (user,domain) = (user,Domain domain)
    writel _ (x,_) = Ok (DoWrite x)
    writer _ (_, Domain y) = Ok (DoWrite y)
    reducer p (u, d) = Ok (u, Domain d)
    writel _ (x,_) = Ok (Just x)
    writer _ (_, Domain y) = Ok (Just y)
    currentDomain :: SDSLens () Domain ()
    currentDomain = toReadOnly (mapRead (\domain -> Domain domain) authServerInfoShare) (\(Domain d). d)
    currentDomain = toReadOnly (mapRead (\domain -> Domain domain) authServerInfoShare)
    enterDomain :: Task Domain
    enterDomain
    ......
    Libraries/iTasks/Extensions/Distributed/_Evaluation.icl
    View file @ 6f4f6f10
    ......@@ -50,7 +50,7 @@ proxyTask value_share onDestroy = Task eval
    # (val,iworld) = readRegister taskId value_share iworld
    = case val of
    // TODO: Fix
    Ok (ReadResult val _) = (ValueResult val {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} (rep event) tree, iworld)
    //Ok (ReadResult val _) = (ValueResult val {TaskEvalInfo|lastEvent=ts,removedTasks=[],refreshSensitive=True} (rep event) tree, iworld)
    Error e = (ExceptionResult e,iworld)
    eval event repAs (TCDestroy _) iworld
    # iworld = onDestroy iworld
    ......
    Libraries/iTasks/Extensions/SQLDatabase.dcl
    View file @ 6f4f6f10
    ......@@ -34,7 +34,7 @@ derive class iTask SQLDatabaseDef, SQLDatabase, SQLValue, SQLTime, SQLDate, SQLT
    * @return The shared data source
    */
    sqlShare :: String (A.*cur: p *cur -> *(MaybeErrorString r,*cur) | SQLCursor cur)
    (A.*cur: p w *cur -> *(MaybeErrorString (), *cur) | SQLCursor cur) -> RWShared (SQLDatabaseDef,p) r w
    (A.*cur: p w *cur -> *(MaybeErrorString (), *cur) | SQLCursor cur) -> SDSSource (SQLDatabaseDef,p) r w
    ......@@ -59,16 +59,16 @@ sqlExecuteSelect :: SQLDatabaseDef SQLStatement ![SQLValue] -> Task [SQLRow]
    * Note: Although it is possible to do other queries than just selects,
    * this is a bad idea. You never know how many times the query will be executed
    */
    sqlSelectShare :: String SQLStatement ![SQLValue] -> ROShared SQLDatabaseDef [SQLRow]
    sqlSelectShare :: String SQLStatement ![SQLValue] -> SDSLens SQLDatabaseDef [SQLRow] ()
    /*
    * View the list of tables in a database
    */
    sqlTables :: ROShared SQLDatabaseDef [SQLTableName]
    sqlTables :: SDSSource SQLDatabaseDef [SQLTableName] ()
    /**
    * The structure of database table
    */
    sqlTableDefinition :: ROShared (SQLDatabaseDef,SQLTableName) SQLTable
    sqlTableDefinition :: SDSSource (SQLDatabaseDef,SQLTableName) SQLTable ()
    sqlExecuteCreateTable :: SQLDatabaseDef SQLTable -> Task ()
    sqlExecuteDropTable :: SQLDatabaseDef SQLTableName -> Task ()
    Libraries/iTasks/Extensions/SQLDatabase.icl
    View file @ 6f4f6f10
    ......@@ -11,7 +11,7 @@ import qualified Data.Map
    derive class iTask SQLDatabaseDef, SQLDatabase, SQLValue, SQLTime, SQLDate, SQLTable, SQLColumn, SQLColumnType
    sqlShare :: String (A.*cur: p *cur -> *(MaybeErrorString r,*cur) | SQLCursor cur)
    (A.*cur: p w *cur -> *(MaybeErrorString (), *cur) | SQLCursor cur) -> RWShared (SQLDatabaseDef,p) r w
    (A.*cur: p w *cur -> *(MaybeErrorString (), *cur) | SQLCursor cur) -> SDSSource (SQLDatabaseDef,p) r w
    sqlShare name readFun writeFun = createReadWriteSDS "SQLShares" name (readFunSQL readFun) (writeFunSQL writeFun)
    readFunSQL :: (A.*cur: p *cur -> *(MaybeErrorString r,*cur) | SQLCursor cur) (SQLDatabaseDef,p) *IWorld -> (!MaybeError TaskException r,!*IWorld)
    ......@@ -115,7 +115,7 @@ execDelete query values cur
    sqlExecuteSelect :: SQLDatabaseDef SQLStatement ![SQLValue] -> Task [SQLRow]
    sqlExecuteSelect db query values = sqlExecute db [] (execSelect query values)
    sqlSelectShare :: String SQLStatement ![SQLValue] -> ROShared SQLDatabaseDef [SQLRow]
    sqlSelectShare :: String SQLStatement ![SQLValue] -> SDSLens SQLDatabaseDef [SQLRow] ()
    sqlSelectShare name query values = sdsTranslate "sqlSelectShare" (\db -> (db,())) (createReadWriteSDS "SQLShares" name (readFunSQL readFun) write)
    where
    readFun () cur
    ......@@ -126,7 +126,7 @@ where
    = (Ok rows,cur)
    write _ () iworld = (Ok (const (const True)),iworld)
    sqlTables :: ROShared SQLDatabaseDef [SQLTableName]
    sqlTables :: SDSSource SQLDatabaseDef [SQLTableName] ()
    sqlTables = createReadOnlySDSError read
    where
    read (MySQLDatabase db) iworld
    ......@@ -149,7 +149,7 @@ where
    # iworld = cacheResource (SQLiteResource path (cur, con, cxt)) iworld
    = (Ok tables,iworld)
    sqlTableDefinition :: ROShared (SQLDatabaseDef,SQLTableName) SQLTable
    sqlTableDefinition :: SDSSource (SQLDatabaseDef,SQLTableName) SQLTable ()
    sqlTableDefinition = createReadOnlySDSError read
    where
    read (MySQLDatabase db,tablename) iworld
    ......
    Libraries/iTasks/Extensions/User.icl
    View file @ 6f4f6f10
    ......@@ -124,17 +124,15 @@ where
    derive class iTask Credentials
    currentUser :: SDSLens () User User
    currentUser = sdsLens "currentUser" id (SDSRead userFromAttr) (SDSWrite userToAttr) (SDSNotify notify) reducer currentTaskInstanceAttributes
    currentUser = sdsLens "currentUser" id (SDSRead userFromAttr) (SDSWrite userToAttr) (SDSNotify notify) Nothing currentTaskInstanceAttributes
    where
    notify _ _ _ = const (const True)
    taskInstanceUser :: SDSLens InstanceNo User User
    taskInstanceUser = sdsLens "taskInstanceUser" id (SDSRead userFromAttr) (SDSWrite userToAttr) (SDSNotify notify) reducer taskInstanceAttributesByNo
    taskInstanceUser = sdsLens "taskInstanceUser" id (SDSRead userFromAttr) (SDSWrite userToAttr) (SDSNotify notify) Nothing taskInstanceAttributesByNo
    where
    notify _ _ _ = const (const True)
    reducer p ws = userFromAttr () ws
    userFromAttr :: a TaskAttributes -> MaybeError TaskException User
    userFromAttr _ attr = case 'DM'.get "auth-user" attr of
    Just userId = Ok (AuthenticatedUser userId (maybe [] (split ",") ('DM'.get "auth-roles" attr)) ('DM'.get "auth-title" attr))
    ......@@ -142,25 +140,25 @@ userFromAttr _ attr = case 'DM'.get "auth-user" attr of
    Just session = Ok (AnonymousUser session)
    _ = Ok SystemUser
    userToAttr :: a TaskAttributes User -> MaybeError TaskException (MaybeSDSWrite TaskAttributes)
    userToAttr :: a TaskAttributes User -> MaybeError TaskException (Maybe TaskAttributes)
    userToAttr _ attr (AuthenticatedUser userId userRoles userTitle)
    //Update user properties
    # attr = 'DM'.put "auth-user" userId attr
    # attr = if (isEmpty userRoles) ('DM'.del "auth-roles" attr) ('DM'.put "auth-roles" (join "," userRoles) attr)
    # attr = maybe ('DM'.del "auth-title" attr) (\title -> 'DM'.put "auth-title" title attr) userTitle
    = Ok (DoWrite attr)
    = Ok (Just attr)
    userToAttr _ attr _
    //Remove user properties
    # attr = 'DM'.del "auth-user" attr
    # attr = 'DM'.del "auth-roles" attr
    # attr = 'DM'.del "auth-title" attr
    = Ok (DoWrite attr)
    = Ok (Just attr)
    processesForUser :: User -> SDSLens () [TaskListItem ()] ()
    processesForUser user = mapRead (filter (forWorker user)) currentProcesses
    processesForCurrentUser :: SDSLens () [TaskListItem ()] ()
    processesForCurrentUser = mapRead readPrj ((currentProcesses >*| currentUser) id)
    processesForCurrentUser = mapRead readPrj ((currentProcesses >*| currentUser))
    where
    readPrj (items,user) = filter (forWorker user) items
    ......@@ -175,10 +173,10 @@ forWorker user {TaskListItem|attributes} = case 'DM'.get "user" attributes of
    Nothing = True
    taskInstancesForUser :: SDSLens User [TaskInstance] ()
    taskInstancesForUser = sdsLens "taskInstancesForUser" (const ()) (SDSRead read) (SDSWriteConst write) (SDSNotify notify) (\_ _ -> Ok ()) detachedTaskInstances
    taskInstancesForUser = sdsLens "taskInstancesForUser" (const ()) (SDSRead read) (SDSWriteConst write) (SDSNotify notify) Nothing detachedTaskInstances
    where
    read u instances = Ok (filter (forUser u) instances)
    write _ () = Ok (DoNotWrite ())
    write _ () = Ok Nothing
    notify _ _ _ = const (const False)
    forUser user {TaskInstance|attributes} = case 'DM'.get "user" attributes of
    ......@@ -198,8 +196,8 @@ taskInstancesForCurrentUser
    id
    (\() u -> u)
    (\_ _ -> Right snd)
    (SDSWrite (\_ u _ -> Ok (DoNotWrite u)))
    (SDSWriteConst (\_ _ -> Ok (DoNotWrite ())))
    (SDSWrite (\_ _ _ -> Ok Nothing))
    (SDSWriteConst (\_ _ -> Ok Nothing))
    currentUser
    taskInstancesForUser
    ......
    Libraries/iTasks/Extensions/Web.icl
    View file @ 6f4f6f10
    ......@@ -60,7 +60,7 @@ serveWebService port handler
    @! ()
    where
    manageConnections io
    = tcplisten port False ((currentTimespec |*< io) (const ()))
    = tcplisten port False (currentTimespec |*< io)
    {ConnectionHandlers|onConnect=onConnect,onData=onData,onShareChange=onShareChange,onDisconnect=onDisconnect}
    onConnect client_name (now,io)
    ......
    Libraries/iTasks/Internal/Distributed/Symbols.dcl
    View file @ 6f4f6f10
    ......@@ -13,7 +13,7 @@ from iTasks.SDS.Definition import :: SDSLens
    symbolsShare :: SDSLens () String String
    storeSymbols :: String !*IWorld -> (MaybeError TaskException String, !*IWorld)
    storeSymbols :: String !*IWorld -> (MaybeError TaskException Int, !*IWorld)
    accSymbols :: ({#Symbol} -> a) -> Task a | iTask a
    ......
    Libraries/iTasks/Internal/Distributed/Symbols.icl
    View file @ 6f4f6f10
    ......@@ -4,6 +4,7 @@ import iTasks
    import StdFile
    import StdDebug
    import StdArray
    import symbols_in_program
    import dynamic_string
    import Text.Encodings.Base64
    ......@@ -15,13 +16,13 @@ import iTasks.Internal.IWorld
    symbolsShare :: SDSLens () String String
    symbolsShare = sharedStore "symbols" ""
    storeSymbols :: String !*IWorld -> (MaybeError TaskException String, !*IWorld)
    storeSymbols :: String !*IWorld -> (MaybeError TaskException Int, !*IWorld)
    storeSymbols file iworld
    # (symbols, iworld) = accFiles (read_symbols file) iworld
    # val = base64Encode (copy_to_string symbols)
    # (res, iworld) = write val symbolsShare EmptyContext iworld
    | isError res = (liftError res, iworld)
    = (Ok val, iworld)
    = (Ok (size symbols), iworld)
    accSymbols :: ({#Symbol} -> a) -> Task a | iTask a
    accSymbols fun = mkInstantTask eval
    ......@@ -41,4 +42,4 @@ where
    eval event evalOpts state iworld
    # (val, iworld) = read symbolsShare EmptyContext iworld
    = case val of
    Ok (ReadResult val _) = let (Task eval`) = taskfun (fst (copy_from_string (base64Decode val))) in eval` event evalOpts state iworld
    Ok (ReadResult val _) = let (Task eval`) = taskfun (fst (copy_from_string (base64Decode val))) in eval` event evalOpts state iworld
    \ No newline at end of file
    Libraries/iTasks/Internal/IWorld.dcl
    View file @ 6f4f6f10
    ......@@ -18,7 +18,7 @@ from iTasks.Internal.TaskEval import :: TaskTime
    from iTasks.WF.Definition import :: TaskValue, :: Event, :: TaskId, :: InstanceNo, :: TaskNo, :: TaskException
    from iTasks.WF.Combinators.Core import :: ParallelTaskType, :: TaskListItem
    from iTasks.Internal.SDS import :: SDSNotifyRequest, :: DeferredWrite, :: SDSIdentity
    from iTasks.SDS.Definition import :: SDSSource, :: SDSLens
    from iTasks.SDS.Definition import :: SDSSource, :: SDSLens, :: SDSParallel
    from iTasks.Extensions.DateTime import :: Time, :: Date, :: DateTime
    from Sapl.Linker.LazyLinker import :: LoaderState
    ......@@ -154,8 +154,8 @@ iworldTimespec :: SDSSource (ClockParameter Timespec) Timespec Timespec
    */
    iworldTimespecNextFire :: Timespec Timespec (ClockParameter Timespec) -> Timespec
    iworldTimestamp :: SDSLens (ClockParameter Timestamp) Timestamp Timestamp
    iworldLocalDateTime :: SDSLens () DateTime ()
    iworldTimestamp :: SDSLens (ClockParameter Timestamp) Timestamp Timestamp
    iworldLocalDateTime :: SDSParallel () DateTime ()
    iworldLocalDateTime` :: !*IWorld -> (!DateTime, !*IWorld)
    ......
    Libraries/iTasks/Internal/IWorld.icl
    View file @ 6f4f6f10
    ......@@ -141,20 +141,19 @@ where
    toT x = {tv_sec=toInt (x/toInteger 1000000000), tv_nsec=toInt (x rem toInteger 1000000000)}
    iworldTimestamp :: SDSLens (ClockParameter Timestamp) Timestamp Timestamp
    iworldTimestamp = mapReadWrite (timespecToStamp, \w r. DoWrite (timestampToSpec w)) (\_ s. Ok (timespecToStamp s))
    iworldTimestamp = mapReadWrite (timespecToStamp, \w r. Just (timestampToSpec w)) (Just \_ s. Ok (timespecToStamp s))
    $ sdsTranslate "iworldTimestamp translation" (\{start,interval}->{start=timestampToSpec start,interval=timestampToSpec interval}) iworldTimespec
    iworldLocalDateTime :: SDSLens () DateTime ()
    iworldLocalDateTime = toReadOnly (SDSParallel (createReadOnlySDS \_ -> iworldLocalDateTime`) (sdsFocus {start=Timestamp 0,interval=Timestamp 1} iworldTimestamp) sdsPar) (const ())
    iworldLocalDateTime :: SDSParallel () DateTime ()
    iworldLocalDateTime = SDSParallel (createReadOnlySDS \_ -> iworldLocalDateTime`) (sdsFocus {start=Timestamp 0,interval=Timestamp 1} iworldTimestamp) sdsPar
    where
    // ignore value, but use notifications for 'iworldTimestamp'
    sdsPar = { SDSParallelOptions
    | name = "iworldLocalDateTime"
    , param = \p -> (p,p)
    , read = fst
    , writel = SDSWrite \_ _ _ -> Ok (DoNotWrite ())
    , writer = SDSWrite \_ t _ -> Ok (DoNotWrite t)
    , reducer = \_ _ -> Ok ()
    , writel = SDSWriteConst \_ _ -> Ok Nothing
    , writer = SDSWriteConst \_ _ -> Ok Nothing
    }
    iworldLocalDateTime` :: !*IWorld -> (!DateTime, !*IWorld)
    ......
    Libraries/iTasks/Internal/SDS.icl
    View file @ 6f4f6f10
    This diff is collapsed.
    Libraries/iTasks/Internal/TaskStore.icl
    View file @ 6f4f6f10
    This diff is collapsed.
    Libraries/iTasks/Internal/Tonic/Server.icl
    View file @ 6f4f6f10
    ......@@ -41,7 +41,7 @@ recordingsShare :: SDSLens () (Map DateTime [TonicMessage]) (Map DateTime [Tonic
    recordingsShare = sharedStore "recordingsShare" 'DM'.newMap
    recordingForDateTimeShare :: SDSLens DateTime [TonicMessage] ()
    recordingForDateTimeShare = toReadOnly (mapLens "recordingForDateTimeShare" recordingsShare (Just [])) id
    recordingForDateTimeShare = toReadOnly (mapLens "recordingForDateTimeShare" recordingsShare (Just []))
    newRTMapFromMessages :: [TonicMessage] -> Task TonicGenRTMap
    newRTMapFromMessages xs = updRTMapFromMessages xs 'DM'.newMap
    ......@@ -171,7 +171,7 @@ where
    startViewer
    = enterChoiceWithShared "Select blueprint" [] (mapRead (\ts -> 'DL'.concatMap f ts.ts_allMsgs) tonicServerShare)
    >&> withSelection noSel (
    (\bp -> whileUnchanged ((tonicServerShare |*| shViewerSettings) id)
    (\bp -> whileUnchanged (tonicServerShare |*| shViewerSettings)
    (\x=:(tms, _) -> (runViewer x -|| forever (viewInformation () [] () >>* [ startAction tms
    , pauseAction tms
    , continueAction tms
    ......
    Libraries/iTasks/Internal/Tonic/Shares.icl
    View file @ 6f4f6f10
    ......@@ -27,7 +27,7 @@ storedOutputEditors = sdsTranslate "storedOutputEditors" (\t -> t +++> "-storedO
    (removeMaybe (Just 'DM'.newMap) memoryShare)
    outputForTaskId :: SDSLens (TaskId, ExprId) (TaskId, Int, Task (), TStability) (TaskId, Int, Task (), TStability)
    outputForTaskId = sdsLens "outputForTaskId" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) reducer storedOutputEditors
    outputForTaskId = sdsLens "outputForTaskId" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) (Just reducer) storedOutputEditors
    where
    reducer p ws = read p ws
    ......@@ -38,8 +38,8 @@ outputForTaskId = sdsLens "outputForTaskId" (const ()) (SDSRead read) (SDSWrite
    Ok ('DM'.get oid trtMap)
    write :: (TaskId, ExprId) (Map (TaskId, ExprId) (TaskId, Int, Task (), TStability)) (TaskId, Int, Task (), TStability)
    -> MaybeError TaskException (MaybeSDSWrite (Map (TaskId, ExprId) (TaskId, Int, Task (), TStability)))
    write tid trtMap bpref = Ok (DoWrite ('DM'.put tid bpref trtMap))
    -> MaybeError TaskException (Maybe (Map (TaskId, ExprId) (TaskId, Int, Task (), TStability)))
    write tid trtMap bpref = Ok (Just ('DM'.put tid bpref trtMap))
    notify :: (TaskId, ExprId) (Map (TaskId, ExprId) (TaskId, Int, Task (), TStability)) (TaskId, Int, Task (), TStability)
    -> SDSNotifyPred (TaskId, ExprId)
    ......@@ -52,7 +52,7 @@ tonicSharedRT = sdsTranslate "tonicSharedRT" (\t -> t +++> "-tonicSharedRT")
    (memoryStore NS_TONIC_INSTANCES (Just 'DM'.newMap))
    allTonicInstances :: SDSLens TaskId [((ModuleName, FuncName), BlueprintInstance)] ()
    allTonicInstances = sdsLens "allTonicInstances" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) (\_ _ -> Ok ()) tonicSharedRT
    allTonicInstances = sdsLens "allTonicInstances" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) (Just \_ _ -> Ok ()) tonicSharedRT
    where
    //read :: (TaskId, ModuleName, FuncName) TonicRTMap -> MaybeError TaskException (Maybe BlueprintInstance) BlueprintInstance
    read tid trtMap = Ok (fromMaybe [] ('DM'.get tid trtMap))
    ......@@ -64,13 +64,13 @@ where
    notify tid oldmap inst = \_ tid` -> False
    tonicInstances :: SDSLens (TaskId, ModuleName, FuncName) (Maybe BlueprintInstance) BlueprintInstance
    tonicInstances = sdsLens "tonicInstances" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) reducer tonicSharedRT
    tonicInstances = sdsLens "tonicInstances" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) (Just reducer) tonicSharedRT
    where
    read :: (TaskId, ModuleName, FuncName) TonicRTMap -> MaybeError TaskException (Maybe BlueprintInstance)
    read (tid, mn, fn) trtMap = Ok ('DM'.get tid trtMap >>= 'DM'.get (mn, fn) o 'DM'.fromList)
    write :: (TaskId, ModuleName, FuncName) TonicRTMap BlueprintInstance -> MaybeError TaskException (MaybeSDSWrite TonicRTMap)
    write (tid, mn, fn) trtMap bpref = Ok (DoWrite (case 'DM'.get tid trtMap of
    write :: (TaskId, ModuleName, FuncName) TonicRTMap BlueprintInstance -> MaybeError TaskException (Maybe TonicRTMap)
    write (tid, mn, fn) trtMap bpref = Ok (Just (case 'DM'.get tid trtMap of
    Just im -> let xs = [if (mn == mn` && fn == fn`) (True, ((mn`, fn`), {bpref & bpi_index = i})) (False, ((mn`, fn`), {bpref` & bpi_index = i})) \\ (i, ((mn`, fn`), bpref`)) <- zip2 [0..] im]
    elems = map snd xs
    in 'DM'.put tid (if (or (map fst xs))
    ......@@ -94,7 +94,7 @@ tonicEnabledSteps = sdsTranslate "tonicEnabledSteps" (\t -> t +++> "-tonicEnable
    (memoryStore NS_TONIC_INSTANCES (Just 'DM'.newMap))
    tonicActionsForTaskID :: SDSLens TaskId (Map ExprId [UI]) (Map ExprId [UI])
    tonicActionsForTaskID = sdsLens "tonicActionsForTaskID" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) reducer tonicEnabledSteps
    tonicActionsForTaskID = sdsLens "tonicActionsForTaskID" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) (Just reducer) tonicEnabledSteps
    where
    read :: TaskId (Map TaskId (Map ExprId [UI])) -> MaybeError TaskException (Map ExprId [UI])
    read tid acts
    ......@@ -102,9 +102,9 @@ tonicActionsForTaskID = sdsLens "tonicActionsForTaskID" (const ()) (SDSRead read
    Just acts` -> Ok acts`
    _ -> Ok 'DM'.newMap
    write :: TaskId (Map TaskId (Map ExprId [UI])) (Map ExprId [UI]) -> MaybeError TaskException (MaybeSDSWrite (Map TaskId (Map ExprId [UI])))
    write :: TaskId (Map TaskId (Map ExprId [UI])) (Map ExprId [UI]) -> MaybeError TaskException (Maybe (Map TaskId (Map ExprId [UI])))
    write tid oldmap acts
    = Ok (DoWrite ('DM'.put tid acts oldmap))
    = Ok (Just ('DM'.put tid acts oldmap))
    notify :: TaskId (Map TaskId (Map ExprId [UI])) (Map ExprId [UI]) -> SDSNotifyPred TaskId
    notify tid oldmap acts = \_ tid` -> case read tid oldmap of
    ......@@ -114,7 +114,7 @@ tonicActionsForTaskID = sdsLens "tonicActionsForTaskID" (const ()) (SDSRead read
    reducer p ws = read p ws
    tonicActionsForTaskIDAndExpr :: SDSLens (TaskId, ExprId) [UI] [UI]
    tonicActionsForTaskIDAndExpr = sdsLens "tonicActionsForTaskIDAndExpr" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) reducer tonicEnabledSteps
    tonicActionsForTaskIDAndExpr = sdsLens "tonicActionsForTaskIDAndExpr" (const ()) (SDSRead read) (SDSWrite write) (SDSNotify notify) (Just reducer) tonicEnabledSteps
    where
    read :: (TaskId, ExprId) (Map TaskId (Map ExprId [UI])) -> MaybeError TaskException [UI]
    read (tid, eid) acts
    ......@@ -124,13 +124,13 @@ tonicActionsForTaskIDAndExpr = sdsLens "tonicActionsForTaskIDAndExpr" (const ())
    _ -> Ok []
    _ -> Ok []
    write :: (TaskId, ExprId) (Map TaskId (Map ExprId [UI])) [UI] -> MaybeError TaskException (MaybeSDSWrite (Map TaskId (Map ExprId [UI])))
    write :: (TaskId, ExprId) (Map TaskId (Map ExprId [UI])) [UI] -> MaybeError TaskException (Maybe (Map TaskId (Map ExprId [UI])))
    write (tid, eid) oldmap acts
    # m = case 'DM'.get tid oldmap of
    Just acts` -> acts`
    _ -> 'DM'.newMap
    # m = 'DM'.put eid acts m
    = Ok (DoWrite ('DM'.put tid m oldmap))
    = Ok (Just ('DM'.put tid m oldmap))
    notify :: (TaskId, ExprId) (Map TaskId (Map ExprId [UI])) [UI] -> SDSNotifyPred (TaskId, ExprId)
    notify tid oldmap acts = \_ tid` -> case read tid oldmap of
    ......
    Libraries/iTasks/SDS/Combinators/Common.dcl
    View file @ 6f4f6f10
    ......@@ -25,20 +25,20 @@ from Text.GenJSON import :: JSONNode, generic JSONEncode, generic JSONDecode